diff options
| author | Keith Seitz <keiths@redhat.com> | 2002-09-24 19:55:43 +0000 |
|---|---|---|
| committer | Keith Seitz <keiths@redhat.com> | 2002-09-24 19:55:43 +0000 |
| commit | 0e8f9dd357b81ada6f8f4a215b928d63ca983f97 (patch) | |
| tree | 7474a17bfcb82d128f44269ac686c462e2fc191e /tcl/generic | |
| parent | e18731d328254b7e926369741b282fbffc840ea5 (diff) | |
| download | gdb-0e8f9dd357b81ada6f8f4a215b928d63ca983f97.tar.gz | |
import tcl 8.4.0
Diffstat (limited to 'tcl/generic')
78 files changed, 36072 insertions, 15191 deletions
diff --git a/tcl/generic/regc_cvec.c b/tcl/generic/regc_cvec.c index 86765ea1f73..d2d56fc70a2 100644 --- a/tcl/generic/regc_cvec.c +++ b/tcl/generic/regc_cvec.c @@ -36,26 +36,27 @@ */ static struct cvec * newcvec(nchrs, nranges, nmcces) -int nchrs; /* to hold this many chrs... */ -int nranges; /* ... and this many ranges... */ -int nmcces; /* ... and this many MCCEs */ + int nchrs; /* to hold this many chrs... */ + int nranges; /* ... and this many ranges... */ + int nmcces; /* ... and this many MCCEs */ { - size_t n; - size_t nc; - struct cvec *cv; + size_t n; + size_t nc; + struct cvec *cv; - nc = (size_t)nchrs + (size_t)nmcces*(MAXMCCE+1) + (size_t)nranges*2; - n = sizeof(struct cvec) + (size_t)(nmcces-1)*sizeof(chr *) + - nc*sizeof(chr); - cv = (struct cvec *)MALLOC(n); - if (cv == NULL) - return NULL; - cv->chrspace = nc; - cv->chrs = (chr *)&cv->mcces[nmcces]; /* chrs just after MCCE ptrs */ - cv->mccespace = nmcces; - cv->ranges = cv->chrs + nchrs + nmcces*(MAXMCCE+1); - cv->rangespace = nranges; - return clearcvec(cv); + nc = (size_t)nchrs + (size_t)nmcces*(MAXMCCE+1) + (size_t)nranges*2; + n = sizeof(struct cvec) + (size_t)(nmcces-1)*sizeof(chr *) + + nc*sizeof(chr); + cv = (struct cvec *)MALLOC(n); + if (cv == NULL) { + return NULL; + } + cv->chrspace = nchrs; + cv->chrs = (chr *)&cv->mcces[nmcces]; /* chrs just after MCCE ptrs */ + cv->mccespace = nmcces; + cv->ranges = cv->chrs + nchrs + nmcces*(MAXMCCE+1); + cv->rangespace = nranges; + return clearcvec(cv); } /* @@ -65,20 +66,21 @@ int nmcces; /* ... and this many MCCEs */ */ static struct cvec * clearcvec(cv) -struct cvec *cv; + struct cvec *cv; /* character vector */ { - int i; + int i; - assert(cv != NULL); - cv->nchrs = 0; - assert(cv->chrs == (chr *)&cv->mcces[cv->mccespace]); - cv->nmcces = 0; - cv->nmccechrs = 0; - cv->nranges = 0; - for (i = 0; i < cv->mccespace; i++) - cv->mcces[i] = NULL; + assert(cv != NULL); + cv->nchrs = 0; + assert(cv->chrs == (chr *)&cv->mcces[cv->mccespace]); + cv->nmcces = 0; + cv->nmccechrs = 0; + cv->nranges = 0; + for (i = 0; i < cv->mccespace; i++) { + cv->mcces[i] = NULL; + } - return cv; + return cv; } /* @@ -87,11 +89,11 @@ struct cvec *cv; */ static VOID addchr(cv, c) -struct cvec *cv; -pchr c; + struct cvec *cv; /* character vector */ + pchr c; /* character to add */ { - assert(cv->nchrs < cv->chrspace - cv->nmccechrs); - cv->chrs[cv->nchrs++] = (chr)c; + assert(cv->nchrs < cv->chrspace - cv->nmccechrs); + cv->chrs[cv->nchrs++] = (chr)c; } /* @@ -100,14 +102,14 @@ pchr c; */ static VOID addrange(cv, from, to) -struct cvec *cv; -pchr from; -pchr to; + struct cvec *cv; /* character vector */ + pchr from; /* first character of range */ + pchr to; /* last character of range */ { - assert(cv->nranges < cv->rangespace); - cv->ranges[cv->nranges*2] = (chr)from; - cv->ranges[cv->nranges*2 + 1] = (chr)to; - cv->nranges++; + assert(cv->nranges < cv->rangespace); + cv->ranges[cv->nranges*2] = (chr)from; + cv->ranges[cv->nranges*2 + 1] = (chr)to; + cv->nranges++; } /* @@ -116,49 +118,55 @@ pchr to; */ static VOID addmcce(cv, startp, endp) -struct cvec *cv; -chr *startp; /* beginning of text */ -chr *endp; /* just past end of text */ + struct cvec *cv; /* character vector */ + chr *startp; /* beginning of text */ + chr *endp; /* just past end of text */ { - int len; - int i; - chr *s; - chr *d; + int len; + int i; + chr *s; + chr *d; - if (startp == NULL && endp == NULL) - return; - len = endp - startp; - assert(len > 0); - assert(cv->nchrs + len < cv->chrspace - cv->nmccechrs); - assert(cv->nmcces < cv->mccespace); - d = &cv->chrs[cv->chrspace - cv->nmccechrs - len - 1]; - cv->mcces[cv->nmcces++] = d; - for (s = startp, i = len; i > 0; s++, i--) - *d++ = *s; - *d++ = 0; /* endmarker */ - assert(d == &cv->chrs[cv->chrspace - cv->nmccechrs]); - cv->nmccechrs += len + 1; + if (startp == NULL && endp == NULL) { + return; + } + len = endp - startp; + assert(len > 0); + assert(cv->nchrs + len < cv->chrspace - cv->nmccechrs); + assert(cv->nmcces < cv->mccespace); + d = &cv->chrs[cv->chrspace - cv->nmccechrs - len - 1]; + cv->mcces[cv->nmcces++] = d; + for (s = startp, i = len; i > 0; s++, i--) { + *d++ = *s; + } + *d++ = 0; /* endmarker */ + assert(d == &cv->chrs[cv->chrspace - cv->nmccechrs]); + cv->nmccechrs += len + 1; } /* - haschr - does a cvec contain this chr? ^ static int haschr(struct cvec *, pchr); */ -static int /* predicate */ +static int /* predicate */ haschr(cv, c) -struct cvec *cv; -pchr c; + struct cvec *cv; /* character vector */ + pchr c; /* character to test for */ { - int i; - chr *p; + int i; + chr *p; - for (p = cv->chrs, i = cv->nchrs; i > 0; p++, i--) - if (*p == c) - return 1; - for (p = cv->ranges, i = cv->nranges; i > 0; p += 2, i--) - if (*p <= c && c <= *(p+1)) - return 1; - return 0; + for (p = cv->chrs, i = cv->nchrs; i > 0; p++, i--) { + if (*p == c) { + return 1; + } + } + for (p = cv->ranges, i = cv->nranges; i > 0; p += 2, i--) { + if ((*p <= c) && (c <= *(p+1))) { + return 1; + } + } + return 0; } /* @@ -167,23 +175,25 @@ pchr c; */ static struct cvec * getcvec(v, nchrs, nranges, nmcces) -struct vars *v; -int nchrs; /* to hold this many chrs... */ -int nranges; /* ... and this many ranges... */ -int nmcces; /* ... and this many MCCEs */ + struct vars *v; /* context */ + int nchrs; /* to hold this many chrs... */ + int nranges; /* ... and this many ranges... */ + int nmcces; /* ... and this many MCCEs */ { - if (v->cv != NULL && nchrs <= v->cv->chrspace && - nranges <= v->cv->rangespace && - nmcces <= v->cv->mccespace) - return clearcvec(v->cv); + if (v->cv != NULL && nchrs <= v->cv->chrspace && + nranges <= v->cv->rangespace && nmcces <= v->cv->mccespace) { + return clearcvec(v->cv); + } - if (v->cv != NULL) - freecvec(v->cv); - v->cv = newcvec(nchrs, nranges, nmcces); - if (v->cv == NULL) - ERR(REG_ESPACE); + if (v->cv != NULL) { + freecvec(v->cv); + } + v->cv = newcvec(nchrs, nranges, nmcces); + if (v->cv == NULL) { + ERR(REG_ESPACE); + } - return v->cv; + return v->cv; } /* @@ -192,7 +202,7 @@ int nmcces; /* ... and this many MCCEs */ */ static VOID freecvec(cv) -struct cvec *cv; + struct cvec *cv; /* character vector */ { - FREE(cv); + FREE(cv); } diff --git a/tcl/generic/regc_locale.c b/tcl/generic/regc_locale.c index 100ba0a9415..695b665b1f2 100644 --- a/tcl/generic/regc_locale.c +++ b/tcl/generic/regc_locale.c @@ -15,105 +15,105 @@ /* ASCII character-name table */ static struct cname { - char *name; - char code; + char *name; + char code; } cnames[] = { - {"NUL", '\0'}, - {"SOH", '\001'}, - {"STX", '\002'}, - {"ETX", '\003'}, - {"EOT", '\004'}, - {"ENQ", '\005'}, - {"ACK", '\006'}, - {"BEL", '\007'}, - {"alert", '\007'}, - {"BS", '\010'}, - {"backspace", '\b'}, - {"HT", '\011'}, - {"tab", '\t'}, - {"LF", '\012'}, - {"newline", '\n'}, - {"VT", '\013'}, - {"vertical-tab", '\v'}, - {"FF", '\014'}, - {"form-feed", '\f'}, - {"CR", '\015'}, - {"carriage-return", '\r'}, - {"SO", '\016'}, - {"SI", '\017'}, - {"DLE", '\020'}, - {"DC1", '\021'}, - {"DC2", '\022'}, - {"DC3", '\023'}, - {"DC4", '\024'}, - {"NAK", '\025'}, - {"SYN", '\026'}, - {"ETB", '\027'}, - {"CAN", '\030'}, - {"EM", '\031'}, - {"SUB", '\032'}, - {"ESC", '\033'}, - {"IS4", '\034'}, - {"FS", '\034'}, - {"IS3", '\035'}, - {"GS", '\035'}, - {"IS2", '\036'}, - {"RS", '\036'}, - {"IS1", '\037'}, - {"US", '\037'}, - {"space", ' '}, - {"exclamation-mark", '!'}, - {"quotation-mark", '"'}, - {"number-sign", '#'}, - {"dollar-sign", '$'}, - {"percent-sign", '%'}, - {"ampersand", '&'}, - {"apostrophe", '\''}, - {"left-parenthesis", '('}, - {"right-parenthesis", ')'}, - {"asterisk", '*'}, - {"plus-sign", '+'}, - {"comma", ','}, - {"hyphen", '-'}, - {"hyphen-minus", '-'}, - {"period", '.'}, - {"full-stop", '.'}, - {"slash", '/'}, - {"solidus", '/'}, - {"zero", '0'}, - {"one", '1'}, - {"two", '2'}, - {"three", '3'}, - {"four", '4'}, - {"five", '5'}, - {"six", '6'}, - {"seven", '7'}, - {"eight", '8'}, - {"nine", '9'}, - {"colon", ':'}, - {"semicolon", ';'}, - {"less-than-sign", '<'}, - {"equals-sign", '='}, - {"greater-than-sign", '>'}, - {"question-mark", '?'}, - {"commercial-at", '@'}, - {"left-square-bracket", '['}, - {"backslash", '\\'}, - {"reverse-solidus", '\\'}, - {"right-square-bracket", ']'}, - {"circumflex", '^'}, - {"circumflex-accent", '^'}, - {"underscore", '_'}, - {"low-line", '_'}, - {"grave-accent", '`'}, - {"left-brace", '{'}, - {"left-curly-bracket", '{'}, - {"vertical-line", '|'}, - {"right-brace", '}'}, - {"right-curly-bracket", '}'}, - {"tilde", '~'}, - {"DEL", '\177'}, - {NULL, 0} + {"NUL", '\0'}, + {"SOH", '\001'}, + {"STX", '\002'}, + {"ETX", '\003'}, + {"EOT", '\004'}, + {"ENQ", '\005'}, + {"ACK", '\006'}, + {"BEL", '\007'}, + {"alert", '\007'}, + {"BS", '\010'}, + {"backspace", '\b'}, + {"HT", '\011'}, + {"tab", '\t'}, + {"LF", '\012'}, + {"newline", '\n'}, + {"VT", '\013'}, + {"vertical-tab", '\v'}, + {"FF", '\014'}, + {"form-feed", '\f'}, + {"CR", '\015'}, + {"carriage-return", '\r'}, + {"SO", '\016'}, + {"SI", '\017'}, + {"DLE", '\020'}, + {"DC1", '\021'}, + {"DC2", '\022'}, + {"DC3", '\023'}, + {"DC4", '\024'}, + {"NAK", '\025'}, + {"SYN", '\026'}, + {"ETB", '\027'}, + {"CAN", '\030'}, + {"EM", '\031'}, + {"SUB", '\032'}, + {"ESC", '\033'}, + {"IS4", '\034'}, + {"FS", '\034'}, + {"IS3", '\035'}, + {"GS", '\035'}, + {"IS2", '\036'}, + {"RS", '\036'}, + {"IS1", '\037'}, + {"US", '\037'}, + {"space", ' '}, + {"exclamation-mark",'!'}, + {"quotation-mark", '"'}, + {"number-sign", '#'}, + {"dollar-sign", '$'}, + {"percent-sign", '%'}, + {"ampersand", '&'}, + {"apostrophe", '\''}, + {"left-parenthesis",'('}, + {"right-parenthesis", ')'}, + {"asterisk", '*'}, + {"plus-sign", '+'}, + {"comma", ','}, + {"hyphen", '-'}, + {"hyphen-minus", '-'}, + {"period", '.'}, + {"full-stop", '.'}, + {"slash", '/'}, + {"solidus", '/'}, + {"zero", '0'}, + {"one", '1'}, + {"two", '2'}, + {"three", '3'}, + {"four", '4'}, + {"five", '5'}, + {"six", '6'}, + {"seven", '7'}, + {"eight", '8'}, + {"nine", '9'}, + {"colon", ':'}, + {"semicolon", ';'}, + {"less-than-sign", '<'}, + {"equals-sign", '='}, + {"greater-than-sign", '>'}, + {"question-mark", '?'}, + {"commercial-at", '@'}, + {"left-square-bracket", '['}, + {"backslash", '\\'}, + {"reverse-solidus", '\\'}, + {"right-square-bracket", ']'}, + {"circumflex", '^'}, + {"circumflex-accent", '^'}, + {"underscore", '_'}, + {"low-line", '_'}, + {"grave-accent", '`'}, + {"left-brace", '{'}, + {"left-curly-bracket", '{'}, + {"vertical-line", '|'}, + {"right-brace", '}'}, + {"right-curly-bracket", '}'}, + {"tilde", '~'}, + {"DEL", '\177'}, + {NULL, 0} }; /* Unicode character-class tables */ @@ -123,17 +123,22 @@ typedef struct crange { chr end; } crange; -/* Unicode: (Alphabetic) */ +/* + * Declarations of Unicode character ranges. This code + * is automatically generated by the tools/uniClass.tcl script + * and used in generic/regc_locale.c. Do not modify by hand. + */ + +/* Unicode: alphabetic characters */ static crange alphaRangeTable[] = { {0x0041, 0x005a}, {0x0061, 0x007a}, {0x00c0, 0x00d6}, {0x00d8, 0x00f6}, - {0x00f8, 0x01f5}, {0x01fa, 0x0217}, {0x0250, 0x02a8}, {0x02b0, 0x02b8}, + {0x00f8, 0x021f}, {0x0222, 0x0233}, {0x0250, 0x02ad}, {0x02b0, 0x02b8}, {0x02bb, 0x02c1}, {0x02e0, 0x02e4}, {0x0388, 0x038a}, {0x038e, 0x03a1}, - {0x03a3, 0x03ce}, {0x03d0, 0x03d6}, {0x03e2, 0x03f3}, {0x0401, 0x040c}, - {0x040e, 0x044f}, {0x0451, 0x045c}, {0x045e, 0x0481}, {0x0490, 0x04c4}, - {0x04d0, 0x04eb}, {0x04ee, 0x04f5}, {0x0531, 0x0556}, {0x0561, 0x0587}, + {0x03a3, 0x03ce}, {0x03d0, 0x03d7}, {0x03da, 0x03f5}, {0x0400, 0x0481}, + {0x048c, 0x04c4}, {0x04d0, 0x04f5}, {0x0531, 0x0556}, {0x0561, 0x0587}, {0x05d0, 0x05ea}, {0x05f0, 0x05f2}, {0x0621, 0x063a}, {0x0640, 0x064a}, - {0x0671, 0x06b7}, {0x06ba, 0x06be}, {0x06c0, 0x06ce}, {0x06d0, 0x06d3}, + {0x0671, 0x06d3}, {0x06fa, 0x06fc}, {0x0712, 0x072c}, {0x0780, 0x07a5}, {0x0905, 0x0939}, {0x0958, 0x0961}, {0x0985, 0x098c}, {0x0993, 0x09a8}, {0x09aa, 0x09b0}, {0x09b6, 0x09b9}, {0x09df, 0x09e1}, {0x0a05, 0x0a0a}, {0x0a13, 0x0a28}, {0x0a2a, 0x0a30}, {0x0a59, 0x0a5c}, {0x0a72, 0x0a74}, @@ -144,90 +149,104 @@ static crange alphaRangeTable[] = { {0x0c05, 0x0c0c}, {0x0c0e, 0x0c10}, {0x0c12, 0x0c28}, {0x0c2a, 0x0c33}, {0x0c35, 0x0c39}, {0x0c85, 0x0c8c}, {0x0c8e, 0x0c90}, {0x0c92, 0x0ca8}, {0x0caa, 0x0cb3}, {0x0cb5, 0x0cb9}, {0x0d05, 0x0d0c}, {0x0d0e, 0x0d10}, - {0x0d12, 0x0d28}, {0x0d2a, 0x0d39}, {0x0e01, 0x0e30}, {0x0e40, 0x0e46}, + {0x0d12, 0x0d28}, {0x0d2a, 0x0d39}, {0x0d85, 0x0d96}, {0x0d9a, 0x0db1}, + {0x0db3, 0x0dbb}, {0x0dc0, 0x0dc6}, {0x0e01, 0x0e30}, {0x0e40, 0x0e46}, {0x0e94, 0x0e97}, {0x0e99, 0x0e9f}, {0x0ea1, 0x0ea3}, {0x0ead, 0x0eb0}, - {0x0ec0, 0x0ec4}, {0x0f40, 0x0f47}, {0x0f49, 0x0f69}, {0x0f88, 0x0f8b}, - {0x10a0, 0x10c5}, {0x10d0, 0x10f6}, {0x1100, 0x1159}, {0x115f, 0x11a2}, - {0x11a8, 0x11f9}, {0x1e00, 0x1e9b}, {0x1ea0, 0x1ef9}, {0x1f00, 0x1f15}, - {0x1f18, 0x1f1d}, {0x1f20, 0x1f45}, {0x1f48, 0x1f4d}, {0x1f50, 0x1f57}, - {0x1f5f, 0x1f7d}, {0x1f80, 0x1fb4}, {0x1fb6, 0x1fbc}, {0x1fc2, 0x1fc4}, - {0x1fc6, 0x1fcc}, {0x1fd0, 0x1fd3}, {0x1fd6, 0x1fdb}, {0x1fe0, 0x1fec}, - {0x1ff2, 0x1ff4}, {0x1ff6, 0x1ffc}, {0x210a, 0x2113}, {0x2118, 0x211d}, - {0x212a, 0x2131}, {0x2133, 0x2138}, {0x3031, 0x3035}, {0x3041, 0x3094}, - {0x30a1, 0x30fa}, {0x30fc, 0x30fe}, {0x3105, 0x312c}, {0x3131, 0x318e}, - {0x4e00, 0x9fa5}, {0xac00, 0xd7a3}, {0xf900, 0xfa2d}, {0xfb00, 0xfb06}, - {0xfb13, 0xfb17}, {0xfb1f, 0xfb28}, {0xfb2a, 0xfb36}, {0xfb38, 0xfb3c}, - {0xfb46, 0xfbb1}, {0xfbd3, 0xfd3d}, {0xfd50, 0xfd8f}, {0xfd92, 0xfdc7}, - {0xfdf0, 0xfdfb}, {0xfe70, 0xfe72}, {0xfe76, 0xfefc}, {0xff21, 0xff3a}, - {0xff41, 0xff5a}, {0xff66, 0xffbe}, {0xffc2, 0xffc7}, {0xffca, 0xffcf}, - {0xffd2, 0xffd7}, {0xffda, 0xffdc} + {0x0ec0, 0x0ec4}, {0x0f40, 0x0f47}, {0x0f49, 0x0f6a}, {0x0f88, 0x0f8b}, + {0x1000, 0x1021}, {0x1023, 0x1027}, {0x1050, 0x1055}, {0x10a0, 0x10c5}, + {0x10d0, 0x10f6}, {0x1100, 0x1159}, {0x115f, 0x11a2}, {0x11a8, 0x11f9}, + {0x1200, 0x1206}, {0x1208, 0x1246}, {0x124a, 0x124d}, {0x1250, 0x1256}, + {0x125a, 0x125d}, {0x1260, 0x1286}, {0x128a, 0x128d}, {0x1290, 0x12ae}, + {0x12b2, 0x12b5}, {0x12b8, 0x12be}, {0x12c2, 0x12c5}, {0x12c8, 0x12ce}, + {0x12d0, 0x12d6}, {0x12d8, 0x12ee}, {0x12f0, 0x130e}, {0x1312, 0x1315}, + {0x1318, 0x131e}, {0x1320, 0x1346}, {0x1348, 0x135a}, {0x13a0, 0x13f4}, + {0x1401, 0x166c}, {0x166f, 0x1676}, {0x1681, 0x169a}, {0x16a0, 0x16ea}, + {0x1780, 0x17b3}, {0x1820, 0x1877}, {0x1880, 0x18a8}, {0x1e00, 0x1e9b}, + {0x1ea0, 0x1ef9}, {0x1f00, 0x1f15}, {0x1f18, 0x1f1d}, {0x1f20, 0x1f45}, + {0x1f48, 0x1f4d}, {0x1f50, 0x1f57}, {0x1f5f, 0x1f7d}, {0x1f80, 0x1fb4}, + {0x1fb6, 0x1fbc}, {0x1fc2, 0x1fc4}, {0x1fc6, 0x1fcc}, {0x1fd0, 0x1fd3}, + {0x1fd6, 0x1fdb}, {0x1fe0, 0x1fec}, {0x1ff2, 0x1ff4}, {0x1ff6, 0x1ffc}, + {0x210a, 0x2113}, {0x2119, 0x211d}, {0x212a, 0x212d}, {0x212f, 0x2131}, + {0x2133, 0x2139}, {0x3031, 0x3035}, {0x3041, 0x3094}, {0x30a1, 0x30fa}, + {0x30fc, 0x30fe}, {0x3105, 0x312c}, {0x3131, 0x318e}, {0x31a0, 0x31b7}, + {0x3400, 0x4db5}, {0x4e00, 0x9fa5}, {0xa000, 0xa48c}, {0xac00, 0xd7a3}, + {0xf900, 0xfa2d}, {0xfb00, 0xfb06}, {0xfb13, 0xfb17}, {0xfb1f, 0xfb28}, + {0xfb2a, 0xfb36}, {0xfb38, 0xfb3c}, {0xfb46, 0xfbb1}, {0xfbd3, 0xfd3d}, + {0xfd50, 0xfd8f}, {0xfd92, 0xfdc7}, {0xfdf0, 0xfdfb}, {0xfe70, 0xfe72}, + {0xfe76, 0xfefc}, {0xff21, 0xff3a}, {0xff41, 0xff5a}, {0xff66, 0xffbe}, + {0xffc2, 0xffc7}, {0xffca, 0xffcf}, {0xffd2, 0xffd7}, {0xffda, 0xffdc} }; #define NUM_ALPHA_RANGE (sizeof(alphaRangeTable)/sizeof(crange)) static chr alphaCharTable[] = { - 0x00aa, 0x00b5, 0x00ba, 0x02d0, 0x02d1, 0x037a, 0x0386, 0x038c, 0x03da, - 0x03dc, 0x03de, 0x03e0, 0x04c7, 0x04c8, 0x04cb, 0x04cc, 0x04f8, 0x04f9, - 0x0559, 0x06d5, 0x06e5, 0x06e6, 0x093d, 0x0950, 0x098f, 0x0990, 0x09b2, - 0x09dc, 0x09dd, 0x09f0, 0x09f1, 0x0a0f, 0x0a10, 0x0a32, 0x0a33, 0x0a35, - 0x0a36, 0x0a38, 0x0a39, 0x0a5e, 0x0a8d, 0x0ab2, 0x0ab3, 0x0abd, 0x0ad0, - 0x0ae0, 0x0b0f, 0x0b10, 0x0b32, 0x0b33, 0x0b3d, 0x0b5c, 0x0b5d, 0x0b99, - 0x0b9a, 0x0b9c, 0x0b9e, 0x0b9f, 0x0ba3, 0x0ba4, 0x0c60, 0x0c61, 0x0cde, - 0x0ce0, 0x0ce1, 0x0d60, 0x0d61, 0x0e32, 0x0e33, 0x0e81, 0x0e82, 0x0e84, - 0x0e87, 0x0e88, 0x0e8a, 0x0e8d, 0x0ea5, 0x0ea7, 0x0eaa, 0x0eab, 0x0eb2, - 0x0eb3, 0x0ebd, 0x0ec6, 0x0edc, 0x0edd, 0x0f00, 0x1f59, 0x1f5b, 0x1f5d, - 0x1fbe, 0x207f, 0x2102, 0x2107, 0x2115, 0x2124, 0x2126, 0x2128, 0x3005, - 0x3006, 0x309d, 0x309e, 0xfb3e, 0xfb40, 0xfb41, 0xfb43, 0xfb44, 0xfe74 + 0x00aa, 0x00b5, 0x00ba, 0x02d0, 0x02d1, 0x02ee, 0x037a, 0x0386, 0x038c, + 0x04c7, 0x04c8, 0x04cb, 0x04cc, 0x04f8, 0x04f9, 0x0559, 0x06d5, 0x06e5, + 0x06e6, 0x0710, 0x093d, 0x0950, 0x098f, 0x0990, 0x09b2, 0x09dc, 0x09dd, + 0x09f0, 0x09f1, 0x0a0f, 0x0a10, 0x0a32, 0x0a33, 0x0a35, 0x0a36, 0x0a38, + 0x0a39, 0x0a5e, 0x0a8d, 0x0ab2, 0x0ab3, 0x0abd, 0x0ad0, 0x0ae0, 0x0b0f, + 0x0b10, 0x0b32, 0x0b33, 0x0b3d, 0x0b5c, 0x0b5d, 0x0b99, 0x0b9a, 0x0b9c, + 0x0b9e, 0x0b9f, 0x0ba3, 0x0ba4, 0x0c60, 0x0c61, 0x0cde, 0x0ce0, 0x0ce1, + 0x0d60, 0x0d61, 0x0dbd, 0x0e32, 0x0e33, 0x0e81, 0x0e82, 0x0e84, 0x0e87, + 0x0e88, 0x0e8a, 0x0e8d, 0x0ea5, 0x0ea7, 0x0eaa, 0x0eab, 0x0eb2, 0x0eb3, + 0x0ebd, 0x0ec6, 0x0edc, 0x0edd, 0x0f00, 0x1029, 0x102a, 0x1248, 0x1258, + 0x1288, 0x12b0, 0x12c0, 0x1310, 0x1f59, 0x1f5b, 0x1f5d, 0x1fbe, 0x207f, + 0x2102, 0x2107, 0x2115, 0x2124, 0x2126, 0x2128, 0x3005, 0x3006, 0x309d, + 0x309e, 0xfb1d, 0xfb3e, 0xfb40, 0xfb41, 0xfb43, 0xfb44, 0xfe74, 0xfffe }; #define NUM_ALPHA_CHAR (sizeof(alphaCharTable)/sizeof(chr)) -/* Unicode: (Decimal digit) */ +/* Unicode: decimal digit characters */ static crange digitRangeTable[] = { {0x0030, 0x0039}, {0x0660, 0x0669}, {0x06f0, 0x06f9}, {0x0966, 0x096f}, {0x09e6, 0x09ef}, {0x0a66, 0x0a6f}, {0x0ae6, 0x0aef}, {0x0b66, 0x0b6f}, {0x0be7, 0x0bef}, {0x0c66, 0x0c6f}, {0x0ce6, 0x0cef}, {0x0d66, 0x0d6f}, - {0x0e50, 0x0e59}, {0x0ed0, 0x0ed9}, {0x0f20, 0x0f29}, {0xff10, 0xff19} + {0x0e50, 0x0e59}, {0x0ed0, 0x0ed9}, {0x0f20, 0x0f29}, {0x1040, 0x1049}, + {0x1369, 0x1371}, {0x17e0, 0x17e9}, {0x1810, 0x1819}, {0xff10, 0xff19} }; #define NUM_DIGIT_RANGE (sizeof(digitRangeTable)/sizeof(crange)) -/* Unicode: (Punctuation) */ +/* no singletons of digit characters */ + +/* Unicode: punctuation characters */ static crange punctRangeTable[] = { {0x0021, 0x0023}, {0x0025, 0x002a}, {0x002c, 0x002f}, {0x005b, 0x005d}, - {0x055a, 0x055f}, {0x066a, 0x066d}, {0x0f04, 0x0f12}, {0x0f3a, 0x0f3d}, - {0x2010, 0x2027}, {0x2030, 0x2043}, {0x3001, 0x3003}, {0x3008, 0x3011}, - {0x3014, 0x301f}, {0xfe30, 0xfe44}, {0xfe49, 0xfe52}, {0xfe54, 0xfe61}, - {0xff01, 0xff03}, {0xff05, 0xff0a}, {0xff0c, 0xff0f}, {0xff3b, 0xff3d}, - {0xff61, 0xff65} + {0x055a, 0x055f}, {0x066a, 0x066d}, {0x0700, 0x070d}, {0x0f04, 0x0f12}, + {0x0f3a, 0x0f3d}, {0x104a, 0x104f}, {0x1361, 0x1368}, {0x16eb, 0x16ed}, + {0x17d4, 0x17da}, {0x1800, 0x180a}, {0x2010, 0x2027}, {0x2030, 0x2043}, + {0x2048, 0x204d}, {0x3001, 0x3003}, {0x3008, 0x3011}, {0x3014, 0x301f}, + {0xfe30, 0xfe44}, {0xfe49, 0xfe52}, {0xfe54, 0xfe61}, {0xff01, 0xff03}, + {0xff05, 0xff0a}, {0xff0c, 0xff0f}, {0xff3b, 0xff3d}, {0xff61, 0xff65} }; #define NUM_PUNCT_RANGE (sizeof(punctRangeTable)/sizeof(crange)) static chr punctCharTable[] = { 0x003a, 0x003b, 0x003f, 0x0040, 0x005f, 0x007b, 0x007d, 0x00a1, 0x00ab, - 0x00ad, 0x00b7, 0x00bb, 0x00bf, 0x037e, 0x0387, 0x0589, 0x05be, 0x05c0, - 0x05c3, 0x05f3, 0x05f4, 0x060c, 0x061b, 0x061f, 0x06d4, 0x0964, 0x0965, - 0x0970, 0x0e5a, 0x0e5b, 0x0f85, 0x10fb, 0x2045, 0x2046, 0x207d, 0x207e, - 0x208d, 0x208e, 0x2329, 0x232a, 0x3030, 0x30fb, 0xfd3e, 0xfd3f, 0xfe63, - 0xfe68, 0xfe6a, 0xfe6b, 0xff1a, 0xff1b, 0xff1f, 0xff20, 0xff3f, 0xff5b, - 0xff5d + 0x00ad, 0x00b7, 0x00bb, 0x00bf, 0x037e, 0x0387, 0x0589, 0x058a, 0x05be, + 0x05c0, 0x05c3, 0x05f3, 0x05f4, 0x060c, 0x061b, 0x061f, 0x06d4, 0x0964, + 0x0965, 0x0970, 0x0df4, 0x0e4f, 0x0e5a, 0x0e5b, 0x0f85, 0x10fb, 0x166d, + 0x166e, 0x169b, 0x169c, 0x17dc, 0x2045, 0x2046, 0x207d, 0x207e, 0x208d, + 0x208e, 0x2329, 0x232a, 0x3030, 0x30fb, 0xfd3e, 0xfd3f, 0xfe63, 0xfe68, + 0xfe6a, 0xfe6b, 0xff1a, 0xff1b, 0xff1f, 0xff20, 0xff3f, 0xff5b, 0xff5d }; #define NUM_PUNCT_CHAR (sizeof(punctCharTable)/sizeof(chr)) -/* Unicode: (White space) */ +/* Unicode: white space characters */ static crange spaceRangeTable[] = { - {0x0009, 0x000d}, {0x2000, 0x200b}, + {0x0009, 0x000d}, {0x2000, 0x200b} }; #define NUM_SPACE_RANGE (sizeof(spaceRangeTable)/sizeof(crange)) static chr spaceCharTable[] = { - 0x0020, 0x00a0, 0x2028, 0x2029, 0x3000 + 0x0020, 0x00a0, 0x1680, 0x2028, 0x2029, 0x202f, 0x3000 }; #define NUM_SPACE_CHAR (sizeof(spaceCharTable)/sizeof(chr)) @@ -236,8 +255,8 @@ static chr spaceCharTable[] = { static crange lowerRangeTable[] = { {0x0061, 0x007a}, {0x00df, 0x00f6}, {0x00f8, 0x00ff}, {0x017e, 0x0180}, - {0x0199, 0x019b}, {0x0250, 0x02a8}, {0x03ac, 0x03ce}, {0x03ef, 0x03f2}, - {0x0430, 0x044f}, {0x0451, 0x045c}, {0x0561, 0x0587}, {0x10d0, 0x10f6}, + {0x0199, 0x019b}, {0x01bd, 0x01bf}, {0x0250, 0x02ad}, {0x03ac, 0x03ce}, + {0x03d5, 0x03d7}, {0x03ef, 0x03f3}, {0x0430, 0x045f}, {0x0561, 0x0587}, {0x1e95, 0x1e9b}, {0x1f00, 0x1f07}, {0x1f10, 0x1f15}, {0x1f20, 0x1f27}, {0x1f30, 0x1f37}, {0x1f40, 0x1f45}, {0x1f50, 0x1f57}, {0x1f60, 0x1f67}, {0x1f70, 0x1f7d}, {0x1f80, 0x1f87}, {0x1f90, 0x1f97}, {0x1fa0, 0x1fa7}, @@ -256,20 +275,22 @@ static chr lowerCharTable[] = { 0x0153, 0x0155, 0x0157, 0x0159, 0x015b, 0x015d, 0x015f, 0x0161, 0x0163, 0x0165, 0x0167, 0x0169, 0x016b, 0x016d, 0x016f, 0x0171, 0x0173, 0x0175, 0x0177, 0x017a, 0x017c, 0x0183, 0x0185, 0x0188, 0x018c, 0x018d, 0x0192, - 0x0195, 0x019e, 0x01a1, 0x01a3, 0x01a5, 0x01a8, 0x01ab, 0x01ad, 0x01b0, - 0x01b4, 0x01b6, 0x01b9, 0x01ba, 0x01bd, 0x01c6, 0x01c9, 0x01cc, 0x01ce, + 0x0195, 0x019e, 0x01a1, 0x01a3, 0x01a5, 0x01a8, 0x01aa, 0x01ab, 0x01ad, + 0x01b0, 0x01b4, 0x01b6, 0x01b9, 0x01ba, 0x01c6, 0x01c9, 0x01cc, 0x01ce, 0x01d0, 0x01d2, 0x01d4, 0x01d6, 0x01d8, 0x01da, 0x01dc, 0x01dd, 0x01df, 0x01e1, 0x01e3, 0x01e5, 0x01e7, 0x01e9, 0x01eb, 0x01ed, 0x01ef, 0x01f0, - 0x01f3, 0x01f5, 0x01fb, 0x01fd, 0x01ff, 0x0201, 0x0203, 0x0205, 0x0207, - 0x0209, 0x020b, 0x020d, 0x020f, 0x0211, 0x0213, 0x0215, 0x0217, 0x0390, - 0x03d0, 0x03d1, 0x03d5, 0x03d6, 0x03e3, 0x03e5, 0x03e7, 0x03e9, 0x03eb, - 0x03ed, 0x045e, 0x045f, 0x0461, 0x0463, 0x0465, 0x0467, 0x0469, 0x046b, - 0x046d, 0x046f, 0x0471, 0x0473, 0x0475, 0x0477, 0x0479, 0x047b, 0x047d, - 0x047f, 0x0481, 0x0491, 0x0493, 0x0495, 0x0497, 0x0499, 0x049b, 0x049d, - 0x049f, 0x04a1, 0x04a3, 0x04a5, 0x04a7, 0x04a9, 0x04ab, 0x04ad, 0x04af, - 0x04b1, 0x04b3, 0x04b5, 0x04b7, 0x04b9, 0x04bb, 0x04bd, 0x04bf, 0x04c2, - 0x04c4, 0x04c8, 0x04cc, 0x04d1, 0x04d3, 0x04d5, 0x04d7, 0x04d9, 0x04db, - 0x04dd, 0x04df, 0x04e1, 0x04e3, 0x04e5, 0x04e7, 0x04e9, 0x04eb, 0x04ef, + 0x01f3, 0x01f5, 0x01f9, 0x01fb, 0x01fd, 0x01ff, 0x0201, 0x0203, 0x0205, + 0x0207, 0x0209, 0x020b, 0x020d, 0x020f, 0x0211, 0x0213, 0x0215, 0x0217, + 0x0219, 0x021b, 0x021d, 0x021f, 0x0223, 0x0225, 0x0227, 0x0229, 0x022b, + 0x022d, 0x022f, 0x0231, 0x0233, 0x0390, 0x03d0, 0x03d1, 0x03db, 0x03dd, + 0x03df, 0x03e1, 0x03e3, 0x03e5, 0x03e7, 0x03e9, 0x03eb, 0x03ed, 0x03f5, + 0x0461, 0x0463, 0x0465, 0x0467, 0x0469, 0x046b, 0x046d, 0x046f, 0x0471, + 0x0473, 0x0475, 0x0477, 0x0479, 0x047b, 0x047d, 0x047f, 0x0481, 0x048d, + 0x048f, 0x0491, 0x0493, 0x0495, 0x0497, 0x0499, 0x049b, 0x049d, 0x049f, + 0x04a1, 0x04a3, 0x04a5, 0x04a7, 0x04a9, 0x04ab, 0x04ad, 0x04af, 0x04b1, + 0x04b3, 0x04b5, 0x04b7, 0x04b9, 0x04bb, 0x04bd, 0x04bf, 0x04c2, 0x04c4, + 0x04c8, 0x04cc, 0x04d1, 0x04d3, 0x04d5, 0x04d7, 0x04d9, 0x04db, 0x04dd, + 0x04df, 0x04e1, 0x04e3, 0x04e5, 0x04e7, 0x04e9, 0x04eb, 0x04ed, 0x04ef, 0x04f1, 0x04f3, 0x04f5, 0x04f9, 0x1e01, 0x1e03, 0x1e05, 0x1e07, 0x1e09, 0x1e0b, 0x1e0d, 0x1e0f, 0x1e11, 0x1e13, 0x1e15, 0x1e17, 0x1e19, 0x1e1b, 0x1e1d, 0x1e1f, 0x1e21, 0x1e23, 0x1e25, 0x1e27, 0x1e29, 0x1e2b, 0x1e2d, @@ -285,7 +306,7 @@ static chr lowerCharTable[] = { 0x1edd, 0x1edf, 0x1ee1, 0x1ee3, 0x1ee5, 0x1ee7, 0x1ee9, 0x1eeb, 0x1eed, 0x1eef, 0x1ef1, 0x1ef3, 0x1ef5, 0x1ef7, 0x1ef9, 0x1fb6, 0x1fb7, 0x1fbe, 0x1fc6, 0x1fc7, 0x1fd6, 0x1fd7, 0x1ff6, 0x1ff7, 0x207f, 0x210a, 0x210e, - 0x210f, 0x2113, 0x2118, 0x212e, 0x212f, 0x2134 + 0x210f, 0x2113, 0x212f, 0x2134, 0x2139 }; #define NUM_LOWER_CHAR (sizeof(lowerCharTable)/sizeof(chr)) @@ -294,14 +315,13 @@ static chr lowerCharTable[] = { static crange upperRangeTable[] = { {0x0041, 0x005a}, {0x00c0, 0x00d6}, {0x00d8, 0x00de}, {0x0189, 0x018b}, - {0x018e, 0x0191}, {0x0196, 0x0198}, {0x01b1, 0x01b3}, {0x0388, 0x038a}, - {0x0391, 0x03a1}, {0x03a3, 0x03ab}, {0x03d2, 0x03d4}, {0x0401, 0x040c}, - {0x040e, 0x042f}, {0x0531, 0x0556}, {0x10a0, 0x10c5}, {0x1f08, 0x1f0f}, + {0x018e, 0x0191}, {0x0196, 0x0198}, {0x01b1, 0x01b3}, {0x01f6, 0x01f8}, + {0x0388, 0x038a}, {0x0391, 0x03a1}, {0x03a3, 0x03ab}, {0x03d2, 0x03d4}, + {0x0400, 0x042f}, {0x0531, 0x0556}, {0x10a0, 0x10c5}, {0x1f08, 0x1f0f}, {0x1f18, 0x1f1d}, {0x1f28, 0x1f2f}, {0x1f38, 0x1f3f}, {0x1f48, 0x1f4d}, - {0x1f68, 0x1f6f}, {0x1f88, 0x1f8f}, {0x1f98, 0x1f9f}, {0x1fa8, 0x1faf}, - {0x1fb8, 0x1fbc}, {0x1fc8, 0x1fcc}, {0x1fd8, 0x1fdb}, {0x1fe8, 0x1fec}, - {0x1ff8, 0x1ffc}, {0x210b, 0x210d}, {0x2110, 0x2112}, {0x2119, 0x211d}, - {0x212a, 0x212d}, {0xff21, 0xff3a} + {0x1f68, 0x1f6f}, {0x1fb8, 0x1fbb}, {0x1fc8, 0x1fcb}, {0x1fd8, 0x1fdb}, + {0x1fe8, 0x1fec}, {0x1ff8, 0x1ffb}, {0x210b, 0x210d}, {0x2110, 0x2112}, + {0x2119, 0x211d}, {0x212a, 0x212d}, {0xff21, 0xff3a} }; #define NUM_UPPER_RANGE (sizeof(upperRangeTable)/sizeof(crange)) @@ -320,15 +340,17 @@ static chr upperCharTable[] = { 0x01cf, 0x01d1, 0x01d3, 0x01d5, 0x01d7, 0x01d9, 0x01db, 0x01de, 0x01e0, 0x01e2, 0x01e4, 0x01e6, 0x01e8, 0x01ea, 0x01ec, 0x01ee, 0x01f1, 0x01f4, 0x01fa, 0x01fc, 0x01fe, 0x0200, 0x0202, 0x0204, 0x0206, 0x0208, 0x020a, - 0x020c, 0x020e, 0x0210, 0x0212, 0x0214, 0x0216, 0x0386, 0x038c, 0x038e, - 0x038f, 0x03da, 0x03dc, 0x03de, 0x03e0, 0x03e2, 0x03e4, 0x03e6, 0x03e8, - 0x03ea, 0x03ec, 0x03ee, 0x0460, 0x0462, 0x0464, 0x0466, 0x0468, 0x046a, - 0x046c, 0x046e, 0x0470, 0x0472, 0x0474, 0x0476, 0x0478, 0x047a, 0x047c, - 0x047e, 0x0480, 0x0490, 0x0492, 0x0494, 0x0496, 0x0498, 0x049a, 0x049c, - 0x049e, 0x04a0, 0x04a2, 0x04a4, 0x04a6, 0x04a8, 0x04aa, 0x04ac, 0x04ae, - 0x04b0, 0x04b2, 0x04b4, 0x04b6, 0x04b8, 0x04ba, 0x04bc, 0x04be, 0x04c1, - 0x04c3, 0x04c7, 0x04cb, 0x04d0, 0x04d2, 0x04d4, 0x04d6, 0x04d8, 0x04da, - 0x04dc, 0x04de, 0x04e0, 0x04e2, 0x04e4, 0x04e6, 0x04e8, 0x04ea, 0x04ee, + 0x020c, 0x020e, 0x0210, 0x0212, 0x0214, 0x0216, 0x0218, 0x021a, 0x021c, + 0x021e, 0x0222, 0x0224, 0x0226, 0x0228, 0x022a, 0x022c, 0x022e, 0x0230, + 0x0232, 0x0386, 0x038c, 0x038e, 0x038f, 0x03da, 0x03dc, 0x03de, 0x03e0, + 0x03e2, 0x03e4, 0x03e6, 0x03e8, 0x03ea, 0x03ec, 0x03ee, 0x03f4, 0x0460, + 0x0462, 0x0464, 0x0466, 0x0468, 0x046a, 0x046c, 0x046e, 0x0470, 0x0472, + 0x0474, 0x0476, 0x0478, 0x047a, 0x047c, 0x047e, 0x0480, 0x048c, 0x048e, + 0x0490, 0x0492, 0x0494, 0x0496, 0x0498, 0x049a, 0x049c, 0x049e, 0x04a0, + 0x04a2, 0x04a4, 0x04a6, 0x04a8, 0x04aa, 0x04ac, 0x04ae, 0x04b0, 0x04b2, + 0x04b4, 0x04b6, 0x04b8, 0x04ba, 0x04bc, 0x04be, 0x04c0, 0x04c1, 0x04c3, + 0x04c7, 0x04cb, 0x04d0, 0x04d2, 0x04d4, 0x04d6, 0x04d8, 0x04da, 0x04dc, + 0x04de, 0x04e0, 0x04e2, 0x04e4, 0x04e6, 0x04e8, 0x04ea, 0x04ec, 0x04ee, 0x04f0, 0x04f2, 0x04f4, 0x04f8, 0x1e00, 0x1e02, 0x1e04, 0x1e06, 0x1e08, 0x1e0a, 0x1e0c, 0x1e0e, 0x1e10, 0x1e12, 0x1e14, 0x1e16, 0x1e18, 0x1e1a, 0x1e1c, 0x1e1e, 0x1e20, 0x1e22, 0x1e24, 0x1e26, 0x1e28, 0x1e2a, 0x1e2c, @@ -349,66 +371,83 @@ static chr upperCharTable[] = { #define NUM_UPPER_CHAR (sizeof(upperCharTable)/sizeof(chr)) -/* - * The graph table includes the set of characters that are Unicode - * print characters excluding space. - */ +/* Unicode: unicode print characters excluding space */ static crange graphRangeTable[] = { - {0x0021, 0x007e}, {0x00a0, 0x011f}, {0x0121, 0x01f5}, {0x01fa, 0x0217}, - {0x0250, 0x02a8}, {0x02b0, 0x02de}, {0x02e0, 0x02e9}, {0x0300, 0x031f}, - {0x0321, 0x0345}, {0x0384, 0x038a}, {0x038e, 0x03a1}, {0x03a3, 0x03ce}, - {0x03d0, 0x03d6}, {0x03e2, 0x03f3}, {0x0401, 0x040c}, {0x040e, 0x041f}, - {0x0421, 0x044f}, {0x0451, 0x045c}, {0x045e, 0x0486}, {0x0490, 0x04c4}, - {0x04d0, 0x04eb}, {0x04ee, 0x04f5}, {0x0531, 0x0556}, {0x0559, 0x055f}, + {0x0021, 0x007e}, {0x00a0, 0x011f}, {0x0121, 0x021f}, {0x0222, 0x0233}, + {0x0250, 0x02ad}, {0x02b0, 0x02ee}, {0x0300, 0x031f}, {0x0321, 0x034e}, + {0x0360, 0x0362}, {0x0384, 0x038a}, {0x038e, 0x03a1}, {0x03a3, 0x03ce}, + {0x03d0, 0x03d7}, {0x03da, 0x03f5}, {0x0400, 0x041f}, {0x0421, 0x0486}, + {0x048c, 0x04c4}, {0x04d0, 0x04f5}, {0x0531, 0x0556}, {0x0559, 0x055f}, {0x0561, 0x0587}, {0x0591, 0x05a1}, {0x05a3, 0x05b9}, {0x05bb, 0x05c4}, - {0x05d0, 0x05ea}, {0x05f0, 0x05f4}, {0x0621, 0x063a}, {0x0640, 0x0652}, - {0x0660, 0x066d}, {0x0670, 0x06b7}, {0x06ba, 0x06be}, {0x06c0, 0x06ce}, - {0x06d0, 0x06ed}, {0x06f0, 0x06f9}, {0x0901, 0x0903}, {0x0905, 0x091f}, - {0x0921, 0x0939}, {0x093c, 0x094d}, {0x0950, 0x0954}, {0x0958, 0x0970}, - {0x0981, 0x0983}, {0x0985, 0x098c}, {0x0993, 0x09a8}, {0x09aa, 0x09b0}, - {0x09b6, 0x09b9}, {0x09be, 0x09c4}, {0x09cb, 0x09cd}, {0x09df, 0x09e3}, - {0x09e6, 0x09fa}, {0x0a05, 0x0a0a}, {0x0a13, 0x0a1f}, {0x0a21, 0x0a28}, - {0x0a2a, 0x0a30}, {0x0a3e, 0x0a42}, {0x0a4b, 0x0a4d}, {0x0a59, 0x0a5c}, - {0x0a66, 0x0a74}, {0x0a81, 0x0a83}, {0x0a85, 0x0a8b}, {0x0a8f, 0x0a91}, - {0x0a93, 0x0aa8}, {0x0aaa, 0x0ab0}, {0x0ab5, 0x0ab9}, {0x0abc, 0x0ac5}, - {0x0ac7, 0x0ac9}, {0x0acb, 0x0acd}, {0x0ae6, 0x0aef}, {0x0b01, 0x0b03}, - {0x0b05, 0x0b0c}, {0x0b13, 0x0b1f}, {0x0b21, 0x0b28}, {0x0b2a, 0x0b30}, - {0x0b36, 0x0b39}, {0x0b3c, 0x0b43}, {0x0b4b, 0x0b4d}, {0x0b5f, 0x0b61}, - {0x0b66, 0x0b70}, {0x0b85, 0x0b8a}, {0x0b8e, 0x0b90}, {0x0b92, 0x0b95}, - {0x0ba8, 0x0baa}, {0x0bae, 0x0bb5}, {0x0bb7, 0x0bb9}, {0x0bbe, 0x0bc2}, - {0x0bc6, 0x0bc8}, {0x0bca, 0x0bcd}, {0x0be7, 0x0bf2}, {0x0c01, 0x0c03}, - {0x0c05, 0x0c0c}, {0x0c0e, 0x0c10}, {0x0c12, 0x0c1f}, {0x0c21, 0x0c28}, - {0x0c2a, 0x0c33}, {0x0c35, 0x0c39}, {0x0c3e, 0x0c44}, {0x0c46, 0x0c48}, - {0x0c4a, 0x0c4d}, {0x0c66, 0x0c6f}, {0x0c85, 0x0c8c}, {0x0c8e, 0x0c90}, - {0x0c92, 0x0ca8}, {0x0caa, 0x0cb3}, {0x0cb5, 0x0cb9}, {0x0cbe, 0x0cc4}, - {0x0cc6, 0x0cc8}, {0x0cca, 0x0ccd}, {0x0ce6, 0x0cef}, {0x0d05, 0x0d0c}, - {0x0d0e, 0x0d10}, {0x0d12, 0x0d1f}, {0x0d21, 0x0d28}, {0x0d2a, 0x0d39}, - {0x0d3e, 0x0d43}, {0x0d46, 0x0d48}, {0x0d4a, 0x0d4d}, {0x0d66, 0x0d6f}, - {0x0e01, 0x0e1f}, {0x0e21, 0x0e3a}, {0x0e3f, 0x0e5b}, {0x0e94, 0x0e97}, - {0x0e99, 0x0e9f}, {0x0ea1, 0x0ea3}, {0x0ead, 0x0eb9}, {0x0ebb, 0x0ebd}, - {0x0ec0, 0x0ec4}, {0x0ec8, 0x0ecd}, {0x0ed0, 0x0ed9}, {0x0f00, 0x0f1f}, - {0x0f21, 0x0f47}, {0x0f49, 0x0f69}, {0x0f71, 0x0f8b}, {0x0f90, 0x0f95}, - {0x0f99, 0x0fad}, {0x0fb1, 0x0fb7}, {0x10a0, 0x10c5}, {0x10d0, 0x10f6}, - {0x1100, 0x111f}, {0x1121, 0x1159}, {0x115f, 0x11a2}, {0x11a8, 0x11f9}, + {0x05d0, 0x05ea}, {0x05f0, 0x05f4}, {0x0621, 0x063a}, {0x0640, 0x0655}, + {0x0660, 0x066d}, {0x0670, 0x06ed}, {0x06f0, 0x06fe}, {0x0700, 0x070d}, + {0x0710, 0x071f}, {0x0721, 0x072c}, {0x0730, 0x074a}, {0x0780, 0x07b0}, + {0x0901, 0x0903}, {0x0905, 0x091f}, {0x0921, 0x0939}, {0x093c, 0x094d}, + {0x0950, 0x0954}, {0x0958, 0x0970}, {0x0981, 0x0983}, {0x0985, 0x098c}, + {0x0993, 0x09a8}, {0x09aa, 0x09b0}, {0x09b6, 0x09b9}, {0x09be, 0x09c4}, + {0x09cb, 0x09cd}, {0x09df, 0x09e3}, {0x09e6, 0x09fa}, {0x0a05, 0x0a0a}, + {0x0a13, 0x0a1f}, {0x0a21, 0x0a28}, {0x0a2a, 0x0a30}, {0x0a3e, 0x0a42}, + {0x0a4b, 0x0a4d}, {0x0a59, 0x0a5c}, {0x0a66, 0x0a74}, {0x0a81, 0x0a83}, + {0x0a85, 0x0a8b}, {0x0a8f, 0x0a91}, {0x0a93, 0x0aa8}, {0x0aaa, 0x0ab0}, + {0x0ab5, 0x0ab9}, {0x0abc, 0x0ac5}, {0x0ac7, 0x0ac9}, {0x0acb, 0x0acd}, + {0x0ae6, 0x0aef}, {0x0b01, 0x0b03}, {0x0b05, 0x0b0c}, {0x0b13, 0x0b1f}, + {0x0b21, 0x0b28}, {0x0b2a, 0x0b30}, {0x0b36, 0x0b39}, {0x0b3c, 0x0b43}, + {0x0b4b, 0x0b4d}, {0x0b5f, 0x0b61}, {0x0b66, 0x0b70}, {0x0b85, 0x0b8a}, + {0x0b8e, 0x0b90}, {0x0b92, 0x0b95}, {0x0ba8, 0x0baa}, {0x0bae, 0x0bb5}, + {0x0bb7, 0x0bb9}, {0x0bbe, 0x0bc2}, {0x0bc6, 0x0bc8}, {0x0bca, 0x0bcd}, + {0x0be7, 0x0bf2}, {0x0c01, 0x0c03}, {0x0c05, 0x0c0c}, {0x0c0e, 0x0c10}, + {0x0c12, 0x0c1f}, {0x0c21, 0x0c28}, {0x0c2a, 0x0c33}, {0x0c35, 0x0c39}, + {0x0c3e, 0x0c44}, {0x0c46, 0x0c48}, {0x0c4a, 0x0c4d}, {0x0c66, 0x0c6f}, + {0x0c85, 0x0c8c}, {0x0c8e, 0x0c90}, {0x0c92, 0x0ca8}, {0x0caa, 0x0cb3}, + {0x0cb5, 0x0cb9}, {0x0cbe, 0x0cc4}, {0x0cc6, 0x0cc8}, {0x0cca, 0x0ccd}, + {0x0ce6, 0x0cef}, {0x0d05, 0x0d0c}, {0x0d0e, 0x0d10}, {0x0d12, 0x0d1f}, + {0x0d21, 0x0d28}, {0x0d2a, 0x0d39}, {0x0d3e, 0x0d43}, {0x0d46, 0x0d48}, + {0x0d4a, 0x0d4d}, {0x0d66, 0x0d6f}, {0x0d85, 0x0d96}, {0x0d9a, 0x0db1}, + {0x0db3, 0x0dbb}, {0x0dc0, 0x0dc6}, {0x0dcf, 0x0dd4}, {0x0dd8, 0x0ddf}, + {0x0df2, 0x0df4}, {0x0e01, 0x0e1f}, {0x0e21, 0x0e3a}, {0x0e3f, 0x0e5b}, + {0x0e94, 0x0e97}, {0x0e99, 0x0e9f}, {0x0ea1, 0x0ea3}, {0x0ead, 0x0eb9}, + {0x0ebb, 0x0ebd}, {0x0ec0, 0x0ec4}, {0x0ec8, 0x0ecd}, {0x0ed0, 0x0ed9}, + {0x0f00, 0x0f1f}, {0x0f21, 0x0f47}, {0x0f49, 0x0f6a}, {0x0f71, 0x0f8b}, + {0x0f90, 0x0f97}, {0x0f99, 0x0fbc}, {0x0fbe, 0x0fcc}, {0x1000, 0x101f}, + {0x1023, 0x1027}, {0x102c, 0x1032}, {0x1036, 0x1039}, {0x1040, 0x1059}, + {0x10a0, 0x10c5}, {0x10d0, 0x10f6}, {0x1100, 0x111f}, {0x1121, 0x1159}, + {0x115f, 0x11a2}, {0x11a8, 0x11f9}, {0x1200, 0x1206}, {0x1208, 0x121f}, + {0x1221, 0x1246}, {0x124a, 0x124d}, {0x1250, 0x1256}, {0x125a, 0x125d}, + {0x1260, 0x1286}, {0x128a, 0x128d}, {0x1290, 0x12ae}, {0x12b2, 0x12b5}, + {0x12b8, 0x12be}, {0x12c2, 0x12c5}, {0x12c8, 0x12ce}, {0x12d0, 0x12d6}, + {0x12d8, 0x12ee}, {0x12f0, 0x130e}, {0x1312, 0x1315}, {0x1318, 0x131e}, + {0x1321, 0x1346}, {0x1348, 0x135a}, {0x1361, 0x137c}, {0x13a0, 0x13f4}, + {0x1401, 0x141f}, {0x1421, 0x151f}, {0x1521, 0x161f}, {0x1621, 0x1676}, + {0x1680, 0x169c}, {0x16a0, 0x16f0}, {0x1780, 0x17dc}, {0x17e0, 0x17e9}, + {0x1800, 0x180a}, {0x1810, 0x1819}, {0x1821, 0x1877}, {0x1880, 0x18a9}, {0x1e00, 0x1e1f}, {0x1e21, 0x1e9b}, {0x1ea0, 0x1ef9}, {0x1f00, 0x1f15}, {0x1f18, 0x1f1d}, {0x1f21, 0x1f45}, {0x1f48, 0x1f4d}, {0x1f50, 0x1f57}, {0x1f5f, 0x1f7d}, {0x1f80, 0x1fb4}, {0x1fb6, 0x1fc4}, {0x1fc6, 0x1fd3}, {0x1fd6, 0x1fdb}, {0x1fdd, 0x1fef}, {0x1ff2, 0x1ff4}, {0x1ff6, 0x1ffe}, - {0x2000, 0x200b}, {0x2010, 0x201f}, {0x2021, 0x2029}, {0x2030, 0x2046}, - {0x2074, 0x208e}, {0x20a0, 0x20ac}, {0x20d0, 0x20e1}, {0x2100, 0x211f}, - {0x2121, 0x2138}, {0x2153, 0x2182}, {0x2190, 0x21ea}, {0x2200, 0x221f}, - {0x2221, 0x22f1}, {0x2302, 0x231f}, {0x2321, 0x237a}, {0x2400, 0x241f}, - {0x2421, 0x2424}, {0x2440, 0x244a}, {0x2460, 0x24ea}, {0x2500, 0x251f}, - {0x2521, 0x2595}, {0x25a0, 0x25ef}, {0x2600, 0x2613}, {0x261a, 0x261f}, - {0x2621, 0x266f}, {0x2701, 0x2704}, {0x2706, 0x2709}, {0x270c, 0x271f}, - {0x2721, 0x2727}, {0x2729, 0x274b}, {0x274f, 0x2752}, {0x2758, 0x275e}, - {0x2761, 0x2767}, {0x2776, 0x2794}, {0x2798, 0x27af}, {0x27b1, 0x27be}, - {0x3000, 0x301f}, {0x3021, 0x3037}, {0x3041, 0x3094}, {0x3099, 0x309e}, - {0x30a1, 0x30fe}, {0x3105, 0x311f}, {0x3121, 0x312c}, {0x3131, 0x318e}, - {0x3190, 0x319f}, {0x3200, 0x321c}, {0x3221, 0x3243}, {0x3260, 0x327b}, - {0x327f, 0x32b0}, {0x32c0, 0x32cb}, {0x32d0, 0x32fe}, {0x3300, 0x331f}, - {0x3321, 0x3376}, {0x337b, 0x33dd}, {0x33e0, 0x33fe}, {0x4e00, 0x4e1f}, + {0x2000, 0x200b}, {0x2010, 0x201f}, {0x2021, 0x2029}, {0x202f, 0x2046}, + {0x2048, 0x204d}, {0x2074, 0x208e}, {0x20a0, 0x20af}, {0x20d0, 0x20e3}, + {0x2100, 0x211f}, {0x2121, 0x213a}, {0x2153, 0x2183}, {0x2190, 0x21f3}, + {0x2200, 0x221f}, {0x2221, 0x22f1}, {0x2300, 0x231f}, {0x2321, 0x237b}, + {0x237d, 0x239a}, {0x2400, 0x241f}, {0x2421, 0x2426}, {0x2440, 0x244a}, + {0x2460, 0x24ea}, {0x2500, 0x251f}, {0x2521, 0x2595}, {0x25a0, 0x25f7}, + {0x2600, 0x2613}, {0x2619, 0x261f}, {0x2621, 0x2671}, {0x2701, 0x2704}, + {0x2706, 0x2709}, {0x270c, 0x271f}, {0x2721, 0x2727}, {0x2729, 0x274b}, + {0x274f, 0x2752}, {0x2758, 0x275e}, {0x2761, 0x2767}, {0x2776, 0x2794}, + {0x2798, 0x27af}, {0x27b1, 0x27be}, {0x2800, 0x281f}, {0x2821, 0x28ff}, + {0x2e80, 0x2e99}, {0x2e9b, 0x2ef3}, {0x2f00, 0x2f1f}, {0x2f21, 0x2fd5}, + {0x2ff0, 0x2ffb}, {0x3000, 0x301f}, {0x3021, 0x303a}, {0x3041, 0x3094}, + {0x3099, 0x309e}, {0x30a1, 0x30fe}, {0x3105, 0x311f}, {0x3121, 0x312c}, + {0x3131, 0x318e}, {0x3190, 0x31b7}, {0x3200, 0x321c}, {0x3221, 0x3243}, + {0x3260, 0x327b}, {0x327f, 0x32b0}, {0x32c0, 0x32cb}, {0x32d0, 0x32fe}, + {0x3300, 0x331f}, {0x3321, 0x3376}, {0x337b, 0x33dd}, {0x33e0, 0x33fe}, + {0x3400, 0x341f}, {0x3421, 0x351f}, {0x3521, 0x361f}, {0x3621, 0x371f}, + {0x3721, 0x381f}, {0x3821, 0x391f}, {0x3921, 0x3a1f}, {0x3a21, 0x3b1f}, + {0x3b21, 0x3c1f}, {0x3c21, 0x3d1f}, {0x3d21, 0x3e1f}, {0x3e21, 0x3f1f}, + {0x3f21, 0x401f}, {0x4021, 0x411f}, {0x4121, 0x421f}, {0x4221, 0x431f}, + {0x4321, 0x441f}, {0x4421, 0x451f}, {0x4521, 0x461f}, {0x4621, 0x471f}, + {0x4721, 0x481f}, {0x4821, 0x491f}, {0x4921, 0x4a1f}, {0x4a21, 0x4b1f}, + {0x4b21, 0x4c1f}, {0x4c21, 0x4d1f}, {0x4d21, 0x4db5}, {0x4e00, 0x4e1f}, {0x4e21, 0x4f1f}, {0x4f21, 0x501f}, {0x5021, 0x511f}, {0x5121, 0x521f}, {0x5221, 0x531f}, {0x5321, 0x541f}, {0x5421, 0x551f}, {0x5521, 0x561f}, {0x5621, 0x571f}, {0x5721, 0x581f}, {0x5821, 0x591f}, {0x5921, 0x5a1f}, @@ -429,49 +468,55 @@ static crange graphRangeTable[] = { {0x9221, 0x931f}, {0x9321, 0x941f}, {0x9421, 0x951f}, {0x9521, 0x961f}, {0x9621, 0x971f}, {0x9721, 0x981f}, {0x9821, 0x991f}, {0x9921, 0x9a1f}, {0x9a21, 0x9b1f}, {0x9b21, 0x9c1f}, {0x9c21, 0x9d1f}, {0x9d21, 0x9e1f}, - {0x9e21, 0x9f1f}, {0x9f21, 0x9fa5}, {0xac00, 0xac1f}, {0xac21, 0xad1f}, - {0xad21, 0xae1f}, {0xae21, 0xaf1f}, {0xaf21, 0xb01f}, {0xb021, 0xb11f}, - {0xb121, 0xb21f}, {0xb221, 0xb31f}, {0xb321, 0xb41f}, {0xb421, 0xb51f}, - {0xb521, 0xb61f}, {0xb621, 0xb71f}, {0xb721, 0xb81f}, {0xb821, 0xb91f}, - {0xb921, 0xba1f}, {0xba21, 0xbb1f}, {0xbb21, 0xbc1f}, {0xbc21, 0xbd1f}, - {0xbd21, 0xbe1f}, {0xbe21, 0xbf1f}, {0xbf21, 0xc01f}, {0xc021, 0xc11f}, - {0xc121, 0xc21f}, {0xc221, 0xc31f}, {0xc321, 0xc41f}, {0xc421, 0xc51f}, - {0xc521, 0xc61f}, {0xc621, 0xc71f}, {0xc721, 0xc81f}, {0xc821, 0xc91f}, - {0xc921, 0xca1f}, {0xca21, 0xcb1f}, {0xcb21, 0xcc1f}, {0xcc21, 0xcd1f}, - {0xcd21, 0xce1f}, {0xce21, 0xcf1f}, {0xcf21, 0xd01f}, {0xd021, 0xd11f}, - {0xd121, 0xd21f}, {0xd221, 0xd31f}, {0xd321, 0xd41f}, {0xd421, 0xd51f}, - {0xd521, 0xd61f}, {0xd621, 0xd71f}, {0xd721, 0xd7a3}, {0xf900, 0xf91f}, - {0xf921, 0xfa1f}, {0xfa21, 0xfa2d}, {0xfb00, 0xfb06}, {0xfb13, 0xfb17}, - {0xfb21, 0xfb36}, {0xfb38, 0xfb3c}, {0xfb46, 0xfbb1}, {0xfbd3, 0xfc1f}, - {0xfc21, 0xfd1f}, {0xfd21, 0xfd3f}, {0xfd50, 0xfd8f}, {0xfd92, 0xfdc7}, - {0xfdf0, 0xfdfb}, {0xfe21, 0xfe23}, {0xfe30, 0xfe44}, {0xfe49, 0xfe52}, - {0xfe54, 0xfe66}, {0xfe68, 0xfe6b}, {0xfe70, 0xfe72}, {0xfe76, 0xfefc}, - {0xff01, 0xff1f}, {0xff21, 0xff5e}, {0xff61, 0xffbe}, {0xffc2, 0xffc7}, - {0xffca, 0xffcf}, {0xffd2, 0xffd7}, {0xffda, 0xffdc}, {0xffe0, 0xffe6}, - {0xffe8, 0xffee} + {0x9e21, 0x9f1f}, {0x9f21, 0x9fa5}, {0xa000, 0xa01f}, {0xa021, 0xa11f}, + {0xa121, 0xa21f}, {0xa221, 0xa31f}, {0xa321, 0xa41f}, {0xa421, 0xa48c}, + {0xa490, 0xa4a1}, {0xa4a4, 0xa4b3}, {0xa4b5, 0xa4c0}, {0xa4c2, 0xa4c4}, + {0xac00, 0xac1f}, {0xac21, 0xad1f}, {0xad21, 0xae1f}, {0xae21, 0xaf1f}, + {0xaf21, 0xb01f}, {0xb021, 0xb11f}, {0xb121, 0xb21f}, {0xb221, 0xb31f}, + {0xb321, 0xb41f}, {0xb421, 0xb51f}, {0xb521, 0xb61f}, {0xb621, 0xb71f}, + {0xb721, 0xb81f}, {0xb821, 0xb91f}, {0xb921, 0xba1f}, {0xba21, 0xbb1f}, + {0xbb21, 0xbc1f}, {0xbc21, 0xbd1f}, {0xbd21, 0xbe1f}, {0xbe21, 0xbf1f}, + {0xbf21, 0xc01f}, {0xc021, 0xc11f}, {0xc121, 0xc21f}, {0xc221, 0xc31f}, + {0xc321, 0xc41f}, {0xc421, 0xc51f}, {0xc521, 0xc61f}, {0xc621, 0xc71f}, + {0xc721, 0xc81f}, {0xc821, 0xc91f}, {0xc921, 0xca1f}, {0xca21, 0xcb1f}, + {0xcb21, 0xcc1f}, {0xcc21, 0xcd1f}, {0xcd21, 0xce1f}, {0xce21, 0xcf1f}, + {0xcf21, 0xd01f}, {0xd021, 0xd11f}, {0xd121, 0xd21f}, {0xd221, 0xd31f}, + {0xd321, 0xd41f}, {0xd421, 0xd51f}, {0xd521, 0xd61f}, {0xd621, 0xd71f}, + {0xd721, 0xd7a3}, {0xf900, 0xf91f}, {0xf921, 0xfa1f}, {0xfa21, 0xfa2d}, + {0xfb00, 0xfb06}, {0xfb13, 0xfb17}, {0xfb1d, 0xfb1f}, {0xfb21, 0xfb36}, + {0xfb38, 0xfb3c}, {0xfb46, 0xfbb1}, {0xfbd3, 0xfc1f}, {0xfc21, 0xfd1f}, + {0xfd21, 0xfd3f}, {0xfd50, 0xfd8f}, {0xfd92, 0xfdc7}, {0xfdf0, 0xfdfb}, + {0xfe21, 0xfe23}, {0xfe30, 0xfe44}, {0xfe49, 0xfe52}, {0xfe54, 0xfe66}, + {0xfe68, 0xfe6b}, {0xfe70, 0xfe72}, {0xfe76, 0xfefc}, {0xff01, 0xff1f}, + {0xff21, 0xff5e}, {0xff61, 0xffbe}, {0xffc2, 0xffc7}, {0xffca, 0xffcf}, + {0xffd2, 0xffd7}, {0xffda, 0xffdc}, {0xffe0, 0xffe6}, {0xffe8, 0xffee}, + {0xfffc, 0xffff} }; #define NUM_GRAPH_RANGE (sizeof(graphRangeTable)/sizeof(crange)) static chr graphCharTable[] = { - 0x0360, 0x0361, 0x0374, 0x0375, 0x037a, 0x037e, 0x038c, 0x03da, 0x03dc, - 0x03de, 0x03e0, 0x04c7, 0x04c8, 0x04cb, 0x04cc, 0x04f8, 0x04f9, 0x0589, - 0x060c, 0x061b, 0x061f, 0x098f, 0x0990, 0x09b2, 0x09bc, 0x09c7, 0x09c8, - 0x09d7, 0x09dc, 0x09dd, 0x0a02, 0x0a0f, 0x0a10, 0x0a32, 0x0a33, 0x0a35, - 0x0a36, 0x0a38, 0x0a39, 0x0a3c, 0x0a47, 0x0a48, 0x0a5e, 0x0a8d, 0x0ab2, - 0x0ab3, 0x0ad0, 0x0ae0, 0x0b0f, 0x0b10, 0x0b32, 0x0b33, 0x0b47, 0x0b48, - 0x0b56, 0x0b57, 0x0b5c, 0x0b5d, 0x0b82, 0x0b83, 0x0b99, 0x0b9a, 0x0b9c, - 0x0b9e, 0x0b9f, 0x0ba3, 0x0ba4, 0x0bd7, 0x0c55, 0x0c56, 0x0c60, 0x0c61, - 0x0c82, 0x0c83, 0x0cd5, 0x0cd6, 0x0cde, 0x0ce0, 0x0ce1, 0x0d02, 0x0d03, - 0x0d57, 0x0d60, 0x0d61, 0x0e81, 0x0e82, 0x0e84, 0x0e87, 0x0e88, 0x0e8a, - 0x0e8d, 0x0ea5, 0x0ea7, 0x0eaa, 0x0eab, 0x0ec6, 0x0edc, 0x0edd, 0x0f97, - 0x0fb9, 0x10fb, 0x1f59, 0x1f5b, 0x1f5d, 0x2070, 0x2300, 0x274d, 0x2756, - 0x303f, 0xfb1e, 0xfb1f, 0xfb3e, 0xfb40, 0xfb41, 0xfb43, 0xfb44, 0xfe74, - 0xfffc, 0xfffd + 0x0374, 0x0375, 0x037a, 0x037e, 0x038c, 0x0488, 0x0489, 0x04c7, 0x04c8, + 0x04cb, 0x04cc, 0x04f8, 0x04f9, 0x0589, 0x058a, 0x060c, 0x061b, 0x061f, + 0x098f, 0x0990, 0x09b2, 0x09bc, 0x09c7, 0x09c8, 0x09d7, 0x09dc, 0x09dd, + 0x0a02, 0x0a0f, 0x0a10, 0x0a32, 0x0a33, 0x0a35, 0x0a36, 0x0a38, 0x0a39, + 0x0a3c, 0x0a47, 0x0a48, 0x0a5e, 0x0a8d, 0x0ab2, 0x0ab3, 0x0ad0, 0x0ae0, + 0x0b0f, 0x0b10, 0x0b32, 0x0b33, 0x0b47, 0x0b48, 0x0b56, 0x0b57, 0x0b5c, + 0x0b5d, 0x0b82, 0x0b83, 0x0b99, 0x0b9a, 0x0b9c, 0x0b9e, 0x0b9f, 0x0ba3, + 0x0ba4, 0x0bd7, 0x0c55, 0x0c56, 0x0c60, 0x0c61, 0x0c82, 0x0c83, 0x0cd5, + 0x0cd6, 0x0cde, 0x0ce0, 0x0ce1, 0x0d02, 0x0d03, 0x0d57, 0x0d60, 0x0d61, + 0x0d82, 0x0d83, 0x0dbd, 0x0dca, 0x0dd6, 0x0e81, 0x0e82, 0x0e84, 0x0e87, + 0x0e88, 0x0e8a, 0x0e8d, 0x0ea5, 0x0ea7, 0x0eaa, 0x0eab, 0x0ec6, 0x0edc, + 0x0edd, 0x0fcf, 0x1021, 0x1029, 0x102a, 0x10fb, 0x1248, 0x1258, 0x1288, + 0x12b0, 0x12c0, 0x1310, 0x1f59, 0x1f5b, 0x1f5d, 0x2070, 0x274d, 0x2756, + 0x303e, 0x303f, 0xa4c6, 0xfb3e, 0xfb40, 0xfb41, 0xfb43, 0xfb44, 0xfe74 }; #define NUM_GRAPH_CHAR (sizeof(graphCharTable)/sizeof(chr)) +/* + * End of auto-generated Unicode character ranges declarations. + */ #define CH NOCELT @@ -481,9 +526,12 @@ static chr graphCharTable[] = { */ static int nmcces(v) -struct vars *v; + struct vars *v; /* context */ { - return 0; + /* + * No multi-character collating elements defined at the moment. + */ + return 0; } /* @@ -492,9 +540,9 @@ struct vars *v; */ static int nleaders(v) -struct vars *v; + struct vars *v; /* context */ { - return 0; + return 0; } /* @@ -503,10 +551,10 @@ struct vars *v; */ static struct cvec * allmcces(v, cv) -struct vars *v; -struct cvec *cv; /* this is supposed to have enough room */ + struct vars *v; /* context */ + struct cvec *cv; /* this is supposed to have enough room */ { - return clearcvec(cv); + return clearcvec(cv); } /* @@ -515,36 +563,40 @@ struct cvec *cv; /* this is supposed to have enough room */ */ static celt element(v, startp, endp) -struct vars *v; -chr *startp; /* points to start of name */ -chr *endp; /* points just past end of name */ + struct vars *v; /* context */ + chr *startp; /* points to start of name */ + chr *endp; /* points just past end of name */ { - struct cname *cn; - size_t len; - Tcl_DString ds; - char *np; - - /* generic: one-chr names stand for themselves */ - assert(startp < endp); - len = endp - startp; - if (len == 1) - return *startp; - - NOTE(REG_ULOCALE); - - /* search table */ - Tcl_DStringInit(&ds); - np = Tcl_UniCharToUtfDString(startp, (int)len, &ds); - for (cn = cnames; cn->name != NULL; cn++) - if (strlen(cn->name) == len && strncmp(cn->name, np, len) == 0) - break; /* NOTE BREAK OUT */ - Tcl_DStringFree(&ds); - if (cn->name != NULL) - return CHR(cn->code); - - /* couldn't find it */ - ERR(REG_ECOLLATE); - return 0; + struct cname *cn; + size_t len; + Tcl_DString ds; + CONST char *np; + + /* generic: one-chr names stand for themselves */ + assert(startp < endp); + len = endp - startp; + if (len == 1) { + return *startp; + } + + NOTE(REG_ULOCALE); + + /* search table */ + Tcl_DStringInit(&ds); + np = Tcl_UniCharToUtfDString(startp, (int)len, &ds); + for (cn=cnames; cn->name!=NULL; cn++) { + if (strlen(cn->name)==len && strncmp(cn->name, np, len)==0) { + break; /* NOTE BREAK OUT */ + } + } + Tcl_DStringFree(&ds); + if (cn->name != NULL) { + return CHR(cn->code); + } + + /* couldn't find it */ + ERR(REG_ECOLLATE); + return 0; } /* @@ -553,71 +605,71 @@ chr *endp; /* points just past end of name */ */ static struct cvec * range(v, a, b, cases) -struct vars *v; -celt a; -celt b; /* might equal a */ -int cases; /* case-independent? */ + struct vars *v; /* context */ + celt a; /* range start */ + celt b; /* range end, might equal a */ + int cases; /* case-independent? */ { - int nchrs; - struct cvec *cv; - celt c, lc, uc, tc; + int nchrs; + struct cvec *cv; + celt c, lc, uc, tc; - if (a != b && !before(a, b)) { - ERR(REG_ERANGE); - return NULL; - } + if (a != b && !before(a, b)) { + ERR(REG_ERANGE); + return NULL; + } - if (!cases) { /* easy version */ - cv = getcvec(v, 0, 1, 0); - NOERRN(); - addrange(cv, a, b); - return cv; - } + if (!cases) { /* easy version */ + cv = getcvec(v, 0, 1, 0); + NOERRN(); + addrange(cv, a, b); + return cv; + } - /* - * When case-independent, it's hard to decide when cvec ranges are - * usable, so for now at least, we won't try. We allocate enough - * space for two case variants plus a little extra for the two - * title case variants. - */ + /* + * When case-independent, it's hard to decide when cvec ranges are + * usable, so for now at least, we won't try. We allocate enough + * space for two case variants plus a little extra for the two + * title case variants. + */ - nchrs = (b - a + 1)*2 + 4; + nchrs = (b - a + 1)*2 + 4; - cv = getcvec(v, nchrs, 0, 0); - NOERRN(); + cv = getcvec(v, nchrs, 0, 0); + NOERRN(); - for (c = a; c <= b; c++) { - addchr(cv, c); - lc = Tcl_UniCharToLower((chr)c); - uc = Tcl_UniCharToUpper((chr)c); - tc = Tcl_UniCharToTitle((chr)c); - if (c != lc) { - addchr(cv, lc); - } - if (c != uc) { - addchr(cv, uc); - } - if (c != tc && tc != uc) { - addchr(cv, tc); - } + for (c=a; c<=b; c++) { + addchr(cv, c); + lc = Tcl_UniCharToLower((chr)c); + uc = Tcl_UniCharToUpper((chr)c); + tc = Tcl_UniCharToTitle((chr)c); + if (c != lc) { + addchr(cv, lc); + } + if (c != uc) { + addchr(cv, uc); + } + if (c != tc && tc != uc) { + addchr(cv, tc); } + } - return cv; + return cv; } /* - before - is celt x before celt y, for purposes of range legality? ^ static int before(celt, celt); */ -static int /* predicate */ +static int /* predicate */ before(x, y) -celt x; -celt y; + celt x, y; /* collating elements */ { - /* trivial because no MCCEs */ - if (x < y) - return 1; - return 0; + /* trivial because no MCCEs */ + if (x < y) { + return 1; + } + return 0; } /* @@ -627,31 +679,33 @@ celt y; */ static struct cvec * eclass(v, c, cases) -struct vars *v; -celt c; -int cases; /* all cases? */ + struct vars *v; /* context */ + celt c; /* Collating element representing + * the equivalence class. */ + int cases; /* all cases? */ { - struct cvec *cv; - - /* crude fake equivalence class for testing */ - if ((v->cflags®_FAKE) && c == 'x') { - cv = getcvec(v, 4, 0, 0); - addchr(cv, (chr)'x'); - addchr(cv, (chr)'y'); - if (cases) { - addchr(cv, (chr)'X'); - addchr(cv, (chr)'Y'); - } - return cv; + struct cvec *cv; + + /* crude fake equivalence class for testing */ + if ((v->cflags®_FAKE) && c == 'x') { + cv = getcvec(v, 4, 0, 0); + addchr(cv, (chr)'x'); + addchr(cv, (chr)'y'); + if (cases) { + addchr(cv, (chr)'X'); + addchr(cv, (chr)'Y'); } - - /* otherwise, none */ - if (cases) - return allcases(v, c); - cv = getcvec(v, 1, 0, 0); - assert(cv != NULL); - addchr(cv, (chr)c); return cv; + } + + /* otherwise, none */ + if (cases) { + return allcases(v, c); + } + cv = getcvec(v, 1, 0, 0); + assert(cv != NULL); + addchr(cv, (chr)c); + return cv; } /* @@ -661,15 +715,16 @@ int cases; /* all cases? */ */ static struct cvec * cclass(v, startp, endp, cases) -struct vars *v; -chr *startp; /* where the name starts */ -chr *endp; /* just past the end of the name */ -int cases; /* case-independent? */ + struct vars *v; /* context */ + chr *startp; /* where the name starts */ + chr *endp; /* just past the end of the name */ + int cases; /* case-independent? */ { size_t len; struct cvec *cv = NULL; Tcl_DString ds; - char *np, **namePtr; + CONST char *np; + char **namePtr; int i, index; /* @@ -709,7 +764,7 @@ int cases; /* case-independent? */ */ index = -1; - for (namePtr = classNames, i = 0; *namePtr != NULL; namePtr++, i++) { + for (namePtr=classNames,i=0 ; *namePtr!=NULL ; namePtr++,i++) { if ((strlen(*namePtr) == len) && (strncmp(*namePtr, np, len) == 0)) { index = i; break; @@ -726,129 +781,137 @@ int cases; /* case-independent? */ */ switch((enum classes) index) { - case CC_PRINT: - case CC_ALNUM: - cv = getcvec(v, NUM_ALPHA_CHAR, - NUM_DIGIT_RANGE + NUM_ALPHA_RANGE, 0); - if (cv) { - for (i = 0; i < NUM_ALPHA_CHAR; i++) { - addchr(cv, alphaCharTable[i]); - } - for (i = 0; i < NUM_ALPHA_RANGE; i++) { - addrange(cv, alphaRangeTable[i].start, - alphaRangeTable[i].end); - } - for (i = 0; i < NUM_DIGIT_RANGE; i++) { - addrange(cv, digitRangeTable[i].start, - digitRangeTable[i].end); - } + case CC_PRINT: + case CC_ALNUM: + cv = getcvec(v, NUM_ALPHA_CHAR, NUM_DIGIT_RANGE + NUM_ALPHA_RANGE, 0); + if (cv) { + for (i=0 ; i<NUM_ALPHA_CHAR ; i++) { + addchr(cv, alphaCharTable[i]); } - break; - case CC_ALPHA: - cv = getcvec(v, NUM_ALPHA_CHAR, NUM_ALPHA_RANGE, 0); - if (cv) { - for (i = 0; i < NUM_ALPHA_RANGE; i++) { - addrange(cv, alphaRangeTable[i].start, - alphaRangeTable[i].end); - } - for (i = 0; i < NUM_ALPHA_CHAR; i++) { - addchr(cv, alphaCharTable[i]); - } + for (i=0 ; i<NUM_ALPHA_RANGE ; i++) { + addrange(cv, alphaRangeTable[i].start, + alphaRangeTable[i].end); } - break; - case CC_ASCII: - cv = getcvec(v, 0, 1, 0); - if (cv) { - addrange(cv, 0, 0x7f); + for (i=0 ; i<NUM_DIGIT_RANGE ; i++) { + addrange(cv, digitRangeTable[i].start, + digitRangeTable[i].end); } - break; - case CC_BLANK: - cv = getcvec(v, 2, 0, 0); - addchr(cv, '\t'); - addchr(cv, ' '); - break; - case CC_CNTRL: - cv = getcvec(v, 0, 2, 0); - addrange(cv, 0x0, 0x1f); - addrange(cv, 0x7f, 0x9f); - break; - case CC_DIGIT: - cv = getcvec(v, 0, NUM_DIGIT_RANGE, 0); - if (cv) { - for (i = 0; i < NUM_DIGIT_RANGE; i++) { - addrange(cv, digitRangeTable[i].start, - digitRangeTable[i].end); - } + } + break; + case CC_ALPHA: + cv = getcvec(v, NUM_ALPHA_CHAR, NUM_ALPHA_RANGE, 0); + if (cv) { + for (i=0 ; i<NUM_ALPHA_RANGE ; i++) { + addrange(cv, alphaRangeTable[i].start, + alphaRangeTable[i].end); } - break; - case CC_PUNCT: - cv = getcvec(v, NUM_PUNCT_CHAR, NUM_PUNCT_RANGE, 0); - if (cv) { - for (i = 0; i < NUM_PUNCT_RANGE; i++) { - addrange(cv, punctRangeTable[i].start, - punctRangeTable[i].end); - } - for (i = 0; i < NUM_PUNCT_CHAR; i++) { - addchr(cv, punctCharTable[i]); - } + for (i=0 ; i<NUM_ALPHA_CHAR ; i++) { + addchr(cv, alphaCharTable[i]); } - break; - case CC_XDIGIT: - cv = getcvec(v, 0, NUM_DIGIT_RANGE+2, 0); - if (cv) { - addrange(cv, '0', '9'); - addrange(cv, 'a', 'f'); - addrange(cv, 'A', 'F'); + } + break; + case CC_ASCII: + cv = getcvec(v, 0, 1, 0); + if (cv) { + addrange(cv, 0, 0x7f); + } + break; + case CC_BLANK: + cv = getcvec(v, 2, 0, 0); + addchr(cv, '\t'); + addchr(cv, ' '); + break; + case CC_CNTRL: + cv = getcvec(v, 0, 2, 0); + addrange(cv, 0x0, 0x1f); + addrange(cv, 0x7f, 0x9f); + break; + case CC_DIGIT: + cv = getcvec(v, 0, NUM_DIGIT_RANGE, 0); + if (cv) { + for (i=0 ; i<NUM_DIGIT_RANGE ; i++) { + addrange(cv, digitRangeTable[i].start, + digitRangeTable[i].end); } - break; - case CC_SPACE: - cv = getcvec(v, NUM_SPACE_CHAR, NUM_SPACE_RANGE, 0); - if (cv) { - for (i = 0; i < NUM_SPACE_RANGE; i++) { - addrange(cv, spaceRangeTable[i].start, - spaceRangeTable[i].end); - } - for (i = 0; i < NUM_SPACE_CHAR; i++) { - addchr(cv, spaceCharTable[i]); - } + } + break; + case CC_PUNCT: + cv = getcvec(v, NUM_PUNCT_CHAR, NUM_PUNCT_RANGE, 0); + if (cv) { + for (i=0 ; i<NUM_PUNCT_RANGE ; i++) { + addrange(cv, punctRangeTable[i].start, + punctRangeTable[i].end); } - break; - case CC_LOWER: - cv = getcvec(v, NUM_LOWER_CHAR, NUM_LOWER_RANGE, 0); - if (cv) { - for (i = 0; i < NUM_LOWER_RANGE; i++) { - addrange(cv, lowerRangeTable[i].start, - lowerRangeTable[i].end); - } - for (i = 0; i < NUM_LOWER_CHAR; i++) { - addchr(cv, lowerCharTable[i]); - } + for (i=0 ; i<NUM_PUNCT_CHAR ; i++) { + addchr(cv, punctCharTable[i]); } - break; - case CC_UPPER: - cv = getcvec(v, NUM_UPPER_CHAR, NUM_UPPER_RANGE, 0); - if (cv) { - for (i = 0; i < NUM_UPPER_RANGE; i++) { - addrange(cv, upperRangeTable[i].start, - upperRangeTable[i].end); - } - for (i = 0; i < NUM_UPPER_CHAR; i++) { - addchr(cv, upperCharTable[i]); - } + } + break; + case CC_XDIGIT: + /* + * This is a 3 instead of (NUM_DIGIT_RANGE+2) because I've no + * idea how to define the digits 'a' through 'f' in + * non-western locales. The concept is quite possibly non + * portable, or only used in contextx where the characters + * used would be the western ones anyway! Whatever is + * actually the case, the number of ranges is fixed (until + * someone comes up with a better arrangement!) + */ + cv = getcvec(v, 0, 3, 0); + if (cv) { + addrange(cv, '0', '9'); + addrange(cv, 'a', 'f'); + addrange(cv, 'A', 'F'); + } + break; + case CC_SPACE: + cv = getcvec(v, NUM_SPACE_CHAR, NUM_SPACE_RANGE, 0); + if (cv) { + for (i=0 ; i<NUM_SPACE_RANGE ; i++) { + addrange(cv, spaceRangeTable[i].start, + spaceRangeTable[i].end); } - break; - case CC_GRAPH: - cv = getcvec(v, NUM_GRAPH_CHAR, NUM_GRAPH_RANGE, 0); - if (cv) { - for (i = 0; i < NUM_GRAPH_RANGE; i++) { - addrange(cv, graphRangeTable[i].start, - graphRangeTable[i].end); - } - for (i = 0; i < NUM_GRAPH_CHAR; i++) { - addchr(cv, graphCharTable[i]); - } + for (i=0 ; i<NUM_SPACE_CHAR ; i++) { + addchr(cv, spaceCharTable[i]); } - break; + } + break; + case CC_LOWER: + cv = getcvec(v, NUM_LOWER_CHAR, NUM_LOWER_RANGE, 0); + if (cv) { + for (i=0 ; i<NUM_LOWER_RANGE ; i++) { + addrange(cv, lowerRangeTable[i].start, + lowerRangeTable[i].end); + } + for (i=0 ; i<NUM_LOWER_CHAR ; i++) { + addchr(cv, lowerCharTable[i]); + } + } + break; + case CC_UPPER: + cv = getcvec(v, NUM_UPPER_CHAR, NUM_UPPER_RANGE, 0); + if (cv) { + for (i=0 ; i<NUM_UPPER_RANGE ; i++) { + addrange(cv, upperRangeTable[i].start, + upperRangeTable[i].end); + } + for (i=0 ; i<NUM_UPPER_CHAR ; i++) { + addchr(cv, upperCharTable[i]); + } + } + break; + case CC_GRAPH: + cv = getcvec(v, NUM_GRAPH_CHAR, NUM_GRAPH_RANGE, 0); + if (cv) { + for (i=0 ; i<NUM_GRAPH_RANGE ; i++) { + addrange(cv, graphRangeTable[i].start, + graphRangeTable[i].end); + } + for (i=0 ; i<NUM_GRAPH_CHAR ; i++) { + addchr(cv, graphCharTable[i]); + } + } + break; } if (cv == NULL) { ERR(REG_ESPACE); @@ -864,28 +927,28 @@ int cases; /* case-independent? */ */ static struct cvec * allcases(v, pc) -struct vars *v; -pchr pc; + struct vars *v; /* context */ + pchr pc; /* character to get case equivs of */ { - struct cvec *cv; - chr c = (chr)pc; - chr lc, uc, tc; - - lc = Tcl_UniCharToLower((chr)c); - uc = Tcl_UniCharToUpper((chr)c); - tc = Tcl_UniCharToTitle((chr)c); - - if (tc != uc) { - cv = getcvec(v, 3, 0, 0); - addchr(cv, tc); - } else { - cv = getcvec(v, 2, 0, 0); - } - addchr(cv, lc); - if (lc != uc) { - addchr(cv, uc); - } - return cv; + struct cvec *cv; + chr c = (chr)pc; + chr lc, uc, tc; + + lc = Tcl_UniCharToLower((chr)c); + uc = Tcl_UniCharToUpper((chr)c); + tc = Tcl_UniCharToTitle((chr)c); + + if (tc != uc) { + cv = getcvec(v, 3, 0, 0); + addchr(cv, tc); + } else { + cv = getcvec(v, 2, 0, 0); + } + addchr(cv, lc); + if (lc != uc) { + addchr(cv, uc); + } + return cv; } /* @@ -896,13 +959,12 @@ pchr pc; * stop at embedded NULs! ^ static int cmp(CONST chr *, CONST chr *, size_t); */ -static int /* 0 for equal, nonzero for unequal */ +static int /* 0 for equal, nonzero for unequal */ cmp(x, y, len) -CONST chr *x; -CONST chr *y; -size_t len; /* exact length of comparison */ + CONST chr *x, *y; /* strings to compare */ + size_t len; /* exact length of comparison */ { - return memcmp(VS(x), VS(y), len*sizeof(chr)); + return memcmp(VS(x), VS(y), len*sizeof(chr)); } /* @@ -913,18 +975,15 @@ size_t len; /* exact length of comparison */ * stop at embedded NULs! ^ static int casecmp(CONST chr *, CONST chr *, size_t); */ -static int /* 0 for equal, nonzero for unequal */ +static int /* 0 for equal, nonzero for unequal */ casecmp(x, y, len) -CONST chr *x; -CONST chr *y; -size_t len; /* exact length of comparison */ + CONST chr *x, *y; /* strings to compare */ + size_t len; /* exact length of comparison */ { - size_t i; - CONST chr *xp; - CONST chr *yp; - - for (xp = x, yp = y, i = len; i > 0; i--) - if (Tcl_UniCharToLower(*xp++) != Tcl_UniCharToLower(*yp++)) - return 1; - return 0; + for (; len > 0; len--, x++, y++) { + if ((*x!=*y) && (Tcl_UniCharToLower(*x) != Tcl_UniCharToLower(*y))) { + return 1; + } + } + return 0; } diff --git a/tcl/generic/tcl.decls b/tcl/generic/tcl.decls index 7b9a74bdf9b..676b2b58da3 100644 --- a/tcl/generic/tcl.decls +++ b/tcl/generic/tcl.decls @@ -7,6 +7,7 @@ # # # Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # @@ -27,15 +28,15 @@ hooks {tclPlat tclInt tclIntPlat} # to preserve backwards compatibility. declare 0 generic { - int Tcl_PkgProvideEx(Tcl_Interp *interp, char *name, char *version, \ - ClientData clientData) + int Tcl_PkgProvideEx(Tcl_Interp* interp, CONST char* name, + CONST char* version, ClientData clientData) } declare 1 generic { - char * Tcl_PkgRequireEx(Tcl_Interp *interp, char *name, char *version, \ - int exact, ClientData *clientDataPtr) + CONST84_RETURN char * Tcl_PkgRequireEx(Tcl_Interp *interp, CONST char *name, + CONST char *version, int exact, ClientData *clientDataPtr) } declare 2 generic { - void Tcl_Panic(char *format, ...) + void Tcl_Panic(CONST char *format, ...) } declare 3 generic { char * Tcl_Alloc(unsigned int size) @@ -47,13 +48,14 @@ declare 5 generic { char * Tcl_Realloc(char *ptr, unsigned int size) } declare 6 generic { - char * Tcl_DbCkalloc(unsigned int size, char *file, int line) + char * Tcl_DbCkalloc(unsigned int size, CONST char *file, int line) } declare 7 generic { - int Tcl_DbCkfree(char *ptr, char *file, int line) + int Tcl_DbCkfree(char *ptr, CONST char *file, int line) } declare 8 generic { - char * Tcl_DbCkrealloc(char *ptr, unsigned int size, char *file, int line) + char * Tcl_DbCkrealloc(char *ptr, unsigned int size, + CONST char *file, int line) } # Tcl_CreateFileHandler and Tcl_DeleteFileHandler are only available on unix, @@ -61,7 +63,7 @@ declare 8 generic { # compatibility reasons. declare 9 unix { - void Tcl_CreateFileHandler(int fd, int mask, Tcl_FileProc *proc, \ + void Tcl_CreateFileHandler(int fd, int mask, Tcl_FileProc *proc, ClientData clientData) } declare 10 unix { @@ -84,47 +86,48 @@ declare 15 generic { void Tcl_AppendStringsToObj(Tcl_Obj *objPtr, ...) } declare 16 generic { - void Tcl_AppendToObj(Tcl_Obj *objPtr, char *bytes, int length) + void Tcl_AppendToObj(Tcl_Obj* objPtr, CONST char* bytes, int length) } declare 17 generic { Tcl_Obj * Tcl_ConcatObj(int objc, Tcl_Obj *CONST objv[]) } declare 18 generic { - int Tcl_ConvertToType(Tcl_Interp *interp, Tcl_Obj *objPtr, \ + int Tcl_ConvertToType(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_ObjType *typePtr) } declare 19 generic { - void Tcl_DbDecrRefCount(Tcl_Obj *objPtr, char *file, int line) + void Tcl_DbDecrRefCount(Tcl_Obj *objPtr, CONST char *file, int line) } declare 20 generic { - void Tcl_DbIncrRefCount(Tcl_Obj *objPtr, char *file, int line) + void Tcl_DbIncrRefCount(Tcl_Obj *objPtr, CONST char *file, int line) } declare 21 generic { - int Tcl_DbIsShared(Tcl_Obj *objPtr, char *file, int line) + int Tcl_DbIsShared(Tcl_Obj *objPtr, CONST char *file, int line) } declare 22 generic { - Tcl_Obj * Tcl_DbNewBooleanObj(int boolValue, char *file, int line) + Tcl_Obj * Tcl_DbNewBooleanObj(int boolValue, CONST char *file, int line) } declare 23 generic { - Tcl_Obj * Tcl_DbNewByteArrayObj(unsigned char *bytes, int length, \ - char *file, int line) + Tcl_Obj * Tcl_DbNewByteArrayObj(CONST unsigned char *bytes, int length, + CONST char *file, int line) } declare 24 generic { - Tcl_Obj * Tcl_DbNewDoubleObj(double doubleValue, char *file, int line) + Tcl_Obj * Tcl_DbNewDoubleObj(double doubleValue, + CONST char *file, int line) } declare 25 generic { - Tcl_Obj * Tcl_DbNewListObj(int objc, Tcl_Obj *CONST objv[], char *file, \ - int line) + Tcl_Obj * Tcl_DbNewListObj(int objc, Tcl_Obj *CONST *objv, + CONST char *file, int line) } declare 26 generic { - Tcl_Obj * Tcl_DbNewLongObj(long longValue, char *file, int line) + Tcl_Obj * Tcl_DbNewLongObj(long longValue, CONST char *file, int line) } declare 27 generic { - Tcl_Obj * Tcl_DbNewObj(char *file, int line) + Tcl_Obj * Tcl_DbNewObj(CONST char *file, int line) } declare 28 generic { - Tcl_Obj * Tcl_DbNewStringObj(CONST char *bytes, int length, \ - char *file, int line) + Tcl_Obj * Tcl_DbNewStringObj(CONST char *bytes, int length, + CONST char *file, int line) } declare 29 generic { Tcl_Obj * Tcl_DuplicateObj(Tcl_Obj *objPtr) @@ -133,28 +136,28 @@ declare 30 generic { void TclFreeObj(Tcl_Obj *objPtr) } declare 31 generic { - int Tcl_GetBoolean(Tcl_Interp *interp, char *str, int *boolPtr) + int Tcl_GetBoolean(Tcl_Interp *interp, CONST char *str, int *boolPtr) } declare 32 generic { - int Tcl_GetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, \ + int Tcl_GetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *boolPtr) } declare 33 generic { unsigned char * Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, int *lengthPtr) } declare 34 generic { - int Tcl_GetDouble(Tcl_Interp *interp, char *str, double *doublePtr) + int Tcl_GetDouble(Tcl_Interp *interp, CONST char *str, double *doublePtr) } declare 35 generic { - int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, \ + int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr) } declare 36 generic { - int Tcl_GetIndexFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, \ - char **tablePtr, char *msg, int flags, int *indexPtr) + int Tcl_GetIndexFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, + CONST84 char **tablePtr, CONST char *msg, int flags, int *indexPtr) } declare 37 generic { - int Tcl_GetInt(Tcl_Interp *interp, char *str, int *intPtr) + int Tcl_GetInt(Tcl_Interp *interp, CONST char *str, int *intPtr) } declare 38 generic { int Tcl_GetIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr) @@ -163,7 +166,7 @@ declare 39 generic { int Tcl_GetLongFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr) } declare 40 generic { - Tcl_ObjType * Tcl_GetObjType(char *typeName) + Tcl_ObjType * Tcl_GetObjType(CONST char *typeName) } declare 41 generic { char * Tcl_GetStringFromObj(Tcl_Obj *objPtr, int *lengthPtr) @@ -172,33 +175,34 @@ declare 42 generic { void Tcl_InvalidateStringRep(Tcl_Obj *objPtr) } declare 43 generic { - int Tcl_ListObjAppendList(Tcl_Interp *interp, Tcl_Obj *listPtr, \ + int Tcl_ListObjAppendList(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *elemListPtr) } declare 44 generic { - int Tcl_ListObjAppendElement(Tcl_Interp *interp, Tcl_Obj *listPtr, \ + int Tcl_ListObjAppendElement(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *objPtr) } declare 45 generic { - int Tcl_ListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr, \ + int Tcl_ListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr, int *objcPtr, Tcl_Obj ***objvPtr) } declare 46 generic { - int Tcl_ListObjIndex(Tcl_Interp *interp, Tcl_Obj *listPtr, int index, \ + int Tcl_ListObjIndex(Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj **objPtrPtr) } declare 47 generic { - int Tcl_ListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr, int *intPtr) + int Tcl_ListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr, + int *lengthPtr) } declare 48 generic { - int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, int first, \ + int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *CONST objv[]) } declare 49 generic { - Tcl_Obj * Tcl_NewBooleanObj(int boolValue) + Tcl_Obj *Tcl_NewBooleanObj(int boolValue) } declare 50 generic { - Tcl_Obj * Tcl_NewByteArrayObj(unsigned char *bytes, int length) + Tcl_Obj *Tcl_NewByteArrayObj(CONST unsigned char* bytes, int length) } declare 51 generic { Tcl_Obj * Tcl_NewDoubleObj(double doubleValue) @@ -225,7 +229,8 @@ declare 58 generic { unsigned char * Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int length) } declare 59 generic { - void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, unsigned char *bytes, int length) + void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, CONST unsigned char *bytes, + int length) } declare 60 generic { void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue) @@ -243,13 +248,13 @@ declare 64 generic { void Tcl_SetObjLength(Tcl_Obj *objPtr, int length) } declare 65 generic { - void Tcl_SetStringObj(Tcl_Obj *objPtr, char *bytes, int length) + void Tcl_SetStringObj(Tcl_Obj* objPtr, CONST char* bytes, int length) } declare 66 generic { void Tcl_AddErrorInfo(Tcl_Interp *interp, CONST char *message) } declare 67 generic { - void Tcl_AddObjErrorInfo(Tcl_Interp *interp, CONST char *message, \ + void Tcl_AddObjErrorInfo(Tcl_Interp *interp, CONST char *message, int length) } declare 68 generic { @@ -262,7 +267,7 @@ declare 70 generic { void Tcl_AppendResult(Tcl_Interp *interp, ...) } declare 71 generic { - Tcl_AsyncHandler Tcl_AsyncCreate(Tcl_AsyncProc *proc, \ + Tcl_AsyncHandler Tcl_AsyncCreate(Tcl_AsyncProc *proc, ClientData clientData) } declare 72 generic { @@ -284,11 +289,11 @@ declare 77 generic { char Tcl_Backslash(CONST char *src, int *readPtr) } declare 78 generic { - int Tcl_BadChannelOption(Tcl_Interp *interp, char *optionName, \ - char *optionList) + int Tcl_BadChannelOption(Tcl_Interp *interp, CONST char *optionName, + CONST char *optionList) } declare 79 generic { - void Tcl_CallWhenDeleted(Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, \ + void Tcl_CallWhenDeleted(Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, ClientData clientData) } declare 80 generic { @@ -298,46 +303,47 @@ declare 81 generic { int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan) } declare 82 generic { - int Tcl_CommandComplete(char *cmd) + int Tcl_CommandComplete(CONST char *cmd) } declare 83 generic { - char * Tcl_Concat(int argc, char **argv) + char * Tcl_Concat(int argc, CONST84 char * CONST *argv) } declare 84 generic { int Tcl_ConvertElement(CONST char *src, char *dst, int flags) } declare 85 generic { - int Tcl_ConvertCountedElement(CONST char *src, int length, char *dst, \ + int Tcl_ConvertCountedElement(CONST char *src, int length, char *dst, int flags) } declare 86 generic { - int Tcl_CreateAlias(Tcl_Interp *slave, char *slaveCmd, \ - Tcl_Interp *target, char *targetCmd, int argc, char **argv) + int Tcl_CreateAlias(Tcl_Interp *slave, CONST char *slaveCmd, + Tcl_Interp *target, CONST char *targetCmd, int argc, + CONST84 char * CONST *argv) } declare 87 generic { - int Tcl_CreateAliasObj(Tcl_Interp *slave, char *slaveCmd, \ - Tcl_Interp *target, char *targetCmd, int objc, \ + int Tcl_CreateAliasObj(Tcl_Interp *slave, CONST char *slaveCmd, + Tcl_Interp *target, CONST char *targetCmd, int objc, Tcl_Obj *CONST objv[]) } declare 88 generic { - Tcl_Channel Tcl_CreateChannel(Tcl_ChannelType *typePtr, char *chanName, \ - ClientData instanceData, int mask) + Tcl_Channel Tcl_CreateChannel(Tcl_ChannelType *typePtr, + CONST char *chanName, ClientData instanceData, int mask) } declare 89 generic { - void Tcl_CreateChannelHandler(Tcl_Channel chan, int mask, \ + void Tcl_CreateChannelHandler(Tcl_Channel chan, int mask, Tcl_ChannelProc *proc, ClientData clientData) } declare 90 generic { - void Tcl_CreateCloseHandler(Tcl_Channel chan, Tcl_CloseProc *proc, \ + void Tcl_CreateCloseHandler(Tcl_Channel chan, Tcl_CloseProc *proc, ClientData clientData) } declare 91 generic { - Tcl_Command Tcl_CreateCommand(Tcl_Interp *interp, char *cmdName, \ - Tcl_CmdProc *proc, ClientData clientData, \ + Tcl_Command Tcl_CreateCommand(Tcl_Interp *interp, CONST char *cmdName, + Tcl_CmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc) } declare 92 generic { - void Tcl_CreateEventSource(Tcl_EventSetupProc *setupProc, \ + void Tcl_CreateEventSource(Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, ClientData clientData) } declare 93 generic { @@ -347,39 +353,41 @@ declare 94 generic { Tcl_Interp * Tcl_CreateInterp(void) } declare 95 generic { - void Tcl_CreateMathFunc(Tcl_Interp *interp, char *name, int numArgs, \ - Tcl_ValueType *argTypes, Tcl_MathProc *proc, ClientData clientData) + void Tcl_CreateMathFunc(Tcl_Interp *interp, CONST char *name, + int numArgs, Tcl_ValueType *argTypes, + Tcl_MathProc *proc, ClientData clientData) } declare 96 generic { - Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp, char *cmdName, \ - Tcl_ObjCmdProc *proc, ClientData clientData, \ + Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp, + CONST char *cmdName, + Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc) } declare 97 generic { - Tcl_Interp * Tcl_CreateSlave(Tcl_Interp *interp, char *slaveName, \ + Tcl_Interp * Tcl_CreateSlave(Tcl_Interp *interp, CONST char *slaveName, int isSafe) } declare 98 generic { - Tcl_TimerToken Tcl_CreateTimerHandler(int milliseconds, \ + Tcl_TimerToken Tcl_CreateTimerHandler(int milliseconds, Tcl_TimerProc *proc, ClientData clientData) } declare 99 generic { - Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, int level, \ + Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, int level, Tcl_CmdTraceProc *proc, ClientData clientData) } declare 100 generic { - void Tcl_DeleteAssocData(Tcl_Interp *interp, char *name) + void Tcl_DeleteAssocData(Tcl_Interp *interp, CONST char *name) } declare 101 generic { - void Tcl_DeleteChannelHandler(Tcl_Channel chan, Tcl_ChannelProc *proc, \ + void Tcl_DeleteChannelHandler(Tcl_Channel chan, Tcl_ChannelProc *proc, ClientData clientData) } declare 102 generic { - void Tcl_DeleteCloseHandler(Tcl_Channel chan, Tcl_CloseProc *proc, \ + void Tcl_DeleteCloseHandler(Tcl_Channel chan, Tcl_CloseProc *proc, ClientData clientData) } declare 103 generic { - int Tcl_DeleteCommand(Tcl_Interp *interp, char *cmdName) + int Tcl_DeleteCommand(Tcl_Interp *interp, CONST char *cmdName) } declare 104 generic { int Tcl_DeleteCommandFromToken(Tcl_Interp *interp, Tcl_Command command) @@ -388,7 +396,7 @@ declare 105 generic { void Tcl_DeleteEvents(Tcl_EventDeleteProc *proc, ClientData clientData) } declare 106 generic { - void Tcl_DeleteEventSource(Tcl_EventSetupProc *setupProc, \ + void Tcl_DeleteEventSource(Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, ClientData clientData) } declare 107 generic { @@ -413,7 +421,7 @@ declare 113 generic { void Tcl_DeleteTrace(Tcl_Interp *interp, Tcl_Trace trace) } declare 114 generic { - void Tcl_DontCallWhenDeleted(Tcl_Interp *interp, \ + void Tcl_DontCallWhenDeleted(Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, ClientData clientData) } declare 115 generic { @@ -453,16 +461,17 @@ declare 126 generic { int Tcl_Eof(Tcl_Channel chan) } declare 127 generic { - char * Tcl_ErrnoId(void) + CONST84_RETURN char * Tcl_ErrnoId(void) } declare 128 generic { - char * Tcl_ErrnoMsg(int err) + CONST84_RETURN char * Tcl_ErrnoMsg(int err) } declare 129 generic { - int Tcl_Eval(Tcl_Interp *interp, char *string) + int Tcl_Eval(Tcl_Interp *interp, CONST char *string) } +# This is obsolete, use Tcl_FSEvalFile declare 130 generic { - int Tcl_EvalFile(Tcl_Interp *interp, char *fileName) + int Tcl_EvalFile(Tcl_Interp *interp, CONST char *fileName) } declare 131 generic { int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) @@ -474,33 +483,33 @@ declare 133 generic { void Tcl_Exit(int status) } declare 134 generic { - int Tcl_ExposeCommand(Tcl_Interp *interp, char *hiddenCmdToken, \ - char *cmdName) + int Tcl_ExposeCommand(Tcl_Interp *interp, CONST char *hiddenCmdToken, + CONST char *cmdName) } declare 135 generic { - int Tcl_ExprBoolean(Tcl_Interp *interp, char *str, int *ptr) + int Tcl_ExprBoolean(Tcl_Interp *interp, CONST char *str, int *ptr) } declare 136 generic { int Tcl_ExprBooleanObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *ptr) } declare 137 generic { - int Tcl_ExprDouble(Tcl_Interp *interp, char *str, double *ptr) + int Tcl_ExprDouble(Tcl_Interp *interp, CONST char *str, double *ptr) } declare 138 generic { int Tcl_ExprDoubleObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *ptr) } declare 139 generic { - int Tcl_ExprLong(Tcl_Interp *interp, char *str, long *ptr) + int Tcl_ExprLong(Tcl_Interp *interp, CONST char *str, long *ptr) } declare 140 generic { int Tcl_ExprLongObj(Tcl_Interp *interp, Tcl_Obj *objPtr, long *ptr) } declare 141 generic { - int Tcl_ExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr, \ + int Tcl_ExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj **resultPtrPtr) } declare 142 generic { - int Tcl_ExprString(Tcl_Interp *interp, char *string) + int Tcl_ExprString(Tcl_Interp *interp, CONST char *string) } declare 143 generic { void Tcl_Finalize(void) @@ -509,7 +518,7 @@ declare 144 generic { void Tcl_FindExecutable(CONST char *argv0) } declare 145 generic { - Tcl_HashEntry * Tcl_FirstHashEntry(Tcl_HashTable *tablePtr, \ + Tcl_HashEntry * Tcl_FirstHashEntry(Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr) } declare 146 generic { @@ -519,28 +528,28 @@ declare 147 generic { void Tcl_FreeResult(Tcl_Interp *interp) } declare 148 generic { - int Tcl_GetAlias(Tcl_Interp *interp, char *slaveCmd, \ - Tcl_Interp **targetInterpPtr, char **targetCmdPtr, int *argcPtr, \ - char ***argvPtr) + int Tcl_GetAlias(Tcl_Interp *interp, CONST char *slaveCmd, + Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, + int *argcPtr, CONST84 char ***argvPtr) } declare 149 generic { - int Tcl_GetAliasObj(Tcl_Interp *interp, char *slaveCmd, \ - Tcl_Interp **targetInterpPtr, char **targetCmdPtr, int *objcPtr, \ - Tcl_Obj ***objv) + int Tcl_GetAliasObj(Tcl_Interp *interp, CONST char *slaveCmd, + Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, + int *objcPtr, Tcl_Obj ***objv) } declare 150 generic { - ClientData Tcl_GetAssocData(Tcl_Interp *interp, char *name, \ + ClientData Tcl_GetAssocData(Tcl_Interp *interp, CONST char *name, Tcl_InterpDeleteProc **procPtr) } declare 151 generic { - Tcl_Channel Tcl_GetChannel(Tcl_Interp *interp, char *chanName, \ + Tcl_Channel Tcl_GetChannel(Tcl_Interp *interp, CONST char *chanName, int *modePtr) } declare 152 generic { int Tcl_GetChannelBufferSize(Tcl_Channel chan) } declare 153 generic { - int Tcl_GetChannelHandle(Tcl_Channel chan, int direction, \ + int Tcl_GetChannelHandle(Tcl_Channel chan, int direction, ClientData *handlePtr) } declare 154 generic { @@ -550,27 +559,28 @@ declare 155 generic { int Tcl_GetChannelMode(Tcl_Channel chan) } declare 156 generic { - char * Tcl_GetChannelName(Tcl_Channel chan) + CONST84_RETURN char * Tcl_GetChannelName(Tcl_Channel chan) } declare 157 generic { - int Tcl_GetChannelOption(Tcl_Interp *interp, Tcl_Channel chan, \ - char *optionName, Tcl_DString *dsPtr) + int Tcl_GetChannelOption(Tcl_Interp *interp, Tcl_Channel chan, + CONST char *optionName, Tcl_DString *dsPtr) } declare 158 generic { Tcl_ChannelType * Tcl_GetChannelType(Tcl_Channel chan) } declare 159 generic { - int Tcl_GetCommandInfo(Tcl_Interp *interp, char *cmdName, \ + int Tcl_GetCommandInfo(Tcl_Interp *interp, CONST char *cmdName, Tcl_CmdInfo *infoPtr) } declare 160 generic { - char * Tcl_GetCommandName(Tcl_Interp *interp, Tcl_Command command) + CONST84_RETURN char * Tcl_GetCommandName(Tcl_Interp *interp, + Tcl_Command command) } declare 161 generic { int Tcl_GetErrno(void) } declare 162 generic { - char * Tcl_GetHostName(void) + CONST84_RETURN char * Tcl_GetHostName(void) } declare 163 generic { int Tcl_GetInterpPath(Tcl_Interp *askInterp, Tcl_Interp *slaveInterp) @@ -589,12 +599,13 @@ declare 166 generic { # generic interface, so we inlcude it here for compatibility reasons. declare 167 unix { - int Tcl_GetOpenFile(Tcl_Interp *interp, char *str, int forWriting, \ + int Tcl_GetOpenFile(Tcl_Interp *interp, CONST char *str, int forWriting, int checkUsage, ClientData *filePtr) } - +# Obsolete. Should now use Tcl_FSGetPathType which is objectified +# and therefore usually faster. declare 168 generic { - Tcl_PathType Tcl_GetPathType(char *path) + Tcl_PathType Tcl_GetPathType(CONST char *path) } declare 169 generic { int Tcl_Gets(Tcl_Channel chan, Tcl_DString *dsPtr) @@ -606,29 +617,31 @@ declare 171 generic { int Tcl_GetServiceMode(void) } declare 172 generic { - Tcl_Interp * Tcl_GetSlave(Tcl_Interp *interp, char *slaveName) + Tcl_Interp * Tcl_GetSlave(Tcl_Interp *interp, CONST char *slaveName) } declare 173 generic { Tcl_Channel Tcl_GetStdChannel(int type) } declare 174 generic { - char * Tcl_GetStringResult(Tcl_Interp *interp) + CONST84_RETURN char * Tcl_GetStringResult(Tcl_Interp *interp) } declare 175 generic { - char * Tcl_GetVar(Tcl_Interp *interp, char *varName, int flags) + CONST84_RETURN char * Tcl_GetVar(Tcl_Interp *interp, CONST char *varName, + int flags) } declare 176 generic { - char * Tcl_GetVar2(Tcl_Interp *interp, char *part1, char *part2, int flags) + CONST84_RETURN char * Tcl_GetVar2(Tcl_Interp *interp, CONST char *part1, + CONST char *part2, int flags) } declare 177 generic { - int Tcl_GlobalEval(Tcl_Interp *interp, char *command) + int Tcl_GlobalEval(Tcl_Interp *interp, CONST char *command) } declare 178 generic { int Tcl_GlobalEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) } declare 179 generic { - int Tcl_HideCommand(Tcl_Interp *interp, char *cmdName, \ - char *hiddenCmdToken) + int Tcl_HideCommand(Tcl_Interp *interp, CONST char *cmdName, + CONST char *hiddenCmdToken) } declare 180 generic { int Tcl_Init(Tcl_Interp *interp) @@ -648,11 +661,14 @@ declare 184 generic { declare 185 generic { int Tcl_IsSafe(Tcl_Interp *interp) } +# Obsolete, use Tcl_FSJoinPath declare 186 generic { - char * Tcl_JoinPath(int argc, char **argv, Tcl_DString *resultPtr) + char * Tcl_JoinPath(int argc, CONST84 char * CONST *argv, + Tcl_DString *resultPtr) } declare 187 generic { - int Tcl_LinkVar(Tcl_Interp *interp, char *varName, char *addr, int type) + int Tcl_LinkVar(Tcl_Interp *interp, CONST char *varName, char *addr, + int type) } # This slot is reserved for use by the plus patch: @@ -670,7 +686,7 @@ declare 191 generic { Tcl_Channel Tcl_MakeTcpClientChannel(ClientData tcpSocket) } declare 192 generic { - char * Tcl_Merge(int argc, char **argv) + char * Tcl_Merge(int argc, CONST84 char * CONST *argv) } declare 193 generic { Tcl_HashEntry * Tcl_NextHashEntry(Tcl_HashSearch *searchPtr) @@ -679,28 +695,30 @@ declare 194 generic { void Tcl_NotifyChannel(Tcl_Channel channel, int mask) } declare 195 generic { - Tcl_Obj * Tcl_ObjGetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, \ + Tcl_Obj * Tcl_ObjGetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags) } declare 196 generic { - Tcl_Obj * Tcl_ObjSetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, \ + Tcl_Obj * Tcl_ObjSetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags) } declare 197 {unix win} { - Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, int argc, \ - char **argv, int flags) + Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, int argc, + CONST84 char **argv, int flags) } +# This is obsolete, use Tcl_FSOpenFileChannel declare 198 generic { - Tcl_Channel Tcl_OpenFileChannel(Tcl_Interp *interp, char *fileName, \ - char *modeString, int permissions) + Tcl_Channel Tcl_OpenFileChannel(Tcl_Interp *interp, CONST char *fileName, + CONST char *modeString, int permissions) } declare 199 generic { - Tcl_Channel Tcl_OpenTcpClient(Tcl_Interp *interp, int port, \ - char *address, char *myaddr, int myport, int async) + Tcl_Channel Tcl_OpenTcpClient(Tcl_Interp *interp, int port, + CONST char *address, CONST char *myaddr, int myport, int async) } declare 200 generic { - Tcl_Channel Tcl_OpenTcpServer(Tcl_Interp *interp, int port, char *host, \ - Tcl_TcpAcceptProc *acceptProc, ClientData callbackData) + Tcl_Channel Tcl_OpenTcpServer(Tcl_Interp *interp, int port, + CONST char *host, Tcl_TcpAcceptProc *acceptProc, + ClientData callbackData) } declare 201 generic { void Tcl_Preserve(ClientData data) @@ -712,7 +730,7 @@ declare 203 generic { int Tcl_PutEnv(CONST char *string) } declare 204 generic { - char * Tcl_PosixError(Tcl_Interp *interp) + CONST84_RETURN char * Tcl_PosixError(Tcl_Interp *interp) } declare 205 generic { void Tcl_QueueEvent(Tcl_Event *evPtr, Tcl_QueuePosition position) @@ -724,7 +742,7 @@ declare 207 {unix win} { void Tcl_ReapDetachedProcs(void) } declare 208 generic { - int Tcl_RecordAndEval(Tcl_Interp *interp, char *cmd, int flags) + int Tcl_RecordAndEval(Tcl_Interp *interp, CONST char *cmd, int flags) } declare 209 generic { int Tcl_RecordAndEvalObj(Tcl_Interp *interp, Tcl_Obj *cmdPtr, int flags) @@ -736,18 +754,19 @@ declare 211 generic { void Tcl_RegisterObjType(Tcl_ObjType *typePtr) } declare 212 generic { - Tcl_RegExp Tcl_RegExpCompile(Tcl_Interp *interp, char *string) + Tcl_RegExp Tcl_RegExpCompile(Tcl_Interp *interp, CONST char *string) } declare 213 generic { - int Tcl_RegExpExec(Tcl_Interp *interp, Tcl_RegExp regexp, \ + int Tcl_RegExpExec(Tcl_Interp *interp, Tcl_RegExp regexp, CONST char *str, CONST char *start) } declare 214 generic { - int Tcl_RegExpMatch(Tcl_Interp *interp, char *str, char *pattern) + int Tcl_RegExpMatch(Tcl_Interp *interp, CONST char *str, + CONST char *pattern) } declare 215 generic { - void Tcl_RegExpRange(Tcl_RegExp regexp, int index, char **startPtr, \ - char **endPtr) + void Tcl_RegExpRange(Tcl_RegExp regexp, int index, + CONST84 char **startPtr, CONST84 char **endPtr) } declare 216 generic { void Tcl_Release(ClientData clientData) @@ -761,8 +780,9 @@ declare 218 generic { declare 219 generic { int Tcl_ScanCountedElement(CONST char *str, int length, int *flagPtr) } +# Obsolete declare 220 generic { - int Tcl_Seek(Tcl_Channel chan, int offset, int mode) + int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode) } declare 221 generic { int Tcl_ServiceAll(void) @@ -771,19 +791,19 @@ declare 222 generic { int Tcl_ServiceEvent(int flags) } declare 223 generic { - void Tcl_SetAssocData(Tcl_Interp *interp, char *name, \ + void Tcl_SetAssocData(Tcl_Interp *interp, CONST char *name, Tcl_InterpDeleteProc *proc, ClientData clientData) } declare 224 generic { void Tcl_SetChannelBufferSize(Tcl_Channel chan, int sz) } declare 225 generic { - int Tcl_SetChannelOption(Tcl_Interp *interp, Tcl_Channel chan, \ - char *optionName, char *newValue) + int Tcl_SetChannelOption(Tcl_Interp *interp, Tcl_Channel chan, + CONST char *optionName, CONST char *newValue) } declare 226 generic { - int Tcl_SetCommandInfo(Tcl_Interp *interp, char *cmdName, \ - Tcl_CmdInfo *infoPtr) + int Tcl_SetCommandInfo(Tcl_Interp *interp, CONST char *cmdName, + CONST Tcl_CmdInfo *infoPtr) } declare 227 generic { void Tcl_SetErrno(int err) @@ -801,7 +821,7 @@ declare 231 generic { int Tcl_SetRecursionLimit(Tcl_Interp *interp, int depth) } declare 232 generic { - void Tcl_SetResult(Tcl_Interp *interp, char *str, \ + void Tcl_SetResult(Tcl_Interp *interp, char *str, Tcl_FreeProc *freeProc) } declare 233 generic { @@ -817,110 +837,115 @@ declare 236 generic { void Tcl_SetStdChannel(Tcl_Channel channel, int type) } declare 237 generic { - char * Tcl_SetVar(Tcl_Interp *interp, char *varName, char *newValue, \ - int flags) + CONST84_RETURN char * Tcl_SetVar(Tcl_Interp *interp, CONST char *varName, + CONST char *newValue, int flags) } declare 238 generic { - char * Tcl_SetVar2(Tcl_Interp *interp, char *part1, char *part2, \ - char *newValue, int flags) + CONST84_RETURN char * Tcl_SetVar2(Tcl_Interp *interp, CONST char *part1, + CONST char *part2, CONST char *newValue, int flags) } declare 239 generic { - char * Tcl_SignalId(int sig) + CONST84_RETURN char * Tcl_SignalId(int sig) } declare 240 generic { - char * Tcl_SignalMsg(int sig) + CONST84_RETURN char * Tcl_SignalMsg(int sig) } declare 241 generic { void Tcl_SourceRCFile(Tcl_Interp *interp) } declare 242 generic { - int Tcl_SplitList(Tcl_Interp *interp, CONST char *listStr, int *argcPtr, \ - char ***argvPtr) + int Tcl_SplitList(Tcl_Interp *interp, CONST char *listStr, int *argcPtr, + CONST84 char ***argvPtr) } +# Obsolete, use Tcl_FSSplitPath declare 243 generic { - void Tcl_SplitPath(CONST char *path, int *argcPtr, char ***argvPtr) + void Tcl_SplitPath(CONST char *path, int *argcPtr, CONST84 char ***argvPtr) } declare 244 generic { - void Tcl_StaticPackage(Tcl_Interp *interp, char *pkgName, \ + void Tcl_StaticPackage(Tcl_Interp *interp, CONST char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) } declare 245 generic { int Tcl_StringMatch(CONST char *str, CONST char *pattern) } +# Obsolete declare 246 generic { - int Tcl_Tell(Tcl_Channel chan) + int Tcl_TellOld(Tcl_Channel chan) } declare 247 generic { - int Tcl_TraceVar(Tcl_Interp *interp, char *varName, int flags, \ + int Tcl_TraceVar(Tcl_Interp *interp, CONST char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData) } declare 248 generic { - int Tcl_TraceVar2(Tcl_Interp *interp, char *part1, char *part2, \ + int Tcl_TraceVar2(Tcl_Interp *interp, CONST char *part1, CONST char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData) } declare 249 generic { - char * Tcl_TranslateFileName(Tcl_Interp *interp, char *name, \ + char * Tcl_TranslateFileName(Tcl_Interp *interp, CONST char *name, Tcl_DString *bufferPtr) } declare 250 generic { - int Tcl_Ungets(Tcl_Channel chan, char *str, int len, int atHead) + int Tcl_Ungets(Tcl_Channel chan, CONST char *str, int len, int atHead) } declare 251 generic { - void Tcl_UnlinkVar(Tcl_Interp *interp, char *varName) + void Tcl_UnlinkVar(Tcl_Interp *interp, CONST char *varName) } declare 252 generic { int Tcl_UnregisterChannel(Tcl_Interp *interp, Tcl_Channel chan) } declare 253 generic { - int Tcl_UnsetVar(Tcl_Interp *interp, char *varName, int flags) + int Tcl_UnsetVar(Tcl_Interp *interp, CONST char *varName, int flags) } declare 254 generic { - int Tcl_UnsetVar2(Tcl_Interp *interp, char *part1, char *part2, int flags) + int Tcl_UnsetVar2(Tcl_Interp *interp, CONST char *part1, CONST char *part2, + int flags) } declare 255 generic { - void Tcl_UntraceVar(Tcl_Interp *interp, char *varName, int flags, \ + void Tcl_UntraceVar(Tcl_Interp *interp, CONST char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData) } declare 256 generic { - void Tcl_UntraceVar2(Tcl_Interp *interp, char *part1, char *part2, \ - int flags, Tcl_VarTraceProc *proc, ClientData clientData) + void Tcl_UntraceVar2(Tcl_Interp *interp, CONST char *part1, + CONST char *part2, int flags, Tcl_VarTraceProc *proc, + ClientData clientData) } declare 257 generic { - void Tcl_UpdateLinkedVar(Tcl_Interp *interp, char *varName) + void Tcl_UpdateLinkedVar(Tcl_Interp *interp, CONST char *varName) } declare 258 generic { - int Tcl_UpVar(Tcl_Interp *interp, char *frameName, char *varName, \ - char *localName, int flags) + int Tcl_UpVar(Tcl_Interp *interp, CONST char *frameName, + CONST char *varName, CONST char *localName, int flags) } declare 259 generic { - int Tcl_UpVar2(Tcl_Interp *interp, char *frameName, char *part1, \ - char *part2, char *localName, int flags) + int Tcl_UpVar2(Tcl_Interp *interp, CONST char *frameName, CONST char *part1, + CONST char *part2, CONST char *localName, int flags) } declare 260 generic { int Tcl_VarEval(Tcl_Interp *interp, ...) } declare 261 generic { - ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, char *varName, \ + ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, CONST char *varName, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData) } declare 262 generic { - ClientData Tcl_VarTraceInfo2(Tcl_Interp *interp, char *part1, \ - char *part2, int flags, Tcl_VarTraceProc *procPtr, \ + ClientData Tcl_VarTraceInfo2(Tcl_Interp *interp, CONST char *part1, + CONST char *part2, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData) } declare 263 generic { - int Tcl_Write(Tcl_Channel chan, char *s, int slen) + int Tcl_Write(Tcl_Channel chan, CONST char *s, int slen) } declare 264 generic { - void Tcl_WrongNumArgs(Tcl_Interp *interp, int objc, \ - Tcl_Obj *CONST objv[], char *message) + void Tcl_WrongNumArgs(Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[], CONST char *message) } declare 265 generic { - int Tcl_DumpActiveMemory(char *fileName) + int Tcl_DumpActiveMemory(CONST char *fileName) } declare 266 generic { - void Tcl_ValidateAllMemory(char *file, int line) + void Tcl_ValidateAllMemory(CONST char *file, int line) } + declare 267 generic { void Tcl_AppendResultVA(Tcl_Interp *interp, va_list argList) } @@ -928,25 +953,27 @@ declare 268 generic { void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, va_list argList) } declare 269 generic { - char * Tcl_HashStats(Tcl_HashTable *tablePtr) + CONST84_RETURN char * Tcl_HashStats(Tcl_HashTable *tablePtr) } declare 270 generic { - char * Tcl_ParseVar(Tcl_Interp *interp, char *str, char **termPtr) + CONST84_RETURN char * Tcl_ParseVar(Tcl_Interp *interp, CONST char *str, + CONST84 char **termPtr) } declare 271 generic { - char * Tcl_PkgPresent(Tcl_Interp *interp, char *name, char *version, \ - int exact) + CONST84_RETURN char * Tcl_PkgPresent(Tcl_Interp *interp, CONST char *name, + CONST char *version, int exact) } declare 272 generic { - char * Tcl_PkgPresentEx(Tcl_Interp *interp, char *name, char *version, \ - int exact, ClientData *clientDataPtr) + CONST84_RETURN char * Tcl_PkgPresentEx(Tcl_Interp *interp, CONST char *name, + CONST char *version, int exact, ClientData *clientDataPtr) } declare 273 generic { - int Tcl_PkgProvide(Tcl_Interp *interp, char *name, char *version) + int Tcl_PkgProvide(Tcl_Interp *interp, CONST char *name, + CONST char *version) } declare 274 generic { - char * Tcl_PkgRequire(Tcl_Interp *interp, char *name, char *version, \ - int exact) + CONST84_RETURN char * Tcl_PkgRequire(Tcl_Interp *interp, CONST char *name, + CONST char *version, int exact) } declare 275 generic { void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList) @@ -957,8 +984,8 @@ declare 276 generic { declare 277 generic { Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options) } -declare 278 {unix win} { - void Tcl_PanicVA(char *format, va_list argList) +declare 278 generic { + void Tcl_PanicVA(CONST char *format, va_list argList) } declare 279 generic { void Tcl_GetVersion(int *major, int *minor, int *patchLevel, int *type) @@ -982,9 +1009,8 @@ declare 280 generic { # version into the new one). declare 281 generic { - Tcl_Channel Tcl_StackChannel(Tcl_Interp *interp, \ - Tcl_ChannelType *typePtr, ClientData instanceData, \ - int mask, Tcl_Channel prevChan) + Tcl_Channel Tcl_StackChannel(Tcl_Interp *interp, Tcl_ChannelType *typePtr, + ClientData instanceData, int mask, Tcl_Channel prevChan) } declare 282 generic { int Tcl_UnstackChannel(Tcl_Interp *interp, Tcl_Channel chan) @@ -992,9 +1018,13 @@ declare 282 generic { declare 283 generic { Tcl_Channel Tcl_GetStackedChannel(Tcl_Channel chan) } + +# 284 was reserved, but added in 8.4a2 +declare 284 generic { + void Tcl_SetMainLoop(Tcl_MainLoopProc *proc) +} + # Reserved for future use (8.0.x vs. 8.1) -# declare 284 generic { -# } # declare 285 generic { # } @@ -1017,10 +1047,11 @@ declare 290 generic { void Tcl_DiscardResult(Tcl_SavedResult *statePtr) } declare 291 generic { - int Tcl_EvalEx(Tcl_Interp *interp, char *script, int numBytes, int flags) + int Tcl_EvalEx(Tcl_Interp *interp, CONST char *script, int numBytes, + int flags) } declare 292 generic { - int Tcl_EvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], \ + int Tcl_EvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], int flags) } declare 293 generic { @@ -1030,14 +1061,14 @@ declare 294 generic { void Tcl_ExitThread(int status) } declare 295 generic { - int Tcl_ExternalToUtf(Tcl_Interp *interp, Tcl_Encoding encoding, \ - CONST char *src, int srcLen, int flags, \ - Tcl_EncodingState *statePtr, char *dst, int dstLen, \ + int Tcl_ExternalToUtf(Tcl_Interp *interp, Tcl_Encoding encoding, + CONST char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr) } declare 296 generic { - char * Tcl_ExternalToUtfDString(Tcl_Encoding encoding, CONST char *src, \ - int srcLen, Tcl_DString *dsPtr) + char * Tcl_ExternalToUtfDString(Tcl_Encoding encoding, + CONST char *src, int srcLen, Tcl_DString *dsPtr) } declare 297 generic { void Tcl_FinalizeThread(void) @@ -1055,21 +1086,22 @@ declare 301 generic { Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, CONST char *name) } declare 302 generic { - char * Tcl_GetEncodingName(Tcl_Encoding encoding) + CONST84_RETURN char * Tcl_GetEncodingName(Tcl_Encoding encoding) } declare 303 generic { void Tcl_GetEncodingNames(Tcl_Interp *interp) } declare 304 generic { - int Tcl_GetIndexFromObjStruct(Tcl_Interp *interp, Tcl_Obj *objPtr, \ - char **tablePtr, int offset, char *msg, int flags, int *indexPtr) + int Tcl_GetIndexFromObjStruct(Tcl_Interp *interp, Tcl_Obj *objPtr, + CONST VOID *tablePtr, int offset, CONST char *msg, int flags, + int *indexPtr) } declare 305 generic { VOID * Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr, int size) } declare 306 generic { - Tcl_Obj * Tcl_GetVar2Ex(Tcl_Interp *interp, char *part1, char *part2, \ - int flags) + Tcl_Obj * Tcl_GetVar2Ex(Tcl_Interp *interp, CONST char *part1, + CONST char *part2, int flags) } declare 307 generic { ClientData Tcl_InitNotifier(void) @@ -1084,14 +1116,14 @@ declare 310 generic { void Tcl_ConditionNotify(Tcl_Condition *condPtr) } declare 311 generic { - void Tcl_ConditionWait(Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, \ + void Tcl_ConditionWait(Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, Tcl_Time *timePtr) } declare 312 generic { int Tcl_NumUtfChars(CONST char *src, int len) } declare 313 generic { - int Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, int charsToRead, \ + int Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, int charsToRead, int appendFlag) } declare 314 generic { @@ -1104,14 +1136,14 @@ declare 316 generic { int Tcl_SetSystemEncoding(Tcl_Interp *interp, CONST char *name) } declare 317 generic { - Tcl_Obj * Tcl_SetVar2Ex(Tcl_Interp *interp, char *part1, char *part2, \ - Tcl_Obj *newValuePtr, int flags) + Tcl_Obj * Tcl_SetVar2Ex(Tcl_Interp *interp, CONST char *part1, + CONST char *part2, Tcl_Obj *newValuePtr, int flags) } declare 318 generic { void Tcl_ThreadAlert(Tcl_ThreadId threadId) } declare 319 generic { - void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, Tcl_Event* evPtr, \ + void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, Tcl_Event* evPtr, Tcl_QueuePosition position) } declare 320 generic { @@ -1130,7 +1162,7 @@ declare 324 generic { int Tcl_UniCharToUtf(int ch, char *buf) } declare 325 generic { - char * Tcl_UtfAtIndex(CONST char *src, int index) + CONST84_RETURN char * Tcl_UtfAtIndex(CONST char *src, int index) } declare 326 generic { int Tcl_UtfCharComplete(CONST char *src, int len) @@ -1139,26 +1171,26 @@ declare 327 generic { int Tcl_UtfBackslash(CONST char *src, int *readPtr, char *dst) } declare 328 generic { - char * Tcl_UtfFindFirst(CONST char *src, int ch) + CONST84_RETURN char * Tcl_UtfFindFirst(CONST char *src, int ch) } declare 329 generic { - char * Tcl_UtfFindLast(CONST char *src, int ch) + CONST84_RETURN char * Tcl_UtfFindLast(CONST char *src, int ch) } declare 330 generic { - char * Tcl_UtfNext(CONST char *src) + CONST84_RETURN char * Tcl_UtfNext(CONST char *src) } declare 331 generic { - char * Tcl_UtfPrev(CONST char *src, CONST char *start) + CONST84_RETURN char * Tcl_UtfPrev(CONST char *src, CONST char *start) } declare 332 generic { - int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding, \ - CONST char *src, int srcLen, int flags, \ - Tcl_EncodingState *statePtr, char *dst, int dstLen, \ + int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding, + CONST char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr) } declare 333 generic { - char * Tcl_UtfToExternalDString(Tcl_Encoding encoding, CONST char *src, \ - int srcLen, Tcl_DString *dsPtr) + char * Tcl_UtfToExternalDString(Tcl_Encoding encoding, + CONST char *src, int srcLen, Tcl_DString *dsPtr) } declare 334 generic { int Tcl_UtfToLower(char *src) @@ -1182,10 +1214,10 @@ declare 340 generic { char * Tcl_GetString(Tcl_Obj *objPtr) } declare 341 generic { - char * Tcl_GetDefaultEncodingDir(void) + CONST84_RETURN char * Tcl_GetDefaultEncodingDir(void) } declare 342 generic { - void Tcl_SetDefaultEncodingDir(char *path) + void Tcl_SetDefaultEncodingDir(CONST char *path) } declare 343 generic { void Tcl_AlertNotifier(ClientData clientData) @@ -1215,55 +1247,59 @@ declare 351 generic { int Tcl_UniCharIsWordChar(int ch) } declare 352 generic { - int Tcl_UniCharLen(Tcl_UniChar *str) + int Tcl_UniCharLen(CONST Tcl_UniChar *str) } declare 353 generic { - int Tcl_UniCharNcmp(CONST Tcl_UniChar *cs, CONST Tcl_UniChar *ct,\ - unsigned long n) + int Tcl_UniCharNcmp(CONST Tcl_UniChar *cs, CONST Tcl_UniChar *ct, + unsigned long n) } declare 354 generic { - char * Tcl_UniCharToUtfDString(CONST Tcl_UniChar *string, int numChars, \ - Tcl_DString *dsPtr) + char * Tcl_UniCharToUtfDString(CONST Tcl_UniChar *string, + int numChars, Tcl_DString *dsPtr) } declare 355 generic { - Tcl_UniChar * Tcl_UtfToUniCharDString(CONST char *string, int length, \ - Tcl_DString *dsPtr) + Tcl_UniChar * Tcl_UtfToUniCharDString(CONST char *string, + int length, Tcl_DString *dsPtr) } declare 356 generic { - Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, int flags) + Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, + int flags) } declare 357 generic { - Tcl_Obj *Tcl_EvalTokens (Tcl_Interp *interp, Tcl_Token *tokenPtr, \ + Tcl_Obj *Tcl_EvalTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count) } declare 358 generic { - void Tcl_FreeParse (Tcl_Parse *parsePtr) + void Tcl_FreeParse(Tcl_Parse *parsePtr) } declare 359 generic { - void Tcl_LogCommandInfo (Tcl_Interp *interp, char *script, \ - char *command, int length) + void Tcl_LogCommandInfo(Tcl_Interp *interp, CONST char *script, + CONST char *command, int length) } declare 360 generic { - int Tcl_ParseBraces (Tcl_Interp *interp, char *string, \ - int numBytes, Tcl_Parse *parsePtr,int append, char **termPtr) + int Tcl_ParseBraces(Tcl_Interp *interp, CONST char *string, int numBytes, + Tcl_Parse *parsePtr, int append, CONST84 char **termPtr) } declare 361 generic { - int Tcl_ParseCommand (Tcl_Interp *interp, char *string, int numBytes, \ + int Tcl_ParseCommand(Tcl_Interp *interp, CONST char *string, int numBytes, int nested, Tcl_Parse *parsePtr) } declare 362 generic { - int Tcl_ParseExpr(Tcl_Interp *interp, char *string, int numBytes, \ + int Tcl_ParseExpr(Tcl_Interp *interp, CONST char *string, int numBytes, Tcl_Parse *parsePtr) } declare 363 generic { - int Tcl_ParseQuotedString(Tcl_Interp *interp, char *string, int numBytes, \ - Tcl_Parse *parsePtr, int append, char **termPtr) + int Tcl_ParseQuotedString(Tcl_Interp *interp, CONST char *string, + int numBytes, Tcl_Parse *parsePtr, int append, + CONST84 char **termPtr) } declare 364 generic { - int Tcl_ParseVarName (Tcl_Interp *interp, char *string, \ - int numBytes, Tcl_Parse *parsePtr, int append) + int Tcl_ParseVarName(Tcl_Interp *interp, CONST char *string, int numBytes, + Tcl_Parse *parsePtr, int append) } +# These 4 functions are obsolete, use Tcl_FSGetCwd, Tcl_FSChdir, +# Tcl_FSAccess and Tcl_FSStat declare 365 generic { char *Tcl_GetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr) } @@ -1298,37 +1334,37 @@ declare 375 generic { int Tcl_UniCharIsPunct(int ch) } declare 376 generic { - int Tcl_RegExpExecObj(Tcl_Interp *interp, Tcl_RegExp regexp, \ + int Tcl_RegExpExecObj(Tcl_Interp *interp, Tcl_RegExp regexp, Tcl_Obj *objPtr, int offset, int nmatches, int flags) } declare 377 generic { void Tcl_RegExpGetInfo(Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr) } declare 378 generic { - Tcl_Obj * Tcl_NewUnicodeObj(Tcl_UniChar *unicode, int numChars) + Tcl_Obj * Tcl_NewUnicodeObj(CONST Tcl_UniChar *unicode, int numChars) } declare 379 generic { - void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, Tcl_UniChar *unicode, \ + void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode, int numChars) } declare 380 generic { - int Tcl_GetCharLength (Tcl_Obj *objPtr) + int Tcl_GetCharLength(Tcl_Obj *objPtr) } declare 381 generic { - Tcl_UniChar Tcl_GetUniChar (Tcl_Obj *objPtr, int index) + Tcl_UniChar Tcl_GetUniChar(Tcl_Obj *objPtr, int index) } declare 382 generic { - Tcl_UniChar * Tcl_GetUnicode (Tcl_Obj *objPtr) + Tcl_UniChar * Tcl_GetUnicode(Tcl_Obj *objPtr) } declare 383 generic { - Tcl_Obj * Tcl_GetRange (Tcl_Obj *objPtr, int first, int last) + Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, int first, int last) } declare 384 generic { - void Tcl_AppendUnicodeToObj (Tcl_Obj *objPtr, \ - Tcl_UniChar *unicode, int length) + void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode, + int length) } declare 385 generic { - int Tcl_RegExpMatchObj(Tcl_Interp *interp, Tcl_Obj *stringObj, \ + int Tcl_RegExpMatchObj(Tcl_Interp *interp, Tcl_Obj *stringObj, Tcl_Obj *patternObj) } declare 386 generic { @@ -1341,43 +1377,44 @@ declare 388 generic { int Tcl_GetChannelNames(Tcl_Interp *interp) } declare 389 generic { - int Tcl_GetChannelNamesEx(Tcl_Interp *interp, char *pattern) + int Tcl_GetChannelNamesEx(Tcl_Interp *interp, CONST char *pattern) } declare 390 generic { - int Tcl_ProcObjCmd(ClientData clientData, Tcl_Interp *interp, \ + int Tcl_ProcObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) } declare 391 generic { - void Tcl_ConditionFinalize (Tcl_Condition *condPtr) + void Tcl_ConditionFinalize(Tcl_Condition *condPtr) } declare 392 generic { - void Tcl_MutexFinalize (Tcl_Mutex *mutex) + void Tcl_MutexFinalize(Tcl_Mutex *mutex) } declare 393 generic { - int Tcl_CreateThread (Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc proc, \ + int Tcl_CreateThread(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc proc, ClientData clientData, int stackSize, int flags) } +# Introduced in 8.3.2 declare 394 generic { - int Tcl_ReadRaw (Tcl_Channel chan, char *dst, int bytesToRead) + int Tcl_ReadRaw(Tcl_Channel chan, char *dst, int bytesToRead) } declare 395 generic { - int Tcl_WriteRaw (Tcl_Channel chan, char *src, int srcLen) + int Tcl_WriteRaw(Tcl_Channel chan, CONST char *src, int srcLen) } declare 396 generic { - Tcl_Channel Tcl_GetTopChannel (Tcl_Channel chan) + Tcl_Channel Tcl_GetTopChannel(Tcl_Channel chan) } declare 397 generic { - int Tcl_ChannelBuffered (Tcl_Channel chan) + int Tcl_ChannelBuffered(Tcl_Channel chan) } declare 398 generic { - char * Tcl_ChannelName(Tcl_ChannelType *chanTypePtr) + CONST84_RETURN char * Tcl_ChannelName(Tcl_ChannelType *chanTypePtr) } declare 399 generic { Tcl_ChannelTypeVersion Tcl_ChannelVersion(Tcl_ChannelType *chanTypePtr) } declare 400 generic { - Tcl_DriverBlockModeProc * Tcl_ChannelBlockModeProc(Tcl_ChannelType \ + Tcl_DriverBlockModeProc * Tcl_ChannelBlockModeProc(Tcl_ChannelType *chanTypePtr) } declare 401 generic { @@ -1396,28 +1433,327 @@ declare 405 generic { Tcl_DriverSeekProc * Tcl_ChannelSeekProc(Tcl_ChannelType *chanTypePtr) } declare 406 generic { - Tcl_DriverSetOptionProc * Tcl_ChannelSetOptionProc(Tcl_ChannelType \ + Tcl_DriverSetOptionProc * Tcl_ChannelSetOptionProc(Tcl_ChannelType *chanTypePtr) } declare 407 generic { - Tcl_DriverGetOptionProc * Tcl_ChannelGetOptionProc(Tcl_ChannelType \ + Tcl_DriverGetOptionProc * Tcl_ChannelGetOptionProc(Tcl_ChannelType *chanTypePtr) } declare 408 generic { Tcl_DriverWatchProc * Tcl_ChannelWatchProc(Tcl_ChannelType *chanTypePtr) } declare 409 generic { - Tcl_DriverGetHandleProc * Tcl_ChannelGetHandleProc(Tcl_ChannelType \ + Tcl_DriverGetHandleProc * Tcl_ChannelGetHandleProc(Tcl_ChannelType *chanTypePtr) } declare 410 generic { Tcl_DriverFlushProc * Tcl_ChannelFlushProc(Tcl_ChannelType *chanTypePtr) } declare 411 generic { - Tcl_DriverHandlerProc * Tcl_ChannelHandlerProc(Tcl_ChannelType \ + Tcl_DriverHandlerProc * Tcl_ChannelHandlerProc(Tcl_ChannelType *chanTypePtr) } +# Introduced in 8.4a2 +declare 412 generic { + int Tcl_JoinThread(Tcl_ThreadId id, int* result) +} +declare 413 generic { + int Tcl_IsChannelShared(Tcl_Channel channel) +} +declare 414 generic { + int Tcl_IsChannelRegistered(Tcl_Interp* interp, Tcl_Channel channel) +} +declare 415 generic { + void Tcl_CutChannel(Tcl_Channel channel) +} +declare 416 generic { + void Tcl_SpliceChannel(Tcl_Channel channel) +} +declare 417 generic { + void Tcl_ClearChannelHandlers(Tcl_Channel channel) +} +declare 418 generic { + int Tcl_IsChannelExisting(CONST char* channelName) +} + +declare 419 generic { + int Tcl_UniCharNcasecmp(CONST Tcl_UniChar *cs, CONST Tcl_UniChar *ct, + unsigned long n) +} +declare 420 generic { + int Tcl_UniCharCaseMatch(CONST Tcl_UniChar *ustr, + CONST Tcl_UniChar *pattern, int nocase) +} + +declare 421 generic { + Tcl_HashEntry *Tcl_FindHashEntry(Tcl_HashTable *tablePtr, CONST char *key) +} + +declare 422 generic { + Tcl_HashEntry *Tcl_CreateHashEntry(Tcl_HashTable *tablePtr, + CONST char *key, int *newPtr) +} + +declare 423 generic { + void Tcl_InitCustomHashTable(Tcl_HashTable *tablePtr, int keyType, + Tcl_HashKeyType *typePtr) +} + +declare 424 generic { + void Tcl_InitObjHashTable(Tcl_HashTable *tablePtr) +} +declare 425 generic { + ClientData Tcl_CommandTraceInfo(Tcl_Interp *interp, CONST char *varName, + int flags, Tcl_CommandTraceProc *procPtr, + ClientData prevClientData) +} +declare 426 generic { + int Tcl_TraceCommand(Tcl_Interp *interp, CONST char *varName, int flags, + Tcl_CommandTraceProc *proc, ClientData clientData) +} +declare 427 generic { + void Tcl_UntraceCommand(Tcl_Interp *interp, CONST char *varName, + int flags, Tcl_CommandTraceProc *proc, ClientData clientData) +} +declare 428 generic { + char * Tcl_AttemptAlloc(unsigned int size) +} +declare 429 generic { + char * Tcl_AttemptDbCkalloc(unsigned int size, CONST char *file, int line) +} +declare 430 generic { + char * Tcl_AttemptRealloc(char *ptr, unsigned int size) +} +declare 431 generic { + char * Tcl_AttemptDbCkrealloc(char *ptr, unsigned int size, + CONST char *file, int line) +} +declare 432 generic { + int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, int length) +} +declare 433 generic { + Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel) +} +# introduced in 8.4a3 +declare 434 generic { + Tcl_UniChar * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr) +} +declare 435 generic { + int Tcl_GetMathFuncInfo(Tcl_Interp *interp, CONST char *name, + int *numArgsPtr, Tcl_ValueType **argTypesPtr, + Tcl_MathProc **procPtr, ClientData *clientDataPtr) +} +declare 436 generic { + Tcl_Obj * Tcl_ListMathFuncs(Tcl_Interp *interp, CONST char *pattern) +} +declare 437 generic { + Tcl_Obj * Tcl_SubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags) +} +declare 438 generic { + int Tcl_DetachChannel(Tcl_Interp* interp, Tcl_Channel channel) +} +declare 439 generic { + int Tcl_IsStandardChannel(Tcl_Channel channel) +} +# New functions due to TIP#17 +declare 440 generic { + int Tcl_FSCopyFile(Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr) +} +declare 441 generic { + int Tcl_FSCopyDirectory(Tcl_Obj *srcPathPtr, + Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr) +} +declare 442 generic { + int Tcl_FSCreateDirectory(Tcl_Obj *pathPtr) +} +declare 443 generic { + int Tcl_FSDeleteFile(Tcl_Obj *pathPtr) +} +declare 444 generic { + int Tcl_FSLoadFile(Tcl_Interp * interp, + Tcl_Obj *pathPtr, CONST char * sym1, CONST char * sym2, + Tcl_PackageInitProc ** proc1Ptr, + Tcl_PackageInitProc ** proc2Ptr, + Tcl_LoadHandle * handlePtr, + Tcl_FSUnloadFileProc **unloadProcPtr) +} +declare 445 generic { + int Tcl_FSMatchInDirectory(Tcl_Interp *interp, Tcl_Obj *result, + Tcl_Obj *pathPtr, CONST char *pattern, Tcl_GlobTypeData *types) +} +declare 446 generic { + Tcl_Obj * Tcl_FSLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr, int linkAction) +} +declare 447 generic { + int Tcl_FSRemoveDirectory(Tcl_Obj *pathPtr, + int recursive, Tcl_Obj **errorPtr) +} +declare 448 generic { + int Tcl_FSRenameFile(Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr) +} +declare 449 generic { + int Tcl_FSLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf) +} +declare 450 generic { + int Tcl_FSUtime(Tcl_Obj *pathPtr, struct utimbuf *tval) +} +declare 451 generic { + int Tcl_FSFileAttrsGet(Tcl_Interp *interp, + int index, Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef) +} +declare 452 generic { + int Tcl_FSFileAttrsSet(Tcl_Interp *interp, + int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr) +} +declare 453 generic { + CONST char ** Tcl_FSFileAttrStrings(Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef) +} +declare 454 generic { + int Tcl_FSStat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf) +} +declare 455 generic { + int Tcl_FSAccess(Tcl_Obj *pathPtr, int mode) +} +declare 456 generic { + Tcl_Channel Tcl_FSOpenFileChannel(Tcl_Interp *interp, Tcl_Obj *pathPtr, + CONST char *modeString, int permissions) +} +declare 457 generic { + Tcl_Obj* Tcl_FSGetCwd(Tcl_Interp *interp) +} +declare 458 generic { + int Tcl_FSChdir(Tcl_Obj *pathPtr) +} +declare 459 generic { + int Tcl_FSConvertToPathType(Tcl_Interp *interp, Tcl_Obj *pathPtr) +} +declare 460 generic { + Tcl_Obj* Tcl_FSJoinPath(Tcl_Obj *listObj, int elements) +} +declare 461 generic { + Tcl_Obj* Tcl_FSSplitPath(Tcl_Obj* pathPtr, int *lenPtr) +} +declare 462 generic { + int Tcl_FSEqualPaths(Tcl_Obj* firstPtr, Tcl_Obj* secondPtr) +} +declare 463 generic { + Tcl_Obj* Tcl_FSGetNormalizedPath(Tcl_Interp *interp, Tcl_Obj* pathObjPtr) +} +declare 464 generic { + Tcl_Obj* Tcl_FSJoinToPath(Tcl_Obj *basePtr, int objc, + Tcl_Obj *CONST objv[]) +} +declare 465 generic { + ClientData Tcl_FSGetInternalRep(Tcl_Obj* pathObjPtr, + Tcl_Filesystem *fsPtr) +} +declare 466 generic { + Tcl_Obj* Tcl_FSGetTranslatedPath(Tcl_Interp *interp, Tcl_Obj* pathPtr) +} +declare 467 generic { + int Tcl_FSEvalFile(Tcl_Interp *interp, Tcl_Obj *fileName) +} +declare 468 generic { + Tcl_Obj* Tcl_FSNewNativePath(Tcl_Filesystem* fromFilesystem, + ClientData clientData) +} +declare 469 generic { + CONST char* Tcl_FSGetNativePath(Tcl_Obj* pathObjPtr) +} +declare 470 generic { + Tcl_Obj* Tcl_FSFileSystemInfo(Tcl_Obj* pathObjPtr) +} +declare 471 generic { + Tcl_Obj* Tcl_FSPathSeparator(Tcl_Obj* pathObjPtr) +} +declare 472 generic { + Tcl_Obj* Tcl_FSListVolumes(void) +} +declare 473 generic { + int Tcl_FSRegister(ClientData clientData, Tcl_Filesystem *fsPtr) +} +declare 474 generic { + int Tcl_FSUnregister(Tcl_Filesystem *fsPtr) +} +declare 475 generic { + ClientData Tcl_FSData(Tcl_Filesystem *fsPtr) +} +declare 476 generic { + CONST char* Tcl_FSGetTranslatedStringPath(Tcl_Interp *interp, + Tcl_Obj* pathPtr) +} +declare 477 generic { + Tcl_Filesystem* Tcl_FSGetFileSystemForPath(Tcl_Obj* pathObjPtr) +} +declare 478 generic { + Tcl_PathType Tcl_FSGetPathType(Tcl_Obj *pathObjPtr) +} +# New function due to TIP#49 +declare 479 generic { + int Tcl_OutputBuffered(Tcl_Channel chan) +} +declare 480 generic { + void Tcl_FSMountsChanged(Tcl_Filesystem *fsPtr) +} +# New function due to TIP#56 +declare 481 generic { + int Tcl_EvalTokensStandard(Tcl_Interp *interp, Tcl_Token *tokenPtr, + int count) +} + +# New export due to TIP#73 +declare 482 generic { + void Tcl_GetTime(Tcl_Time* timeBuf) +} + +# New exports due to TIP#32 + +declare 483 generic { + Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp* interp, int level, int flags, + Tcl_CmdObjTraceProc* objProc, ClientData clientData, + Tcl_CmdObjTraceDeleteProc* delProc) +} +declare 484 generic { + int Tcl_GetCommandInfoFromToken(Tcl_Command token, Tcl_CmdInfo* infoPtr) +} +declare 485 generic { + int Tcl_SetCommandInfoFromToken(Tcl_Command token, + CONST Tcl_CmdInfo* infoPtr) +} + +### New functions on 64-bit dev branch ### +declare 486 generic { + Tcl_Obj * Tcl_DbNewWideIntObj(Tcl_WideInt wideValue, + CONST char *file, int line) +} +declare 487 generic { + int Tcl_GetWideIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, + Tcl_WideInt *widePtr) +} +declare 488 generic { + Tcl_Obj * Tcl_NewWideIntObj(Tcl_WideInt wideValue) +} +declare 489 generic { + void Tcl_SetWideIntObj(Tcl_Obj *objPtr, Tcl_WideInt wideValue) +} +declare 490 generic { + Tcl_StatBuf * Tcl_AllocStatBuf(void) +} +declare 491 generic { + Tcl_WideInt Tcl_Seek(Tcl_Channel chan, Tcl_WideInt offset, int mode) +} +declare 492 generic { + Tcl_WideInt Tcl_Tell(Tcl_Channel chan) +} + +# New export due to TIP#91 +declare 493 generic { + Tcl_DriverWideSeekProc * Tcl_ChannelWideSeekProc( + Tcl_ChannelType *chanTypePtr) +} + ############################################################################## # Define the platform specific public Tcl interface. These functions are @@ -1453,20 +1789,20 @@ declare 1 mac { char * Tcl_MacConvertTextResource(Handle resource) } declare 2 mac { - int Tcl_MacEvalResource(Tcl_Interp *interp, char *resourceName, \ - int resourceNumber, char *fileName) + int Tcl_MacEvalResource(Tcl_Interp *interp, CONST char *resourceName, + int resourceNumber, CONST char *fileName) } declare 3 mac { - Handle Tcl_MacFindResource(Tcl_Interp *interp, long resourceType, \ - char *resourceName, int resourceNumber, char *resFileRef, \ - int * releaseIt) + Handle Tcl_MacFindResource(Tcl_Interp *interp, long resourceType, + CONST char *resourceName, int resourceNumber, + CONST char *resFileRef, int * releaseIt) } # These routines support the new OSType object type (i.e. the packed 4 # character type and creator codes). declare 4 mac { - int Tcl_GetOSTypeFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, \ + int Tcl_GetOSTypeFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, OSType *osTypePtr) } declare 5 mac { @@ -1477,8 +1813,7 @@ declare 6 mac { } # These are not in MSL 2.1.2, so we need to export them from the -# Tcl shared library. They are found in the compat directory -# except the panic routine which is found in tclMacPanic.h. +# Tcl shared library. They are found in the compat directory. declare 7 mac { int strncasecmp(CONST char *s1, CONST char *s2, size_t n) @@ -1487,3 +1822,14 @@ declare 8 mac { int strcasecmp(CONST char *s1, CONST char *s2) } +################## +# Mac OS X declarations +# + +declare 0 macosx { + int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp, + CONST char *bundleName, + int hasResourceFile, + int maxPathLen, + char *libraryPath) +} diff --git a/tcl/generic/tcl.h b/tcl/generic/tcl.h index f4574f30d95..c3e4cd6bf9d 100644 --- a/tcl/generic/tcl.h +++ b/tcl/generic/tcl.h @@ -8,6 +8,7 @@ * Copyright (c) 1993-1996 Lucent Technologies. * Copyright (c) 1994-1998 Sun Microsystems, Inc. * Copyright (c) 1998-2000 by Scriptics Corporation. + * Copyright (c) 2002 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -43,26 +44,23 @@ extern "C" { * win/configure.in (as above) * win/tcl.m4 (not patchlevel) * win/makefile.vc (not patchlevel) 2 LOC - * win/pkgIndex.tcl (not patchlevel, for tclregNN.dll) * README (sections 0 and 2) * mac/README (2 LOC, not patchlevel) * win/README.binary (sections 0-4) * win/README (not patchlevel) (sections 0 and 2) - * unix/README (not patchlevel) (part (h)) * unix/tcl.spec (2 LOC Major/Minor, 1 LOC patch) - * tests/basic.test (not patchlevel) (version checks) + * tests/basic.test (1 LOC M/M, not patchlevel) * tools/tcl.hpj.in (not patchlevel, for windows installer) * tools/tcl.wse.in (for windows installer) * tools/tclSplash.bmp (not patchlevel) */ - #define TCL_MAJOR_VERSION 8 -#define TCL_MINOR_VERSION 3 +#define TCL_MINOR_VERSION 4 #define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE -#define TCL_RELEASE_SERIAL 2 +#define TCL_RELEASE_SERIAL 0 -#define TCL_VERSION "8.3" -#define TCL_PATCH_LEVEL "8.3.2" +#define TCL_VERSION "8.4" +#define TCL_PATCH_LEVEL "8.4.0" /* * The following definitions set up the proper options for Windows @@ -70,34 +68,21 @@ extern "C" { */ #ifndef __WIN32__ -# if defined(_WIN32) || defined(WIN32) || \ - defined(__CYGWIN__) || defined(__MINGW32__) +# if defined(_WIN32) || defined(WIN32) || defined(__CYGWIN__) || defined(__MINGW32__) || defined(__BORLANDC__) # define __WIN32__ +# ifndef WIN32 +# define WIN32 +# endif # endif #endif +/* + * STRICT: See MSDN Article Q83456 + */ #ifdef __WIN32__ # ifndef STRICT # define STRICT # endif -# ifndef USE_PROTOTYPE -# define USE_PROTOTYPE 1 -# endif -# ifndef HAS_STDARG -# define HAS_STDARG 1 -# endif -# ifndef USE_PROTOTYPE -# define USE_PROTOTYPE 1 -# endif - -/* - * Under Windows we need to call Tcl_Alloc in all cases to avoid competing - * C run-time library issues. - */ - -# ifndef USE_TCLALLOC -# define USE_TCLALLOC 1 -# endif #endif /* __WIN32__ */ /* @@ -106,9 +91,7 @@ extern "C" { */ #ifdef MAC_TCL -# ifndef HAS_STDARG -# define HAS_STDARG 1 -# endif +#include <ConditionalMacros.h> # ifndef USE_TCLALLOC # define USE_TCLALLOC 1 # endif @@ -118,34 +101,40 @@ extern "C" { # define INLINE #endif + /* * Utility macros: STRINGIFY takes an argument and wraps it in "" (double * quotation marks), JOIN joins two arguments. */ - -#define VERBATIM(x) x -#ifdef _MSC_VER -# define STRINGIFY(x) STRINGIFY1(x) -# define STRINGIFY1(x) #x -# define JOIN(a,b) JOIN1(a,b) -# define JOIN1(a,b) a##b -#else -# ifdef RESOURCE_INCLUDED +#ifndef STRINGIFY # define STRINGIFY(x) STRINGIFY1(x) # define STRINGIFY1(x) #x +#endif +#ifndef JOIN # define JOIN(a,b) JOIN1(a,b) # define JOIN1(a,b) a##b -# else -# ifdef __STDC__ -# define STRINGIFY(x) #x -# define JOIN(a,b) a##b -# else -# define STRINGIFY(x) "x" -# define JOIN(a,b) VERBATIM(a)VERBATIM(b) -# endif -# endif #endif +/* + * A special definition used to allow this header file to be included + * from windows resource files so that they can obtain version + * information. RC_INVOKED is defined by default by the RC tool. + * Resource compilers don't like all the C stuff, like typedefs and + * procedure declarations, that occur below, so block them out. + */ + +#ifndef RC_INVOKED + +/* + * A special definition for Macintosh used to allow this header file + * to be included in resource files so that they can get obtain + * version information from this file. Resource compilers don't like + * all the C stuff, like typedefs and procedure declarations, that + * occur below. +*/ + +#ifndef RESOURCE_INCLUDED + /* * Special macro to define mutexes, that doesn't do anything * if we are not using threads. @@ -171,19 +160,12 @@ extern "C" { #define Tcl_ConditionFinalize(condPtr) #endif /* TCL_THREADS */ -/* - * A special definition used to allow this header file to be included - * in resource files so that they can get obtain version information from - * this file. Resource compilers don't like all the C stuff, like typedefs - * and procedure declarations, that occur below. - */ - -#ifndef RESOURCE_INCLUDED #ifndef BUFSIZ -#include <stdio.h> +# include <stdio.h> #endif + /* * Definitions that allow Tcl functions with variable numbers of * arguments to be used with either varargs.h or stdarg.h. TCL_VARARGS @@ -193,23 +175,15 @@ extern "C" { * string for use in the function definition. TCL_VARARGS_START * initializes the va_list data structure and returns the first argument. */ - -#if defined(__STDC__) || defined(HAS_STDARG) +#if !defined(NO_STDARG) # include <stdarg.h> - # define TCL_VARARGS(type, name) (type name, ...) # define TCL_VARARGS_DEF(type, name) (type name, ...) # define TCL_VARARGS_START(type, name, list) (va_start(list, name), name) #else # include <varargs.h> - -# ifdef __cplusplus -# define TCL_VARARGS(type, name) (type name, ...) -# define TCL_VARARGS_DEF(type, name) (type va_alist, ...) -# else -# define TCL_VARARGS(type, name) () -# define TCL_VARARGS_DEF(type, name) (va_alist) -# endif +# define TCL_VARARGS(type, name) () +# define TCL_VARARGS_DEF(type, name) (va_alist) # define TCL_VARARGS_START(type, name, list) \ (va_start(list), va_arg(list, type)) #endif @@ -223,16 +197,16 @@ extern "C" { */ #ifdef STATIC_BUILD -# define DLLIMPORT -# define DLLEXPORT +# define DLLIMPORT +# define DLLEXPORT #else -# if defined(__WIN32__) && (defined(_MSC_VER) || (defined(__GNUC__) && defined(__declspec))) -# define DLLIMPORT __declspec(dllimport) -# define DLLEXPORT __declspec(dllexport) -# else -# define DLLIMPORT -# define DLLEXPORT -# endif +# if (defined(__WIN32__) && (defined(_MSC_VER) || (__BORLANDC__ >= 0x0550) || (defined(__GNUC__) && defined(__declspec)))) || (defined(MAC_TCL) && FUNCTION_DECLSPEC) +# define DLLIMPORT __declspec(dllimport) +# define DLLEXPORT __declspec(dllexport) +# else +# define DLLIMPORT +# define DLLEXPORT +# endif #endif /* @@ -248,45 +222,64 @@ extern "C" { * name of a library we are building, is set on the compile line for sources * that are to be placed in the library. When this macro is set, the * storage class will be set to DLLEXPORT. At the end of the header file, the - * storage class will be reset to DLLIMPORt. + * storage class will be reset to DLLIMPORT. */ - #undef TCL_STORAGE_CLASS #ifdef BUILD_tcl -# define TCL_STORAGE_CLASS DLLEXPORT +# define TCL_STORAGE_CLASS DLLEXPORT #else -# ifdef USE_TCL_STUBS -# define TCL_STORAGE_CLASS -# else -# define TCL_STORAGE_CLASS DLLIMPORT -# endif +# ifdef USE_TCL_STUBS +# define TCL_STORAGE_CLASS +# else +# define TCL_STORAGE_CLASS DLLIMPORT +# endif #endif + /* * Definitions that allow this header file to be used either with or * without ANSI C features like function prototypes. */ - #undef _ANSI_ARGS_ #undef CONST #ifndef INLINE # define INLINE #endif -#if ((defined(__STDC__) || defined(SABER)) && !defined(NO_PROTOTYPE)) || defined(__cplusplus) || defined(USE_PROTOTYPE) -# define _USING_PROTOTYPES_ 1 -# define _ANSI_ARGS_(x) x +#ifndef NO_CONST # define CONST const #else -# define _ANSI_ARGS_(x) () # define CONST #endif +#ifndef NO_PROTOTYPES +# define _ANSI_ARGS_(x) x +#else +# define _ANSI_ARGS_(x) () +#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 + + /* * Make sure EXTERN isn't defined elsewhere */ #ifdef EXTERN -#undef EXTERN +# undef EXTERN #endif /* EXTERN */ #ifdef __cplusplus @@ -295,23 +288,13 @@ extern "C" { # define EXTERN extern TCL_STORAGE_CLASS #endif + /* - * Macro to use instead of "void" for arguments that must have - * type "void *" in ANSI C; maps them to type "char *" in - * non-ANSI systems. - */ -#ifndef __WIN32__ -#ifndef VOID -# ifdef __STDC__ -# define VOID void -# else -# define VOID char -# endif -#endif -#else /* __WIN32__ */ -/* - * The following code is copied from winnt.h + * The following code is copied from winnt.h. + * If we don't replicate it here, then <windows.h> can't be included + * after tcl.h, since tcl.h also defines VOID. */ +#ifdef __WIN32__ #ifndef VOID #define VOID void typedef char CHAR; @@ -321,22 +304,130 @@ typedef long LONG; #endif /* __WIN32__ */ /* - * Miscellaneous declarations. + * Macro to use instead of "void" for arguments that must have + * type "void *" in ANSI C; maps them to type "char *" in + * non-ANSI systems. */ +#ifndef NO_VOID +# define VOID void +#else +# define VOID char +#endif + +/* + * Miscellaneous declarations. + */ #ifndef NULL -#define NULL 0 +# define NULL 0 #endif #ifndef _CLIENTDATA -# if defined(__STDC__) || defined(__cplusplus) - typedef void *ClientData; +# ifndef NO_VOID + typedef void *ClientData; # else - typedef int *ClientData; -# endif /* __STDC__ */ -#define _CLIENTDATA + typedef int *ClientData; +# endif +# define _CLIENTDATA +#endif + +/* + * Define Tcl_WideInt to be a type that is (at least) 64-bits wide, + * and define Tcl_WideUInt to be the unsigned variant of that type + * (assuming that where we have one, we can have the other.) + * + * At the moment, this only works on Unix systems anyway... + * + * Also defines the following macros: + * TCL_WIDE_INT_IS_LONG - if wide ints are really longs (i.e. we're on + * a real 64-bit system.) + * Tcl_WideAsLong - forgetful converter from wideInt to long. + * Tcl_LongAsWide - sign-extending converter from long to wideInt. + * Tcl_WideAsDouble - converter from wideInt to double. + * Tcl_DoubleAsWide - converter from double to wideInt. + * + * 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 functions strtoull() + * and, where sprintf(...,"%lld",...) does not work, lltostr(). + * Although strtoull() is fairly straight-forward, lltostr() is a most + * unusual function on Solaris8 (taking its operating buffer + * backwards) so any changes you make will need to be done + * cautiously... + */ + +#if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG) +# ifdef __WIN32__ +# define TCL_WIDE_INT_TYPE __int64 +# ifdef __BORLANDC__ +typedef struct stati64 Tcl_StatBuf; +# define TCL_LL_MODIFIER "L" +# define TCL_LL_MODIFIER_SIZE 1 +# else /* __BORLANDC__ */ +typedef struct _stati64 Tcl_StatBuf; +# define TCL_LL_MODIFIER "I64" +# define TCL_LL_MODIFIER_SIZE 3 +# endif /* __BORLANDC__ */ +# else /* __WIN32__ */ +/* + * Don't know what platform it is and configure hasn't discovered what + * is going on for us. Try to guess... + */ +# ifdef NO_LIMITS_H +# error please define either TCL_WIDE_INT_TYPE or TCL_WIDE_INT_IS_LONG +# else /* !NO_LIMITS_H */ +# 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 /* NO_LIMITS_H */ +# 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 */ + +typedef TCL_WIDE_INT_TYPE Tcl_WideInt; +typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; + +#ifdef TCL_WIDE_INT_IS_LONG +typedef struct stat Tcl_StatBuf; +# 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))) +#else /* TCL_WIDE_INT_IS_LONG */ +# ifndef __WIN32__ +# ifdef HAVE_STRUCT_STAT64 +typedef struct stat64 Tcl_StatBuf; +# else +typedef struct stat Tcl_StatBuf; +# endif /* HAVE_STRUCT_STAT64 */ +# define TCL_LL_MODIFIER "ll" +# define TCL_LL_MODIFIER_SIZE 2 +# endif /* !__WIN32__ */ +# 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 */ + + +/* + * This flag controls whether binary compatability is maintained with + * extensions built against a previous version of Tcl. This is true + * by default. + */ +#ifndef TCL_PRESERVE_BINARY_COMPATABILITY +# define TCL_PRESERVE_BINARY_COMPATABILITY 1 #endif + /* * Data structures defined opaquely in this module. The definitions below * just provide dummy types. A few fields are made visible in Tcl_Interp @@ -388,6 +479,7 @@ typedef struct Tcl_TimerToken_ *Tcl_TimerToken; typedef struct Tcl_Trace_ *Tcl_Trace; typedef struct Tcl_Var_ *Tcl_Var; typedef struct Tcl_ChannelTypeVersion_ *Tcl_ChannelTypeVersion; +typedef struct Tcl_LoadHandle_ *Tcl_LoadHandle; /* * Definition of the interface to procedures implementing threads. @@ -395,7 +487,6 @@ typedef struct Tcl_ChannelTypeVersion_ *Tcl_ChannelTypeVersion; * 'Tcl_CreateThread' and will be called as the main fuction of * the new thread created by that call. */ - #ifdef MAC_TCL typedef pascal void *(Tcl_ThreadCreateProc) _ANSI_ARGS_((ClientData clientData)); #elif defined __WIN32__ @@ -422,12 +513,10 @@ typedef void (Tcl_ThreadCreateProc) _ANSI_ARGS_((ClientData clientData)); #endif - /* * Definition of values for default stacksize and the possible flags to be * given to Tcl_CreateThread. */ - #define TCL_THREAD_STACK_DEFAULT (0) /* Use default size for stack */ #define TCL_THREAD_NOFLAGS (0000) /* Standard flags, default behaviour */ #define TCL_THREAD_JOINABLE (0001) /* Mark the thread as joinable */ @@ -435,7 +524,6 @@ typedef void (Tcl_ThreadCreateProc) _ANSI_ARGS_((ClientData clientData)); /* * Flag values passed to Tcl_GetRegExpFromObj. */ - #define TCL_REG_BASIC 000000 /* BREs (convenience) */ #define TCL_REG_EXTENDED 000001 /* EREs */ #define TCL_REG_ADVF 000002 /* advanced features in EREs */ @@ -455,7 +543,6 @@ typedef void (Tcl_ThreadCreateProc) _ANSI_ARGS_((ClientData clientData)); * The following flag is experimental and only intended for use by Expect. It * will probably go away in a later release. */ - #define TCL_REG_BOSONLY 002000 /* prepend \A to pattern so it only * matches at the beginning of the * string. */ @@ -463,7 +550,6 @@ typedef void (Tcl_ThreadCreateProc) _ANSI_ARGS_((ClientData clientData)); /* * Flags values passed to Tcl_RegExpExecObj. */ - #define TCL_REG_NOTBOL 0001 /* Beginning of string does not match ^. */ #define TCL_REG_NOTEOL 0002 /* End of string does not match $. */ @@ -472,7 +558,6 @@ typedef void (Tcl_ThreadCreateProc) _ANSI_ARGS_((ClientData clientData)); * relative to the start of the match string, not the beginning of the * entire string. */ - typedef struct Tcl_RegExpIndices { long start; /* character offset of first character in match */ long end; /* character offset of first character after the @@ -493,8 +578,8 @@ typedef struct Tcl_RegExpInfo { * Picky compilers complain if this typdef doesn't appear before the * struct's reference in tclDecls.h. */ - -typedef struct stat *Tcl_Stat_; +typedef Tcl_StatBuf *Tcl_Stat_; +typedef struct stat *Tcl_OldStat_; /* * When a TCL command returns, the interpreter contains a result from the @@ -516,7 +601,6 @@ typedef struct stat *Tcl_Stat_; * TCL_CONTINUE Go on to the next iteration of the current loop; * the interpreter's result is meaningless. */ - #define TCL_OK 0 #define TCL_ERROR 1 #define TCL_RETURN 2 @@ -526,15 +610,31 @@ typedef struct stat *Tcl_Stat_; #define TCL_RESULT_SIZE 200 /* - * Argument descriptors for math function callbacks in expressions: + * Flags to control what substitutions are performed by Tcl_SubstObj(): */ +#define TCL_SUBST_COMMANDS 001 +#define TCL_SUBST_VARIABLES 002 +#define TCL_SUBST_BACKSLASHES 004 +#define TCL_SUBST_ALL 007 + -typedef enum {TCL_INT, TCL_DOUBLE, TCL_EITHER} Tcl_ValueType; +/* + * Argument descriptors for math function callbacks in expressions: + */ +typedef enum { + TCL_INT, TCL_DOUBLE, TCL_EITHER, TCL_WIDE_INT +#ifdef TCL_WIDE_INT_IS_LONG + = TCL_INT +#endif +} Tcl_ValueType; typedef struct Tcl_Value { Tcl_ValueType type; /* Indicates intValue or doubleValue is * valid, or both. */ long intValue; /* Integer value. */ double doubleValue; /* Double-precision floating value. */ +#ifndef TCL_WIDE_INT_IS_LONG + Tcl_WideInt wideValue; /* Wide (min. 64-bit) integer value. */ +#endif } Tcl_Value; /* @@ -542,9 +642,9 @@ typedef struct Tcl_Value { * reference to Tcl_Obj is encountered in the procedure types declared * below. */ - struct Tcl_Obj; + /* * Procedure types defined by Tcl: */ @@ -556,10 +656,14 @@ typedef void (Tcl_ChannelProc) _ANSI_ARGS_((ClientData clientData, int mask)); typedef void (Tcl_CloseProc) _ANSI_ARGS_((ClientData data)); typedef void (Tcl_CmdDeleteProc) _ANSI_ARGS_((ClientData clientData)); typedef int (Tcl_CmdProc) _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char *argv[])); + Tcl_Interp *interp, int argc, CONST84 char *argv[])); typedef void (Tcl_CmdTraceProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *proc, - ClientData cmdClientData, int argc, char *argv[])); + ClientData cmdClientData, int argc, CONST84 char *argv[])); +typedef int (Tcl_CmdObjTraceProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int level, CONST char *command, + Tcl_Command commandInfo, int objc, struct Tcl_Obj * CONST * objv)); +typedef void (Tcl_CmdObjTraceDeleteProc) _ANSI_ARGS_((ClientData clientData)); typedef void (Tcl_DupInternalRepProc) _ANSI_ARGS_((struct Tcl_Obj *srcPtr, struct Tcl_Obj *dupPtr)); typedef int (Tcl_EncodingConvertProc)_ANSI_ARGS_((ClientData clientData, @@ -586,9 +690,9 @@ typedef int (Tcl_MathProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr)); typedef void (Tcl_NamespaceDeleteProc) _ANSI_ARGS_((ClientData clientData)); typedef int (Tcl_ObjCmdProc) _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, struct Tcl_Obj *CONST objv[])); + Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST * objv)); typedef int (Tcl_PackageInitProc) _ANSI_ARGS_((Tcl_Interp *interp)); -typedef void (Tcl_PanicProc) _ANSI_ARGS_(TCL_VARARGS(char *, format)); +typedef void (Tcl_PanicProc) _ANSI_ARGS_(TCL_VARARGS(CONST char *, format)); typedef void (Tcl_TcpAcceptProc) _ANSI_ARGS_((ClientData callbackData, Tcl_Channel chan, char *address, int port)); typedef void (Tcl_TimerProc) _ANSI_ARGS_((ClientData clientData)); @@ -596,10 +700,19 @@ typedef int (Tcl_SetFromAnyProc) _ANSI_ARGS_((Tcl_Interp *interp, struct Tcl_Obj *objPtr)); typedef void (Tcl_UpdateStringProc) _ANSI_ARGS_((struct Tcl_Obj *objPtr)); typedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, char *part1, char *part2, int flags)); + Tcl_Interp *interp, CONST84 char *part1, CONST84 char *part2, int flags)); +typedef void (Tcl_CommandTraceProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, CONST char *oldName, CONST char *newName, + int flags)); typedef void (Tcl_CreateFileHandlerProc) _ANSI_ARGS_((int fd, int mask, Tcl_FileProc *proc, ClientData clientData)); typedef void (Tcl_DeleteFileHandlerProc) _ANSI_ARGS_((int fd)); +typedef void (Tcl_AlertNotifierProc) _ANSI_ARGS_((ClientData clientData)); +typedef void (Tcl_ServiceModeHookProc) _ANSI_ARGS_((int mode)); +typedef ClientData (Tcl_InitNotifierProc) _ANSI_ARGS_((VOID)); +typedef void (Tcl_FinalizeNotifierProc) _ANSI_ARGS_((ClientData clientData)); +typedef void (Tcl_MainLoopProc) _ANSI_ARGS_((void)); + /* * The following structure represents a type of object, which is a @@ -626,6 +739,7 @@ typedef struct Tcl_ObjType { * failure. */ } Tcl_ObjType; + /* * One of the following structures exists for each object in the Tcl * system. An object stores a value as either a string, some internal @@ -655,6 +769,7 @@ typedef struct Tcl_Obj { long longValue; /* - an long integer value */ double doubleValue; /* - a double-precision floating value */ VOID *otherValuePtr; /* - another, type-specific value */ + Tcl_WideInt wideValue; /* - a long long value */ struct { /* - internal rep as two pointers */ VOID *ptr1; VOID *ptr2; @@ -662,6 +777,7 @@ typedef struct Tcl_Obj { } internalRep; } 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). @@ -672,7 +788,6 @@ typedef struct Tcl_Obj { * "obj" twice. This means that you should avoid calling it with an * expression that is expensive to compute or has side effects. */ - void Tcl_IncrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr)); void Tcl_DecrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr)); int Tcl_IsShared _ANSI_ARGS_((Tcl_Obj *objPtr)); @@ -716,14 +831,16 @@ int Tcl_IsShared _ANSI_ARGS_((Tcl_Obj *objPtr)); Tcl_DbNewObj(__FILE__, __LINE__) # define Tcl_NewStringObj(bytes, len) \ Tcl_DbNewStringObj(bytes, len, __FILE__, __LINE__) +# define Tcl_NewWideIntObj(val) \ + Tcl_DbNewWideIntObj(val, __FILE__, __LINE__) #endif /* TCL_MEM_DEBUG */ + /* * The following structure contains the state needed by * Tcl_SaveResult. No-one outside of Tcl should access any of these * fields. This structure is typically allocated on the stack. */ - typedef struct Tcl_SavedResult { char *result; Tcl_FreeProc *freeProc; @@ -759,6 +876,7 @@ typedef struct Tcl_Namespace { * namespace. */ } Tcl_Namespace; + /* * The following structure represents a call frame, or activation record. * A call frame defines a naming context for a procedure call: its local @@ -795,6 +913,7 @@ typedef struct Tcl_CallFrame { char* dummy10; } Tcl_CallFrame; + /* * Information about commands that is returned by Tcl_GetCommandInfo and * passed to Tcl_SetCommandInfo. objProc is an objc/objv object-based @@ -809,7 +928,7 @@ typedef struct Tcl_CallFrame { * does string-to-object or object-to-string argument conversions then * calls the other procedure. */ - + typedef struct Tcl_CmdInfo { int isNativeObjectProc; /* 1 if objProc was registered by a call to * Tcl_CreateObjCommand; 0 otherwise. @@ -833,10 +952,9 @@ typedef struct Tcl_CmdInfo { /* * The structure defined below is used to hold dynamic strings. The only - * field that clients should use is the string field, and they should - * never modify it. + * field that clients should use is the string field, accessible via the + * macro Tcl_DStringValue. */ - #define TCL_DSTRING_STATIC_SIZE 200 typedef struct Tcl_DString { char *string; /* Points to beginning of string: either @@ -859,7 +977,6 @@ typedef struct Tcl_DString { * be specified in the "tcl_precision" variable, and the number of * bytes of buffer space required by Tcl_PrintDouble. */ - #define TCL_MAX_PREC 17 #define TCL_DOUBLE_SPACE (TCL_MAX_PREC+10) @@ -868,7 +985,6 @@ typedef struct Tcl_DString { * string representation of an integer in base 10 (assuming the existence * of 64-bit integers). */ - #define TCL_INTEGER_SPACE 24 /* @@ -876,14 +992,12 @@ typedef struct Tcl_DString { * output braces (careful! if you change this flag be sure to change * the definitions at the front of tclUtil.c). */ - #define TCL_DONT_USE_BRACES 1 /* * Flag that may be passed to Tcl_GetIndexFromObj to force it to disallow * abbreviated strings. */ - #define TCL_EXACT 1 /* @@ -891,16 +1005,15 @@ typedef struct Tcl_DString { * WARNING: these bit choices must not conflict with the bit choices * for evalFlag bits in tclInt.h!! */ - #define TCL_NO_EVAL 0x10000 #define TCL_EVAL_GLOBAL 0x20000 #define TCL_EVAL_DIRECT 0x40000 +#define TCL_EVAL_INVOKE 0x80000 /* * Special freeProc values that may be passed to Tcl_SetResult (see * the man page for details): */ - #define TCL_VOLATILE ((Tcl_FreeProc *) 1) #define TCL_STATIC ((Tcl_FreeProc *) 0) #define TCL_DYNAMIC ((Tcl_FreeProc *) 3) @@ -908,7 +1021,6 @@ typedef struct Tcl_DString { /* * Flag values passed to variable-related procedures. */ - #define TCL_GLOBAL_ONLY 1 #define TCL_NAMESPACE_ONLY 2 #define TCL_APPEND_VALUE 4 @@ -920,6 +1032,30 @@ typedef struct Tcl_DString { #define TCL_INTERP_DESTROYED 0x100 #define TCL_LEAVE_ERR_MSG 0x200 #define TCL_TRACE_ARRAY 0x800 +#ifndef TCL_REMOVE_OBSOLETE_TRACES +/* Required to support old variable/vdelete/vinfo traces */ +#define TCL_TRACE_OLD_STYLE 0x1000 +#endif +/* Indicate the semantics of the result of a trace */ +#define TCL_TRACE_RESULT_DYNAMIC 0x8000 +#define TCL_TRACE_RESULT_OBJECT 0x10000 + +/* + * Flag values passed to command-related procedures. + */ + +#define TCL_TRACE_RENAME 0x2000 +#define TCL_TRACE_DELETE 0x4000 + +#define TCL_ALLOW_INLINE_COMPILATION 0x20000 + +/* + * Flag values passed to Tcl_CreateObjTrace, and used internally + * by command execution traces. Slots 4,8,16 and 32 are + * used internally by execution traces (see tclCmdMZ.c) + */ +#define TCL_TRACE_ENTER_EXEC 1 +#define TCL_TRACE_LEAVE_EXEC 2 /* * The TCL_PARSE_PART1 flag is deprecated and has no effect. @@ -929,28 +1065,45 @@ typedef struct Tcl_DString { * flag) */ #ifndef TCL_NO_DEPRECATED -#define TCL_PARSE_PART1 0x400 +# define TCL_PARSE_PART1 0x400 #endif /* * Types for linked variables: */ - #define TCL_LINK_INT 1 #define TCL_LINK_DOUBLE 2 #define TCL_LINK_BOOLEAN 3 #define TCL_LINK_STRING 4 +#define TCL_LINK_WIDE_INT 5 #define TCL_LINK_READ_ONLY 0x80 + /* - * Forward declaration of Tcl_HashTable. Needed by some C++ compilers - * to prevent errors when the forward reference to Tcl_HashTable is - * encountered in the Tcl_HashEntry structure. + * Forward declarations of Tcl_HashTable and related types. */ +typedef struct Tcl_HashKeyType Tcl_HashKeyType; +typedef struct Tcl_HashTable Tcl_HashTable; +typedef struct Tcl_HashEntry Tcl_HashEntry; -#ifdef __cplusplus -struct Tcl_HashTable; +typedef unsigned int (Tcl_HashKeyProc) _ANSI_ARGS_((Tcl_HashTable *tablePtr, + VOID *keyPtr)); +typedef int (Tcl_CompareHashKeysProc) _ANSI_ARGS_((VOID *keyPtr, + Tcl_HashEntry *hPtr)); +typedef Tcl_HashEntry *(Tcl_AllocHashEntryProc) _ANSI_ARGS_(( + Tcl_HashTable *tablePtr, VOID *keyPtr)); +typedef void (Tcl_FreeHashEntryProc) _ANSI_ARGS_((Tcl_HashEntry *hPtr)); + +/* + * 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 /* @@ -959,18 +1112,30 @@ struct Tcl_HashTable; * defined below. */ -typedef struct Tcl_HashEntry { - struct Tcl_HashEntry *nextPtr; /* Pointer to next entry in this +struct Tcl_HashEntry { + Tcl_HashEntry *nextPtr; /* Pointer to next entry in this * hash bucket, or NULL for end of * chain. */ - struct Tcl_HashTable *tablePtr; /* Pointer to table containing entry. */ - struct Tcl_HashEntry **bucketPtr; /* Pointer to bucket that points to + Tcl_HashTable *tablePtr; /* Pointer to table containing entry. */ +#if TCL_HASH_KEY_STORE_HASH +# if TCL_PRESERVE_BINARY_COMPATABILITY + VOID *hash; /* Hash value, stored as pointer to + * ensure that the offsets of the + * fields in this structure are not + * changed. */ +# else + unsigned int hash; /* Hash value. */ +# endif +#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 Tcl_SetHashValue. */ union { /* Key has one of these forms: */ char *oneWordValue; /* One-word value for key. */ + Tcl_Obj *objPtr; /* Tcl_Obj * key value. */ int words[1]; /* Multiple integer words for key. * The actual size will be as large * as necessary for this table's @@ -979,7 +1144,63 @@ typedef struct Tcl_HashEntry { * will be as large as needed to hold * the key. */ } key; /* MUST BE LAST FIELD IN RECORD!! */ -} Tcl_HashEntry; +}; + +/* + * Flags used in Tcl_HashKeyType. + * + * TCL_HASH_KEY_RANDOMIZE_HASH: + * There are some things, pointers for example + * which don't hash well because they do not use + * the lower bits. If this flag is set then the + * hash table will attempt to rectify this by + * randomising the bits and then using the upper + * N bits as the index into the table. + */ +#define TCL_HASH_KEY_RANDOMIZE_HASH 0x1 + +/* + * Structure definition for the methods associated with a hash table + * key type. + */ +#define TCL_HASH_KEY_TYPE_VERSION 1 +struct Tcl_HashKeyType { + int version; /* Version of the table. If this structure is + * extended in future then the version can be + * used to distinguish between different + * structures. + */ + + int flags; /* Flags, see above for details. */ + + /* Calculates a hash value for the key. If this is NULL then the pointer + * itself is used as a hash value. + */ + Tcl_HashKeyProc *hashKeyProc; + + /* Compares two keys and returns zero if they do not match, and non-zero + * if they do. If this is NULL then the pointers are compared. + */ + Tcl_CompareHashKeysProc *compareKeysProc; + + /* Called to allocate memory for a new entry, i.e. if the key is a + * string then this could allocate a single block which contains enough + * space for both the entry and the string. Only the key field of the + * allocated Tcl_HashEntry structure needs to be filled in. If something + * else needs to be done to the key, i.e. incrementing a reference count + * then that should be done by this function. If this is NULL then Tcl_Alloc + * is used to allocate enough space for a Tcl_HashEntry and the key pointer + * is assigned to key.oneWordValue. + */ + Tcl_AllocHashEntryProc *allocEntryProc; + + /* Called to free memory associated with an entry. If something else needs + * to be done to the key, i.e. decrementing a reference count then that + * should be done by this function. If this is NULL then Tcl_Free is used + * to free the Tcl_HashEntry. + */ + Tcl_FreeHashEntryProc *freeEntryProc; +}; /* * Structure definition for a hash table. Must be in tcl.h so clients @@ -988,7 +1209,7 @@ typedef struct Tcl_HashEntry { */ #define TCL_SMALL_HASH_TABLE 4 -typedef struct Tcl_HashTable { +struct Tcl_HashTable { Tcl_HashEntry **buckets; /* Pointer to bucket array. Each * element points to first entry in * bucket's hash chain, or NULL. */ @@ -1007,16 +1228,20 @@ typedef struct Tcl_HashTable { int mask; /* Mask value used in hashing * function. */ int keyType; /* Type of keys used in this table. - * It's either TCL_STRING_KEYS, - * TCL_ONE_WORD_KEYS, or an integer - * giving the number of ints that - * is the size of the key. + * It's either TCL_CUSTOM_KEYS, + * TCL_STRING_KEYS, TCL_ONE_WORD_KEYS, + * or an integer giving the number of + * ints that is the size of the key. */ - Tcl_HashEntry *(*findProc) _ANSI_ARGS_((struct Tcl_HashTable *tablePtr, +#if TCL_PRESERVE_BINARY_COMPATABILITY + Tcl_HashEntry *(*findProc) _ANSI_ARGS_((Tcl_HashTable *tablePtr, CONST char *key)); - Tcl_HashEntry *(*createProc) _ANSI_ARGS_((struct Tcl_HashTable *tablePtr, + Tcl_HashEntry *(*createProc) _ANSI_ARGS_((Tcl_HashTable *tablePtr, CONST char *key, int *newPtr)); -} Tcl_HashTable; +#endif + Tcl_HashKeyType *typePtr; /* Type of the keys used in the + * Tcl_HashTable. */ +}; /* * Structure definition for information used to keep track of searches @@ -1033,36 +1258,79 @@ typedef struct Tcl_HashSearch { /* * Acceptable key types for hash tables: + * + * TCL_STRING_KEYS: The keys are strings, they are copied into + * the entry. + * TCL_ONE_WORD_KEYS: The keys are pointers, the pointer is stored + * in the entry. + * TCL_CUSTOM_TYPE_KEYS: The keys are arbitrary types which are copied + * into the entry. + * TCL_CUSTOM_PTR_KEYS: The keys are pointers to arbitrary types, the + * pointer is stored in the entry. + * + * While maintaining binary compatability the above have to be distinct + * values as they are used to differentiate between old versions of the + * hash table which don't have a typePtr and new ones which do. Once binary + * compatability is discarded in favour of making more wide spread changes + * TCL_STRING_KEYS can be the same as TCL_CUSTOM_TYPE_KEYS, and + * TCL_ONE_WORD_KEYS can be the same as TCL_CUSTOM_PTR_KEYS because they + * simply determine how the key is accessed from the entry and not the + * behaviour. */ #define TCL_STRING_KEYS 0 #define TCL_ONE_WORD_KEYS 1 +#if TCL_PRESERVE_BINARY_COMPATABILITY +# define TCL_CUSTOM_TYPE_KEYS -2 +# define TCL_CUSTOM_PTR_KEYS -1 +#else +# define TCL_CUSTOM_TYPE_KEYS TCL_STRING_KEYS +# define TCL_CUSTOM_PTR_KEYS TCL_ONE_WORD_KEYS +#endif + /* * Macros for clients to use to access fields of hash entries: */ #define Tcl_GetHashValue(h) ((h)->clientData) #define Tcl_SetHashValue(h, value) ((h)->clientData = (ClientData) (value)) -#define Tcl_GetHashKey(tablePtr, h) \ - ((char *) (((tablePtr)->keyType == TCL_ONE_WORD_KEYS) ? (h)->key.oneWordValue \ - : (h)->key.string)) +#if TCL_PRESERVE_BINARY_COMPATABILITY +# define Tcl_GetHashKey(tablePtr, h) \ + ((char *) (((tablePtr)->keyType == TCL_ONE_WORD_KEYS || \ + (tablePtr)->keyType == TCL_CUSTOM_PTR_KEYS) \ + ? (h)->key.oneWordValue \ + : (h)->key.string)) +#else +# define Tcl_GetHashKey(tablePtr, h) \ + ((char *) (((tablePtr)->keyType == TCL_ONE_WORD_KEYS) \ + ? (h)->key.oneWordValue \ + : (h)->key.string)) +#endif /* * Macros to use for clients to use to invoke find and create procedures * for hash tables: */ -#define Tcl_FindHashEntry(tablePtr, key) \ +#if TCL_PRESERVE_BINARY_COMPATABILITY +# define Tcl_FindHashEntry(tablePtr, key) \ (*((tablePtr)->findProc))(tablePtr, key) -#define Tcl_CreateHashEntry(tablePtr, key, newPtr) \ +# define Tcl_CreateHashEntry(tablePtr, key, newPtr) \ (*((tablePtr)->createProc))(tablePtr, key, newPtr) +#else /* !TCL_PRESERVE_BINARY_COMPATABILITY */ +/* + * Macro to use new extended version of Tcl_InitHashTable. + */ +# define Tcl_InitHashTable(tablePtr, keyType) \ + Tcl_InitHashTableEx(tablePtr, keyType, NULL) +#endif /* TCL_PRESERVE_BINARY_COMPATABILITY */ + /* * Flag values to pass to Tcl_DoOneEvent to disable searches * for some kinds of events: */ - #define TCL_DONT_WAIT (1<<1) #define TCL_WINDOW_EVENTS (1<<2) #define TCL_FILE_EVENTS (1<<3) @@ -1079,7 +1347,6 @@ typedef struct Tcl_HashSearch { * a Tcl_Event header followed by additional information specific to that * event. */ - struct Tcl_Event { Tcl_EventProc *proc; /* Procedure to call to service this event. */ struct Tcl_Event *nextPtr; /* Next in list of pending events, or NULL. */ @@ -1088,7 +1355,6 @@ struct Tcl_Event { /* * Positions to pass to Tcl_QueueEvent: */ - typedef enum { TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK } Tcl_QueuePosition; @@ -1097,17 +1363,16 @@ typedef enum { * Values to pass to Tcl_SetServiceMode to specify the behavior of notifier * event routines. */ - #define TCL_SERVICE_NONE 0 #define TCL_SERVICE_ALL 1 + /* * The following structure keeps is used to hold a time value, either as * an absolute time (the number of seconds from the epoch) or as an * elapsed time. On Unix systems the epoch is Midnight Jan 1, 1970 GMT. * On Macintosh systems the epoch is Midnight Jan 1, 1904 GMT. */ - typedef struct Tcl_Time { long sec; /* Seconds. */ long usec; /* Microseconds. */ @@ -1116,11 +1381,11 @@ typedef struct Tcl_Time { typedef void (Tcl_SetTimerProc) _ANSI_ARGS_((Tcl_Time *timePtr)); typedef int (Tcl_WaitForEventProc) _ANSI_ARGS_((Tcl_Time *timePtr)); + /* * Bits to pass to Tcl_CreateFileHandler and Tcl_CreateChannelHandler * to indicate what sorts of events are of interest: */ - #define TCL_READABLE (1<<1) #define TCL_WRITABLE (1<<2) #define TCL_EXCEPTION (1<<3) @@ -1130,7 +1395,6 @@ typedef int (Tcl_WaitForEventProc) _ANSI_ARGS_((Tcl_Time *timePtr)); * disposition of the stdio handles. TCL_STDIN, TCL_STDOUT, TCL_STDERR, * are also used in Tcl_GetStdChannel. */ - #define TCL_STDIN (1<<1) #define TCL_STDOUT (1<<2) #define TCL_STDERR (1<<3) @@ -1140,28 +1404,25 @@ typedef int (Tcl_WaitForEventProc) _ANSI_ARGS_((Tcl_Time *timePtr)); * Bits passed to Tcl_DriverClose2Proc to indicate which side of a channel * should be closed. */ - #define TCL_CLOSE_READ (1<<1) -#define TCL_CLOSE_WRITE (1<<2) +#define TCL_CLOSE_WRITE (1<<2) /* * Value to use as the closeProc for a channel that supports the * close2Proc interface. */ - #define TCL_CLOSE2PROC ((Tcl_DriverCloseProc *)1) /* * Channel version tag. This was introduced in 8.3.2/8.4. */ - #define TCL_CHANNEL_VERSION_1 ((Tcl_ChannelTypeVersion) 0x1) #define TCL_CHANNEL_VERSION_2 ((Tcl_ChannelTypeVersion) 0x2) +#define TCL_CHANNEL_VERSION_3 ((Tcl_ChannelTypeVersion) 0x3) /* * Typedefs for the various operations in a channel type: */ - typedef int (Tcl_DriverBlockModeProc) _ANSI_ARGS_(( ClientData instanceData, int mode)); typedef int (Tcl_DriverCloseProc) _ANSI_ARGS_((ClientData instanceData, @@ -1171,15 +1432,15 @@ typedef int (Tcl_DriverClose2Proc) _ANSI_ARGS_((ClientData instanceData, typedef int (Tcl_DriverInputProc) _ANSI_ARGS_((ClientData instanceData, char *buf, int toRead, int *errorCodePtr)); typedef int (Tcl_DriverOutputProc) _ANSI_ARGS_((ClientData instanceData, - char *buf, int toWrite, int *errorCodePtr)); + CONST84 char *buf, int toWrite, int *errorCodePtr)); typedef int (Tcl_DriverSeekProc) _ANSI_ARGS_((ClientData instanceData, long offset, int mode, int *errorCodePtr)); typedef int (Tcl_DriverSetOptionProc) _ANSI_ARGS_(( ClientData instanceData, Tcl_Interp *interp, - char *optionName, char *value)); + CONST char *optionName, CONST char *value)); typedef int (Tcl_DriverGetOptionProc) _ANSI_ARGS_(( ClientData instanceData, Tcl_Interp *interp, - char *optionName, Tcl_DString *dsPtr)); + CONST84 char *optionName, Tcl_DString *dsPtr)); typedef void (Tcl_DriverWatchProc) _ANSI_ARGS_(( ClientData instanceData, int mask)); typedef int (Tcl_DriverGetHandleProc) _ANSI_ARGS_(( @@ -1189,19 +1450,23 @@ typedef int (Tcl_DriverFlushProc) _ANSI_ARGS_(( ClientData instanceData)); typedef int (Tcl_DriverHandlerProc) _ANSI_ARGS_(( ClientData instanceData, int interestMask)); +typedef Tcl_WideInt (Tcl_DriverWideSeekProc) _ANSI_ARGS_(( + ClientData instanceData, Tcl_WideInt offset, + int mode, int *errorCodePtr)); + /* * The following declarations either map ckalloc and ckfree to * malloc and free, or they map them to procedures with all sorts * of debugging hooks defined in tclCkalloc.c. */ - #ifdef TCL_MEM_DEBUG # define ckalloc(x) Tcl_DbCkalloc(x, __FILE__, __LINE__) # define ckfree(x) Tcl_DbCkfree(x, __FILE__, __LINE__) # define ckrealloc(x,y) Tcl_DbCkrealloc((x), (y),__FILE__, __LINE__) - +# define attemptckalloc(x) Tcl_AttemptDbCkalloc(x, __FILE__, __LINE__) +# define attemptckrealloc(x,y) Tcl_AttemptDbCkrealloc((x), (y), __FILE__, __LINE__) #else /* !TCL_MEM_DEBUG */ /* @@ -1210,10 +1475,11 @@ typedef int (Tcl_DriverHandlerProc) _ANSI_ARGS_(( * is using the same memory allocator both inside and outside of the * Tcl library. */ - # define ckalloc(x) Tcl_Alloc(x) # define ckfree(x) Tcl_Free(x) # define ckrealloc(x,y) Tcl_Realloc(x,y) +# define attemptckalloc(x) Tcl_AttemptAlloc(x) +# define attemptckrealloc(x,y) Tcl_AttemptRealloc(x,y) # define Tcl_InitMemory(x) # define Tcl_DumpActiveMemory(x) # define Tcl_ValidateAllMemory(x,y) @@ -1221,17 +1487,6 @@ typedef int (Tcl_DriverHandlerProc) _ANSI_ARGS_(( #endif /* !TCL_MEM_DEBUG */ /* - * Enum for different end of line translation and recognition modes. - */ - -typedef enum Tcl_EolTranslation { - TCL_TRANSLATE_AUTO, /* Eol == \r, \n and \r\n. */ - TCL_TRANSLATE_CR, /* Eol == \r. */ - TCL_TRANSLATE_LF, /* Eol == \n. */ - TCL_TRANSLATE_CRLF /* Eol == \r\n. */ -} Tcl_EolTranslation; - -/* * struct Tcl_ChannelType: * * One such structure exists for each type (kind) of channel. @@ -1241,11 +1496,10 @@ typedef enum Tcl_EolTranslation { * It is recommend that the Tcl_Channel* functions are used to access * elements of this structure, instead of direct accessing. */ - typedef struct Tcl_ChannelType { char *typeName; /* The name of the channel type in Tcl - * commands. This storage is owned by - * channel type. */ + * commands. This storage is owned by + * channel type. */ Tcl_ChannelTypeVersion version; /* Version of the channel type. */ Tcl_DriverCloseProc *closeProc; /* Procedure to call to close the * channel, or TCL_CLOSE2PROC if the @@ -1274,13 +1528,22 @@ typedef struct Tcl_ChannelType { /* Set blocking mode for the * raw channel. May be NULL. */ /* - * Only valid in TCL_CHANNEL_VERSION_2 channels + * Only valid in TCL_CHANNEL_VERSION_2 channels or later */ Tcl_DriverFlushProc *flushProc; /* Procedure to call to flush a * channel. May be NULL. */ Tcl_DriverHandlerProc *handlerProc; /* Procedure to call to handle a * channel event. This will be passed * up the stacked channel chain. */ + /* + * Only valid in TCL_CHANNEL_VERSION_3 channels or later + */ + Tcl_DriverWideSeekProc *wideSeekProc; + /* Procedure to call to seek + * on the channel which can + * handle 64-bit offsets. May be + * NULL, and must be NULL if + * seekProc is NULL. */ } Tcl_ChannelType; /* @@ -1288,38 +1551,346 @@ typedef struct Tcl_ChannelType { * set the channel into blocking or nonblocking mode. They are passed * as arguments to the blockModeProc procedure in the above structure. */ - -#define TCL_MODE_BLOCKING 0 /* Put channel into blocking mode. */ -#define TCL_MODE_NONBLOCKING 1 /* Put channel into nonblocking +#define TCL_MODE_BLOCKING 0 /* Put channel into blocking mode. */ +#define TCL_MODE_NONBLOCKING 1 /* Put channel into nonblocking * mode. */ /* * Enum for different types of file paths. */ - typedef enum Tcl_PathType { TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, TCL_PATH_VOLUME_RELATIVE } Tcl_PathType; + +/* + * The following structure is used to pass glob type data amongst + * the various glob routines and Tcl_FSMatchInDirectory. + */ +typedef struct Tcl_GlobTypeData { + /* Corresponds to bcdpfls as in 'find -t' */ + int type; + /* Corresponds to file permissions */ + int perm; + /* Acceptable mac type */ + Tcl_Obj* macType; + /* Acceptable mac creator */ + Tcl_Obj* macCreator; +} Tcl_GlobTypeData; + +/* + * type and permission definitions for glob command + */ +#define TCL_GLOB_TYPE_BLOCK (1<<0) +#define TCL_GLOB_TYPE_CHAR (1<<1) +#define TCL_GLOB_TYPE_DIR (1<<2) +#define TCL_GLOB_TYPE_PIPE (1<<3) +#define TCL_GLOB_TYPE_FILE (1<<4) +#define TCL_GLOB_TYPE_LINK (1<<5) +#define TCL_GLOB_TYPE_SOCK (1<<6) + +#define TCL_GLOB_PERM_RONLY (1<<0) +#define TCL_GLOB_PERM_HIDDEN (1<<1) +#define TCL_GLOB_PERM_R (1<<2) +#define TCL_GLOB_PERM_W (1<<3) +#define TCL_GLOB_PERM_X (1<<4) + + +/* + * Typedefs for the various filesystem operations: + */ +typedef int (Tcl_FSStatProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_StatBuf *buf)); +typedef int (Tcl_FSAccessProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, int mode)); +typedef Tcl_Channel (Tcl_FSOpenFileChannelProc) + _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr, + int mode, int permissions)); +typedef int (Tcl_FSMatchInDirectoryProc) _ANSI_ARGS_((Tcl_Interp* interp, + Tcl_Obj *result, Tcl_Obj *pathPtr, CONST char *pattern, + Tcl_GlobTypeData * types)); +typedef Tcl_Obj* (Tcl_FSGetCwdProc) _ANSI_ARGS_((Tcl_Interp *interp)); +typedef int (Tcl_FSChdirProc) _ANSI_ARGS_((Tcl_Obj *pathPtr)); +typedef int (Tcl_FSLstatProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, + Tcl_StatBuf *buf)); +typedef int (Tcl_FSCreateDirectoryProc) _ANSI_ARGS_((Tcl_Obj *pathPtr)); +typedef int (Tcl_FSDeleteFileProc) _ANSI_ARGS_((Tcl_Obj *pathPtr)); +typedef int (Tcl_FSCopyDirectoryProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr, + Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr)); +typedef int (Tcl_FSCopyFileProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr, + Tcl_Obj *destPathPtr)); +typedef int (Tcl_FSRemoveDirectoryProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, + int recursive, Tcl_Obj **errorPtr)); +typedef int (Tcl_FSRenameFileProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr, + Tcl_Obj *destPathPtr)); +typedef void (Tcl_FSUnloadFileProc) _ANSI_ARGS_((Tcl_LoadHandle loadHandle)); +typedef Tcl_Obj* (Tcl_FSListVolumesProc) _ANSI_ARGS_((void)); +/* We have to declare the utime structure here. */ +struct utimbuf; +typedef int (Tcl_FSUtimeProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, + struct utimbuf *tval)); +typedef int (Tcl_FSNormalizePathProc) _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *pathPtr, int nextCheckpoint)); +typedef int (Tcl_FSFileAttrsGetProc) _ANSI_ARGS_((Tcl_Interp *interp, + int index, Tcl_Obj *pathPtr, + Tcl_Obj **objPtrRef)); +typedef CONST char** (Tcl_FSFileAttrStringsProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, + Tcl_Obj** objPtrRef)); +typedef int (Tcl_FSFileAttrsSetProc) _ANSI_ARGS_((Tcl_Interp *interp, + int index, Tcl_Obj *pathPtr, + Tcl_Obj *objPtr)); +typedef Tcl_Obj* (Tcl_FSLinkProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, + Tcl_Obj *toPtr, int linkType)); +typedef int (Tcl_FSLoadFileProc) _ANSI_ARGS_((Tcl_Interp * interp, + Tcl_Obj *pathPtr, + Tcl_LoadHandle *handlePtr, + Tcl_FSUnloadFileProc **unloadProcPtr)); +typedef int (Tcl_FSPathInFilesystemProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, + ClientData *clientDataPtr)); +typedef Tcl_Obj* (Tcl_FSFilesystemPathTypeProc) + _ANSI_ARGS_((Tcl_Obj *pathPtr)); +typedef Tcl_Obj* (Tcl_FSFilesystemSeparatorProc) + _ANSI_ARGS_((Tcl_Obj *pathPtr)); +typedef void (Tcl_FSFreeInternalRepProc) _ANSI_ARGS_((ClientData clientData)); +typedef ClientData (Tcl_FSDupInternalRepProc) + _ANSI_ARGS_((ClientData clientData)); +typedef Tcl_Obj* (Tcl_FSInternalToNormalizedProc) + _ANSI_ARGS_((ClientData clientData)); +typedef ClientData (Tcl_FSCreateInternalRepProc) _ANSI_ARGS_((Tcl_Obj *pathPtr)); + +typedef struct Tcl_FSVersion_ *Tcl_FSVersion; + +/* + *---------------------------------------------------------------- + * Data structures related to hooking into the filesystem + *---------------------------------------------------------------- + */ + +/* + * Filesystem version tag. This was introduced in 8.4. + */ +#define TCL_FILESYSTEM_VERSION_1 ((Tcl_FSVersion) 0x1) + +/* + * struct Tcl_Filesystem: + * + * One such structure exists for each type (kind) of filesystem. + * It collects together in one place all the functions that are + * part of the specific filesystem. Tcl always accesses the + * filesystem through one of these structures. + * + * Not all entries need be non-NULL; any which are NULL are simply + * ignored. However, a complete filesystem should provide all of + * these functions. The explanations in the structure show + * the importance of each function. + */ + +typedef struct Tcl_Filesystem { + CONST char *typeName; /* The name of the filesystem. */ + int structureLength; /* Length of this structure, so future + * binary compatibility can be assured. */ + Tcl_FSVersion version; + /* Version of the filesystem type. */ + Tcl_FSPathInFilesystemProc *pathInFilesystemProc; + /* Function to check whether a path is in + * this filesystem. This is the most + * important filesystem procedure. */ + Tcl_FSDupInternalRepProc *dupInternalRepProc; + /* Function to duplicate internal fs rep. May + * be NULL (but then fs is less efficient). */ + Tcl_FSFreeInternalRepProc *freeInternalRepProc; + /* Function to free internal fs rep. Must + * be implemented, if internal representations + * need freeing, otherwise it can be NULL. */ + Tcl_FSInternalToNormalizedProc *internalToNormalizedProc; + /* Function to convert internal representation + * to a normalized path. Only required if + * the fs creates pure path objects with no + * string/path representation. */ + Tcl_FSCreateInternalRepProc *createInternalRepProc; + /* Function to create a filesystem-specific + * internal representation. May be NULL + * if paths have no internal representation, + * or if the Tcl_FSPathInFilesystemProc + * for this filesystem always immediately + * creates an internal representation for + * paths it accepts. */ + Tcl_FSNormalizePathProc *normalizePathProc; + /* Function to normalize a path. Should + * be implemented for all filesystems + * which can have multiple string + * representations for the same path + * object. */ + Tcl_FSFilesystemPathTypeProc *filesystemPathTypeProc; + /* Function to determine the type of a + * path in this filesystem. May be NULL. */ + Tcl_FSFilesystemSeparatorProc *filesystemSeparatorProc; + /* Function to return the separator + * character(s) for this filesystem. Must + * be implemented. */ + Tcl_FSStatProc *statProc; + /* + * Function to process a 'Tcl_FSStat()' + * call. Must be implemented for any + * reasonable filesystem. + */ + Tcl_FSAccessProc *accessProc; + /* + * Function to process a 'Tcl_FSAccess()' + * call. Must be implemented for any + * reasonable filesystem. + */ + Tcl_FSOpenFileChannelProc *openFileChannelProc; + /* + * Function to process a + * 'Tcl_FSOpenFileChannel()' call. Must be + * implemented for any reasonable + * filesystem. + */ + Tcl_FSMatchInDirectoryProc *matchInDirectoryProc; + /* Function to process a + * 'Tcl_FSMatchInDirectory()'. If not + * implemented, then glob and recursive + * copy functionality will be lacking in + * the filesystem. */ + Tcl_FSUtimeProc *utimeProc; + /* Function to process a + * 'Tcl_FSUtime()' call. Required to + * allow setting (not reading) of times + * with 'file mtime', 'file atime' and + * the open-r/open-w/fcopy implementation + * of 'file copy'. */ + Tcl_FSLinkProc *linkProc; + /* Function to process a + * 'Tcl_FSLink()' call. Should be + * implemented only if the filesystem supports + * links (reading or creating). */ + Tcl_FSListVolumesProc *listVolumesProc; + /* Function to list any filesystem volumes + * added by this filesystem. Should be + * implemented only if the filesystem adds + * volumes at the head of the filesystem. */ + Tcl_FSFileAttrStringsProc *fileAttrStringsProc; + /* Function to list all attributes strings + * which are valid for this filesystem. + * If not implemented the filesystem will + * not support the 'file attributes' command. + * This allows arbitrary additional information + * to be attached to files in the filesystem. */ + Tcl_FSFileAttrsGetProc *fileAttrsGetProc; + /* Function to process a + * 'Tcl_FSFileAttrsGet()' call, used by + * 'file attributes'. */ + Tcl_FSFileAttrsSetProc *fileAttrsSetProc; + /* Function to process a + * 'Tcl_FSFileAttrsSet()' call, used by + * 'file attributes'. */ + Tcl_FSCreateDirectoryProc *createDirectoryProc; + /* Function to process a + * 'Tcl_FSCreateDirectory()' call. Should + * be implemented unless the FS is + * read-only. */ + Tcl_FSRemoveDirectoryProc *removeDirectoryProc; + /* Function to process a + * 'Tcl_FSRemoveDirectory()' call. Should + * be implemented unless the FS is + * read-only. */ + Tcl_FSDeleteFileProc *deleteFileProc; + /* Function to process a + * 'Tcl_FSDeleteFile()' call. Should + * be implemented unless the FS is + * read-only. */ + Tcl_FSCopyFileProc *copyFileProc; + /* Function to process a + * 'Tcl_FSCopyFile()' call. If not + * implemented Tcl will fall back + * on open-r, open-w and fcopy as + * a copying mechanism, for copying + * actions initiated in Tcl (not C). */ + Tcl_FSRenameFileProc *renameFileProc; + /* Function to process a + * 'Tcl_FSRenameFile()' call. If not + * implemented, Tcl will fall back on + * a copy and delete mechanism, for + * rename actions initiated in Tcl (not C). */ + Tcl_FSCopyDirectoryProc *copyDirectoryProc; + /* Function to process a + * 'Tcl_FSCopyDirectory()' call. If + * not implemented, Tcl will fall back + * on a recursive create-dir, file copy + * mechanism, for copying actions + * initiated in Tcl (not C). */ + Tcl_FSLstatProc *lstatProc; + /* Function to process a + * 'Tcl_FSLstat()' call. If not implemented, + * Tcl will attempt to use the 'statProc' + * defined above instead. */ + Tcl_FSLoadFileProc *loadFileProc; + /* Function to process a + * 'Tcl_FSLoadFile()' call. If not + * implemented, Tcl will fall back on + * a copy to native-temp followed by a + * Tcl_FSLoadFile on that temporary copy. */ + Tcl_FSGetCwdProc *getCwdProc; + /* + * Function to process a 'Tcl_FSGetCwd()' + * call. Most filesystems need not + * implement this. It will usually only be + * called once, if 'getcwd' is called + * before 'chdir'. May be NULL. + */ + Tcl_FSChdirProc *chdirProc; + /* + * Function to process a 'Tcl_FSChdir()' + * call. If filesystems do not implement + * this, it will be emulated by a series of + * directory access checks. Otherwise, + * virtual filesystems which do implement + * it need only respond with a positive + * return result if the dirName is a valid + * directory in their filesystem. They + * need not remember the result, since that + * will be automatically remembered for use + * by GetCwd. Real filesystems should + * carry out the correct action (i.e. call + * the correct system 'chdir' api). If not + * implemented, then 'cd' and 'pwd' will + * fail inside the filesystem. + */ +} Tcl_Filesystem; + +/* + * The following definitions are used as values for the 'linkAction' flag + * to Tcl_FSLink, or the linkProc of any filesystem. Any combination + * of flags can be given. For link creation, the linkProc should create + * a link which matches any of the types given. + * + * TCL_CREATE_SYMBOLIC_LINK: Create a symbolic or soft link. + * TCL_CREATE_HARD_LINK: Create a hard link. + */ +#define TCL_CREATE_SYMBOLIC_LINK 0x01 +#define TCL_CREATE_HARD_LINK 0x02 + /* * The following structure represents the Notifier functions that * you can override with the Tcl_SetNotifier call. */ - typedef struct Tcl_NotifierProcs { Tcl_SetTimerProc *setTimerProc; Tcl_WaitForEventProc *waitForEventProc; Tcl_CreateFileHandlerProc *createFileHandlerProc; Tcl_DeleteFileHandlerProc *deleteFileHandlerProc; + Tcl_InitNotifierProc *initNotifierProc; + Tcl_FinalizeNotifierProc *finalizeNotifierProc; + Tcl_AlertNotifierProc *alertNotifierProc; + Tcl_ServiceModeHookProc *serviceModeHookProc; } Tcl_NotifierProcs; + /* * The following structure represents a user-defined encoding. It collects * together all the functions that are used by the specific encoding. */ - typedef struct Tcl_EncodingType { CONST char *encodingName; /* The name of the encoding, e.g. "euc-jp". * This name is the unique key for this @@ -1373,16 +1944,14 @@ typedef struct Tcl_EncodingType { * in the destination buffer and then continue * to sonvert the source. */ - #define TCL_ENCODING_START 0x01 #define TCL_ENCODING_END 0x02 #define TCL_ENCODING_STOPONERROR 0x04 + /* - *---------------------------------------------------------------- - * The following data structures and declarations are for the new - * Tcl parser. This stuff should all move to tcl.h eventually. - *---------------------------------------------------------------- + * The following data structures and declarations are for the new Tcl + * parser. */ /* @@ -1390,11 +1959,10 @@ typedef struct Tcl_EncodingType { * variable reference, one of the following structures is created to * describe the token. */ - typedef struct Tcl_Token { int type; /* Type of token, such as TCL_TOKEN_WORD; * see below for valid types. */ - char *start; /* First character in token. */ + CONST char *start; /* First character in token. */ int size; /* Number of bytes in token. */ int numComponents; /* If this token is composed of other * tokens, this field tells how many of @@ -1476,7 +2044,6 @@ typedef struct Tcl_Token { * operator's operands. NumComponents is * always 0. */ - #define TCL_TOKEN_WORD 1 #define TCL_TOKEN_SIMPLE_WORD 2 #define TCL_TOKEN_TEXT 4 @@ -1491,7 +2058,6 @@ typedef struct Tcl_Token { * will be stored in the error field of the Tcl_Parse structure * defined below. */ - #define TCL_PARSE_SUCCESS 0 #define TCL_PARSE_QUOTE_EXTRA 1 #define TCL_PARSE_BRACE_EXTRA 2 @@ -1507,18 +2073,17 @@ typedef struct Tcl_Token { * A structure of the following type is filled in by Tcl_ParseCommand. * It describes a single command parsed from an input string. */ - #define NUM_STATIC_TOKENS 20 typedef struct Tcl_Parse { - char *commentStart; /* Pointer to # that begins the first of + CONST char *commentStart; /* Pointer to # that begins the first of * one or more comments preceding the * command. */ int commentSize; /* Number of bytes in comments (up through * newline character that terminates the * last comment). If there were no * comments, this field is 0. */ - char *commandStart; /* First character in first word of command. */ + CONST char *commandStart; /* First character in first word of command. */ int commandSize; /* Number of bytes in command, including * first character of first word, up * through the terminating newline, @@ -1542,13 +2107,13 @@ typedef struct Tcl_Parse { * Tcl_ParseCommand. */ - char *string; /* The original command string passed to + CONST char *string; /* The original command string passed to * Tcl_ParseCommand. */ - char *end; /* Points to the character just after the + CONST char *end; /* Points to the character just after the * last one in the command string. */ Tcl_Interp *interp; /* Interpreter to use for error reporting, * or NULL. */ - char *term; /* Points to character in string that + CONST char *term; /* Points to character in string that * terminated most recent token. Filled in * by ParseTokens. If an error occurs, * points to beginning of region where the @@ -1597,40 +2162,40 @@ typedef struct Tcl_Parse { * encoding. This error is reported only if * TCL_ENCODING_STOPONERROR was specified. */ - #define TCL_CONVERT_MULTIBYTE -1 #define TCL_CONVERT_SYNTAX -2 #define TCL_CONVERT_UNKNOWN -3 #define TCL_CONVERT_NOSPACE -4 + /* * The maximum number of bytes that are necessary to represent a single * Unicode character in UTF-8. */ - #define TCL_UTF_MAX 3 /* - * This represents a Unicode character. + * This represents a Unicode character. Any changes to this should + * also be reflected in regcustom.h. */ - typedef unsigned short Tcl_UniChar; + /* * Deprecated Tcl procedures: */ - #ifndef TCL_NO_DEPRECATED -#define Tcl_EvalObj(interp,objPtr) Tcl_EvalObjEx((interp),(objPtr),0) -#define Tcl_GlobalEvalObj(interp,objPtr) \ +# define Tcl_EvalObj(interp,objPtr) \ + Tcl_EvalObjEx((interp),(objPtr),0) +# define Tcl_GlobalEvalObj(interp,objPtr) \ Tcl_EvalObjEx((interp),(objPtr),TCL_EVAL_GLOBAL) #endif + /* * These function have been renamed. The old names are deprecated, but we * define these macros for backwards compatibilty. */ - #define Tcl_Ckalloc Tcl_Alloc #define Tcl_Ckfree Tcl_Free #define Tcl_Ckrealloc Tcl_Realloc @@ -1639,6 +2204,7 @@ typedef unsigned short Tcl_UniChar; #define panic Tcl_Panic #define panicVA Tcl_PanicVA + /* * The following constant is used to test for older versions of Tcl * in the stubs tables. @@ -1647,7 +2213,7 @@ typedef unsigned short Tcl_UniChar; * value since the stubs tables don't match. */ -#define TCL_STUB_MAGIC 0xFCA3BACF +#define TCL_STUB_MAGIC ((int)0xFCA3BACF) /* * The following function is required to be defined in all stubs aware @@ -1657,8 +2223,8 @@ typedef unsigned short Tcl_UniChar; * linked into an application. */ -EXTERN char * Tcl_InitStubs _ANSI_ARGS_((Tcl_Interp *interp, - char *version, int exact)); +EXTERN CONST char * Tcl_InitStubs _ANSI_ARGS_((Tcl_Interp *interp, + CONST char *version, int exact)); #ifndef USE_TCL_STUBS @@ -1680,6 +2246,26 @@ EXTERN char * Tcl_InitStubs _ANSI_ARGS_((Tcl_Interp *interp, #include "tclDecls.h" /* + * Include platform specific public function declarations that are + * accessible via the stubs table. + */ + +/* + * tclPlatDecls.h can't be included here on the Mac, as we need + * Mac specific headers to define the Mac types used in this file, + * but these Mac haders conflict with a number of tk types + * and thus can't be included in the globally read tcl.h + * This header was originally added here as a fix for bug 5241 + * (stub link error for symbols in TclPlatStubs table), as a work- + * around for the bug on the mac, tclMac.h is included immediately + * after tcl.h in the tcl precompiled header (with DLLEXPORT set). + */ + +#if !defined(MAC_TCL) +#include "tclPlatDecls.h" +#endif + +/* * Public functions that are not accessible via the stubs table. */ @@ -1691,24 +2277,23 @@ EXTERN void Tcl_Main _ANSI_ARGS_((int argc, char **argv, * This function is not *implemented* by the tcl library, so the storage * class is neither DLLEXPORT nor DLLIMPORT */ - #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS EXTERN int Tcl_AppInit _ANSI_ARGS_((Tcl_Interp *interp)); -#endif /* RESOURCE_INCLUDED */ +#endif /* RC_INVOKED */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT +#endif /* RESOURCE_INCLUDED */ + /* * end block for C++ */ - #ifdef __cplusplus } #endif - -#endif /* _TCL */ +#endif /* _TCL */ diff --git a/tcl/generic/tclAlloc.c b/tcl/generic/tclAlloc.c index 44c4e94b2c2..b510fb95bca 100644 --- a/tcl/generic/tclAlloc.c +++ b/tcl/generic/tclAlloc.c @@ -18,6 +18,13 @@ * RCS: @(#) $Id$ */ +/* + * Windows and Unix use an alternative allocator when building with threads + * that has significantly reduced lock contention. + */ + +#if !defined(TCL_THREADS) || !defined(USE_THREAD_ALLOC) + #include "tclInt.h" #include "tclPort.h" @@ -30,12 +37,10 @@ #endif /* - * With gcc this will already be defined. This should really - * make use of AC_CHECK_TYPE(caddr_t) but that can wait - * until we use config.h properly. + * We should really make use of AC_CHECK_TYPE(caddr_t) + * here, but it can wait until Tcl uses config.h properly. */ - -#if defined(MAC_TCL) || defined(_MSC_VER) || defined(__MINGW32__) +#if defined(MAC_TCL) || defined(_MSC_VER) || defined(__MINGW32__) || defined(__BORLANDC__) typedef unsigned long caddr_t; #endif @@ -723,4 +728,4 @@ TclpRealloc(cp, nbytes) } #endif /* !USE_TCLALLOC */ - +#endif /* !TCL_THREADS */ diff --git a/tcl/generic/tclAsync.c b/tcl/generic/tclAsync.c index 6ec8ca9934b..cf689dee2cc 100644 --- a/tcl/generic/tclAsync.c +++ b/tcl/generic/tclAsync.c @@ -18,6 +18,9 @@ #include "tclInt.h" #include "tclPort.h" +/* Forward declaration */ +struct ThreadSpecificData; + /* * One of the following structures exists for each asynchronous * handler: @@ -33,34 +36,74 @@ typedef struct AsyncHandler { * is invoked. */ ClientData clientData; /* Value to pass to handler when it * is invoked. */ + struct ThreadSpecificData *originTsd; + /* Used in Tcl_AsyncMark to modify thread- + * specific data from outside the thread + * it is associated to. */ + Tcl_ThreadId originThrdId; /* Origin thread where this token was + * created and where it will be + * yielded. */ } AsyncHandler; -/* - * The variables below maintain a list of all existing handlers. - */ -static AsyncHandler *firstHandler; /* First handler defined for process, - * or NULL if none. */ -static AsyncHandler *lastHandler; /* Last handler or NULL. */ +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. */ -TCL_DECLARE_MUTEX(asyncMutex) /* Process-wide async handler lock */ + /* + * The variable below is set to 1 whenever a handler becomes ready and + * it is cleared to zero whenever Tcl_AsyncInvoke is called. It can be + * checked elsewhere in the application by calling Tcl_AsyncReady to see + * if Tcl_AsyncInvoke should be invoked. + */ -/* - * The variable below is set to 1 whenever a handler becomes ready and - * it is cleared to zero whenever Tcl_AsyncInvoke is called. It can be - * checked elsewhere in the application by calling Tcl_AsyncReady to see - * if Tcl_AsyncInvoke should be invoked. - */ + int asyncReady; + + /* + * The variable below indicates whether Tcl_AsyncInvoke is currently + * working. If so then we won't set asyncReady again until + * Tcl_AsyncInvoke returns. + */ -static int asyncReady = 0; + int asyncActive; + Tcl_Mutex asyncMutex; /* Thread-specific AsyncHandler linked-list lock */ + +} ThreadSpecificData; +static Tcl_ThreadDataKey dataKey; + + /* - * The variable below indicates whether Tcl_AsyncInvoke is currently - * working. If so then we won't set asyncReady again until - * Tcl_AsyncInvoke returns. + *---------------------------------------------------------------------- + * + * TclFinalizeAsync -- + * + * Finalizes the mutex in the thread local data structure for the + * async subsystem. + * + * Results: + * None. + * + * Side effects: + * Forgets knowledge of the mutex should it have been created. + * + *---------------------------------------------------------------------- */ -static int asyncActive = 0; +void +TclFinalizeAsync() +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + if (tsdPtr->asyncMutex != NULL) { + Tcl_MutexFinalize(&tsdPtr->asyncMutex); + } +} /* *---------------------------------------------------------------------- @@ -88,20 +131,24 @@ Tcl_AsyncCreate(proc, clientData) ClientData clientData; /* Argument to pass to handler. */ { AsyncHandler *asyncPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); asyncPtr = (AsyncHandler *) ckalloc(sizeof(AsyncHandler)); asyncPtr->ready = 0; asyncPtr->nextPtr = NULL; asyncPtr->proc = proc; asyncPtr->clientData = clientData; - Tcl_MutexLock(&asyncMutex); - if (firstHandler == NULL) { - firstHandler = asyncPtr; + asyncPtr->originTsd = tsdPtr; + asyncPtr->originThrdId = Tcl_GetCurrentThread(); + + Tcl_MutexLock(&tsdPtr->asyncMutex); + if (tsdPtr->firstHandler == NULL) { + tsdPtr->firstHandler = asyncPtr; } else { - lastHandler->nextPtr = asyncPtr; + tsdPtr->lastHandler->nextPtr = asyncPtr; } - lastHandler = asyncPtr; - Tcl_MutexUnlock(&asyncMutex); + tsdPtr->lastHandler = asyncPtr; + Tcl_MutexUnlock(&tsdPtr->asyncMutex); return (Tcl_AsyncHandler) asyncPtr; } @@ -128,13 +175,15 @@ void Tcl_AsyncMark(async) Tcl_AsyncHandler async; /* Token for handler. */ { - Tcl_MutexLock(&asyncMutex); - ((AsyncHandler *) async)->ready = 1; - if (!asyncActive) { - asyncReady = 1; - TclpAsyncMark(async); + AsyncHandler *token = (AsyncHandler *) async; + + Tcl_MutexLock(&token->originTsd->asyncMutex); + token->ready = 1; + if (!token->originTsd->asyncActive) { + token->originTsd->asyncReady = 1; + Tcl_ThreadAlert(token->originThrdId); } - Tcl_MutexUnlock(&asyncMutex); + Tcl_MutexUnlock(&token->originTsd->asyncMutex); } /* @@ -167,14 +216,16 @@ Tcl_AsyncInvoke(interp, code) * just completed. */ { AsyncHandler *asyncPtr; - Tcl_MutexLock(&asyncMutex); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + Tcl_MutexLock(&tsdPtr->asyncMutex); - if (asyncReady == 0) { - Tcl_MutexUnlock(&asyncMutex); + if (tsdPtr->asyncReady == 0) { + Tcl_MutexUnlock(&tsdPtr->asyncMutex); return code; } - asyncReady = 0; - asyncActive = 1; + tsdPtr->asyncReady = 0; + tsdPtr->asyncActive = 1; if (interp == NULL) { code = 0; } @@ -191,7 +242,7 @@ Tcl_AsyncInvoke(interp, code) */ while (1) { - for (asyncPtr = firstHandler; asyncPtr != NULL; + for (asyncPtr = tsdPtr->firstHandler; asyncPtr != NULL; asyncPtr = asyncPtr->nextPtr) { if (asyncPtr->ready) { break; @@ -201,12 +252,12 @@ Tcl_AsyncInvoke(interp, code) break; } asyncPtr->ready = 0; - Tcl_MutexUnlock(&asyncMutex); + Tcl_MutexUnlock(&tsdPtr->asyncMutex); code = (*asyncPtr->proc)(asyncPtr->clientData, interp, code); - Tcl_MutexLock(&asyncMutex); + Tcl_MutexLock(&tsdPtr->asyncMutex); } - asyncActive = 0; - Tcl_MutexUnlock(&asyncMutex); + tsdPtr->asyncActive = 0; + Tcl_MutexUnlock(&tsdPtr->asyncMutex); return code; } @@ -231,26 +282,27 @@ void Tcl_AsyncDelete(async) Tcl_AsyncHandler async; /* Token for handler to delete. */ { + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); AsyncHandler *asyncPtr = (AsyncHandler *) async; AsyncHandler *prevPtr; - Tcl_MutexLock(&asyncMutex); - if (firstHandler == asyncPtr) { - firstHandler = asyncPtr->nextPtr; - if (firstHandler == NULL) { - lastHandler = NULL; + Tcl_MutexLock(&tsdPtr->asyncMutex); + if (tsdPtr->firstHandler == asyncPtr) { + tsdPtr->firstHandler = asyncPtr->nextPtr; + if (tsdPtr->firstHandler == NULL) { + tsdPtr->lastHandler = NULL; } } else { - prevPtr = firstHandler; + prevPtr = tsdPtr->firstHandler; while (prevPtr->nextPtr != asyncPtr) { prevPtr = prevPtr->nextPtr; } prevPtr->nextPtr = asyncPtr->nextPtr; - if (lastHandler == asyncPtr) { - lastHandler = prevPtr; + if (tsdPtr->lastHandler == asyncPtr) { + tsdPtr->lastHandler = prevPtr; } } - Tcl_MutexUnlock(&asyncMutex); + Tcl_MutexUnlock(&tsdPtr->asyncMutex); ckfree((char *) asyncPtr); } @@ -261,7 +313,7 @@ Tcl_AsyncDelete(async) * * This procedure can be used to tell whether Tcl_AsyncInvoke * needs to be called. This procedure is the external interface - * for checking the internal asyncReady variable. + * for checking the thread-specific asyncReady variable. * * Results: * The return value is 1 whenever a handler is ready and is 0 @@ -276,5 +328,6 @@ Tcl_AsyncDelete(async) int Tcl_AsyncReady() { - return asyncReady; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + return tsdPtr->asyncReady; } diff --git a/tcl/generic/tclBasic.c b/tcl/generic/tclBasic.c index 8c6a19de4ef..1fe5f109c56 100644 --- a/tcl/generic/tclBasic.c +++ b/tcl/generic/tclBasic.c @@ -3,11 +3,12 @@ * * Contains the basic facilities for TCL command interpretation, * including interpreter creation and deletion, command creation - * and deletion, and command parsing and execution. + * 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. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -25,12 +26,20 @@ * Static procedures in this file: */ +static char * CallCommandTraces _ANSI_ARGS_((Interp *iPtr, + Command *cmdPtr, CONST char *oldName, + CONST char* newName, int flags)); static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp)); static void ProcessUnexpectedResult _ANSI_ARGS_(( Tcl_Interp *interp, int returnCode)); -static void RecordTracebackInfo _ANSI_ARGS_(( - Tcl_Interp *interp, Tcl_Obj *objPtr, - int numSrcBytes)); +static int StringTraceProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp* interp, + int level, + CONST char* command, + Tcl_Command commandInfo, + int objc, + Tcl_Obj *CONST objv[])); +static void StringTraceDeleteProc _ANSI_ARGS_((ClientData clientData)); extern TclStubs tclStubs; @@ -62,7 +71,7 @@ static CmdInfo builtInCmds[] = { */ {"append", (Tcl_CmdProc *) NULL, Tcl_AppendObjCmd, - (CompileProc *) NULL, 1}, + TclCompileAppendCmd, 1}, {"array", (Tcl_CmdProc *) NULL, Tcl_ArrayObjCmd, (CompileProc *) NULL, 1}, {"binary", (Tcl_CmdProc *) NULL, Tcl_BinaryObjCmd, @@ -110,15 +119,15 @@ static CmdInfo builtInCmds[] = { {"join", (Tcl_CmdProc *) NULL, Tcl_JoinObjCmd, (CompileProc *) NULL, 1}, {"lappend", (Tcl_CmdProc *) NULL, Tcl_LappendObjCmd, - (CompileProc *) NULL, 1}, + TclCompileLappendCmd, 1}, {"lindex", (Tcl_CmdProc *) NULL, Tcl_LindexObjCmd, - (CompileProc *) NULL, 1}, + TclCompileLindexCmd, 1}, {"linsert", (Tcl_CmdProc *) NULL, Tcl_LinsertObjCmd, (CompileProc *) NULL, 1}, {"list", (Tcl_CmdProc *) NULL, Tcl_ListObjCmd, - (CompileProc *) NULL, 1}, + TclCompileListCmd, 1}, {"llength", (Tcl_CmdProc *) NULL, Tcl_LlengthObjCmd, - (CompileProc *) NULL, 1}, + TclCompileLlengthCmd, 1}, {"load", (Tcl_CmdProc *) NULL, Tcl_LoadObjCmd, (CompileProc *) NULL, 0}, {"lrange", (Tcl_CmdProc *) NULL, Tcl_LrangeObjCmd, @@ -127,6 +136,8 @@ static CmdInfo builtInCmds[] = { (CompileProc *) NULL, 1}, {"lsearch", (Tcl_CmdProc *) NULL, Tcl_LsearchObjCmd, (CompileProc *) NULL, 1}, + {"lset", (Tcl_CmdProc *) NULL, Tcl_LsetObjCmd, + TclCompileLsetCmd, 1}, {"lsort", (Tcl_CmdProc *) NULL, Tcl_LsortObjCmd, (CompileProc *) NULL, 1}, {"namespace", (Tcl_CmdProc *) NULL, Tcl_NamespaceObjCmd, @@ -136,13 +147,13 @@ static CmdInfo builtInCmds[] = { {"proc", (Tcl_CmdProc *) NULL, Tcl_ProcObjCmd, (CompileProc *) NULL, 1}, {"regexp", (Tcl_CmdProc *) NULL, Tcl_RegexpObjCmd, - (CompileProc *) NULL, 1}, + TclCompileRegexpCmd, 1}, {"regsub", (Tcl_CmdProc *) NULL, Tcl_RegsubObjCmd, (CompileProc *) NULL, 1}, {"rename", (Tcl_CmdProc *) NULL, Tcl_RenameObjCmd, (CompileProc *) NULL, 1}, {"return", (Tcl_CmdProc *) NULL, Tcl_ReturnObjCmd, - (CompileProc *) NULL, 1}, + TclCompileReturnCmd, 1}, {"scan", (Tcl_CmdProc *) NULL, Tcl_ScanObjCmd, (CompileProc *) NULL, 1}, {"set", (Tcl_CmdProc *) NULL, Tcl_SetObjCmd, @@ -150,7 +161,7 @@ static CmdInfo builtInCmds[] = { {"split", (Tcl_CmdProc *) NULL, Tcl_SplitObjCmd, (CompileProc *) NULL, 1}, {"string", (Tcl_CmdProc *) NULL, Tcl_StringObjCmd, - (CompileProc *) NULL, 1}, + TclCompileStringCmd, 1}, {"subst", (Tcl_CmdProc *) NULL, Tcl_SubstObjCmd, (CompileProc *) NULL, 1}, {"switch", (Tcl_CmdProc *) NULL, Tcl_SwitchObjCmd, @@ -239,6 +250,15 @@ static CmdInfo builtInCmds[] = { (CompileProc *) NULL, 0} }; +/* + * The following structure holds the client data for string-based + * trace procs + */ + +typedef struct StringTraceData { + ClientData clientData; /* Client data from Tcl_CreateTrace */ + Tcl_CmdTraceProc* proc; /* Trace procedure from Tcl_CreateTrace */ +} StringTraceData; /* *---------------------------------------------------------------------- @@ -253,8 +273,8 @@ static CmdInfo builtInCmds[] = { * Tcl_DeleteInterp. * * Side effects: - * The command interpreter is initialized with an empty variable - * table and the built-in commands. + * The command interpreter is initialized with the built-in commands + * and with the variables documented in tclvars(n). * *---------------------------------------------------------------------- */ @@ -311,10 +331,10 @@ Tcl_CreateInterp() Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS); iPtr->numLevels = 0; - iPtr->maxNestingDepth = 1000; + iPtr->maxNestingDepth = MAX_NESTING_DEPTH; iPtr->framePtr = NULL; iPtr->varFramePtr = NULL; - iPtr->activeTracePtr = NULL; + iPtr->activeVarTracePtr = NULL; iPtr->returnCode = TCL_OK; iPtr->errorInfo = NULL; iPtr->errorCode = NULL; @@ -335,6 +355,9 @@ Tcl_CreateInterp() iPtr->scriptFile = NULL; iPtr->flags = 0; iPtr->tracePtr = NULL; + iPtr->tracesForbiddingInline = 0; + iPtr->activeCmdTracePtr = NULL; + iPtr->activeInterpTracePtr = NULL; iPtr->assocData = (Tcl_HashTable *) NULL; iPtr->execEnvPtr = NULL; /* set after namespaces initialized */ iPtr->emptyObjPtr = Tcl_NewObj(); /* another empty object */ @@ -447,8 +470,9 @@ Tcl_CreateInterp() } cmdPtr->deleteProc = NULL; cmdPtr->deleteData = (ClientData) NULL; - cmdPtr->deleted = 0; + cmdPtr->flags = 0; cmdPtr->importRefPtr = NULL; + cmdPtr->tracePtr = NULL; Tcl_SetHashValue(hPtr, cmdPtr); } } @@ -458,7 +482,7 @@ Tcl_CreateInterp() */ i = 0; - for (builtinFuncPtr = builtinFuncTable; builtinFuncPtr->name != NULL; + for (builtinFuncPtr = tclBuiltinFuncTable; builtinFuncPtr->name != NULL; builtinFuncPtr++) { Tcl_CreateMathFunc((Tcl_Interp *) iPtr, builtinFuncPtr->name, builtinFuncPtr->numArgs, builtinFuncPtr->argTypes, @@ -518,6 +542,9 @@ Tcl_CreateInterp() ((order.c[0] == 1) ? "littleEndian" : "bigEndian"), TCL_GLOBAL_ONLY); + Tcl_SetVar2Ex(interp, "tcl_platform", "wordSize", + Tcl_NewLongObj((long) sizeof(long)), TCL_GLOBAL_ONLY); + /* * Set up other variables such as tcl_version and tcl_library */ @@ -715,7 +742,7 @@ Tcl_DontCallWhenDeleted(interp, proc, clientData) void Tcl_SetAssocData(interp, name, proc, clientData) Tcl_Interp *interp; /* Interpreter to associate with. */ - char *name; /* Name for association. */ + 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. */ @@ -761,7 +788,7 @@ Tcl_SetAssocData(interp, name, proc, clientData) void Tcl_DeleteAssocData(interp, name) Tcl_Interp *interp; /* Interpreter to associate with. */ - char *name; /* Name of association. */ + CONST char *name; /* Name of association. */ { Interp *iPtr = (Interp *) interp; AssocData *dPtr; @@ -803,7 +830,7 @@ Tcl_DeleteAssocData(interp, name) ClientData Tcl_GetAssocData(interp, name, procPtr) Tcl_Interp *interp; /* Interpreter associated with. */ - char *name; /* Name of association. */ + CONST char *name; /* Name of association. */ Tcl_InterpDeleteProc **procPtr; /* Pointer to place to store address * of current deletion callback. */ { @@ -1048,10 +1075,7 @@ DeleteInterpProc(interp) } TclFreePackageInfo(iPtr); while (iPtr->tracePtr != NULL) { - Trace *nextPtr = iPtr->tracePtr->nextPtr; - - ckfree((char *) iPtr->tracePtr); - iPtr->tracePtr = nextPtr; + Tcl_DeleteTrace( (Tcl_Interp*) iPtr, (Tcl_Trace) iPtr->tracePtr ); } if (iPtr->execEnvPtr != NULL) { TclDeleteExecEnv(iPtr->execEnvPtr); @@ -1098,8 +1122,8 @@ DeleteInterpProc(interp) int Tcl_HideCommand(interp, cmdName, hiddenCmdToken) Tcl_Interp *interp; /* Interpreter in which to hide command. */ - char *cmdName; /* Name of command to hide. */ - char *hiddenCmdToken; /* Token name of the to-be-hidden command. */ + CONST char *cmdName; /* Name of command to hide. */ + CONST char *hiddenCmdToken; /* Token name of the to-be-hidden command. */ { Interp *iPtr = (Interp *) interp; Tcl_Command cmd; @@ -1261,8 +1285,8 @@ int Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName) Tcl_Interp *interp; /* Interpreter in which to make command * callable. */ - char *hiddenCmdToken; /* Name of hidden command. */ - char *cmdName; /* Name of to-be-exposed command. */ + CONST char *hiddenCmdToken; /* Name of hidden command. */ + CONST char *cmdName; /* Name of to-be-exposed command. */ { Interp *iPtr = (Interp *) interp; Command *cmdPtr; @@ -1415,7 +1439,7 @@ Tcl_Command Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) Tcl_Interp *interp; /* Token for command interpreter returned by * a previous call to Tcl_CreateInterp. */ - char *cmdName; /* Name of command. If it contains namespace + 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. */ @@ -1430,7 +1454,7 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) Namespace *nsPtr, *dummy1, *dummy2; Command *cmdPtr, *refCmdPtr; Tcl_HashEntry *hPtr; - char *tail; + CONST char *tail; int new; ImportedCmdData *dataPtr; @@ -1498,8 +1522,9 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) cmdPtr->clientData = clientData; cmdPtr->deleteProc = deleteProc; cmdPtr->deleteData = clientData; - cmdPtr->deleted = 0; + cmdPtr->flags = 0; cmdPtr->importRefPtr = NULL; + cmdPtr->tracePtr = NULL; /* * Plug in any existing import references found above. Be sure @@ -1559,7 +1584,7 @@ Tcl_Command Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) Tcl_Interp *interp; /* Token for command interpreter (returned * by previous call to Tcl_CreateInterp). */ - char *cmdName; /* Name of command. If it contains namespace + 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. */ @@ -1576,7 +1601,7 @@ Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) Namespace *nsPtr, *dummy1, *dummy2; Command *cmdPtr, *refCmdPtr; Tcl_HashEntry *hPtr; - char *tail; + CONST char *tail; int new; ImportedCmdData *dataPtr; @@ -1659,8 +1684,9 @@ Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) cmdPtr->clientData = (ClientData) cmdPtr; cmdPtr->deleteProc = deleteProc; cmdPtr->deleteData = clientData; - cmdPtr->deleted = 0; + cmdPtr->flags = 0; cmdPtr->importRefPtr = NULL; + cmdPtr->tracePtr = NULL; /* * Plug in any existing import references found above. Be sure @@ -1727,8 +1753,8 @@ TclInvokeStringCommand(clientData, interp, objc, objv) */ #define NUM_ARGS 20 - char *(argStorage[NUM_ARGS]); - char **argv = argStorage; + CONST char *(argStorage[NUM_ARGS]); + CONST char **argv = argStorage; /* * Create the string argument array "argv". Make sure argv is large @@ -1737,7 +1763,7 @@ TclInvokeStringCommand(clientData, interp, objc, objv) */ if ((objc + 1) > NUM_ARGS) { - argv = (char **) ckalloc((unsigned)(objc + 1) * sizeof(char *)); + argv = (CONST char **) ckalloc((unsigned)(objc + 1) * sizeof(char *)); } for (i = 0; i < objc; i++) { @@ -1788,7 +1814,7 @@ TclInvokeObjectCommand(clientData, interp, argc, argv) ClientData clientData; /* Points to command's Command structure. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ - register char **argv; /* Argument strings. */ + register CONST char **argv; /* Argument strings. */ { Command *cmdPtr = (Command *) clientData; register Tcl_Obj *objPtr; @@ -1886,7 +1912,7 @@ TclRenameCommand(interp, oldName, newName) char *newName; /* New command name. */ { Interp *iPtr = (Interp *) interp; - char *newTail; + CONST char *newTail; Namespace *cmdNsPtr, *newNsPtr, *dummy1, *dummy2; Tcl_Command cmd; Command *cmdPtr; @@ -1976,6 +2002,15 @@ TclRenameCommand(interp, oldName, newName) } /* + * Script for rename traces can delete the command "oldName". + * Therefore increment the reference count for cmdPtr so that + * it's Command structure is freed only towards the end of this + * function by calling TclCleanupCommand. + */ + cmdPtr->refCount++; + CallCommandTraces(iPtr,cmdPtr,oldName,newName,TCL_TRACE_RENAME); + + /* * The new command name is okay, so remove the command from its * current namespace. This is like deleting the command, so bump * the cmdEpoch to invalidate any cached references to the command. @@ -1995,6 +2030,12 @@ TclRenameCommand(interp, oldName, newName) iPtr->compileEpoch++; } + /* + * Now free the Command structure, if the "oldName" command has + * been deleted by invocation of rename traces. + */ + TclCleanupCommand(cmdPtr); + return TCL_OK; } @@ -2024,15 +2065,48 @@ int Tcl_SetCommandInfo(interp, cmdName, infoPtr) Tcl_Interp *interp; /* Interpreter in which to look * for command. */ - char *cmdName; /* Name of desired command. */ - Tcl_CmdInfo *infoPtr; /* Where to find information + CONST char *cmdName; /* Name of desired command. */ + CONST Tcl_CmdInfo *infoPtr; /* Where to find information * to store in the command. */ { Tcl_Command cmd; - Command *cmdPtr; cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, /*flags*/ 0); + + return Tcl_SetCommandInfoFromToken( cmd, infoPtr ); + +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetCommandInfoFromToken -- + * + * Modifies various information about a Tcl command. Note that + * this procedure will not change a command's namespace; use + * Tcl_RenameCommand to do that. Also, the isNativeObjectProc + * member of *infoPtr is ignored. + * + * Results: + * If cmdName exists in interp, then the information at *infoPtr + * is stored with the command in place of the current information + * and 1 is returned. If the command doesn't exist then 0 is + * returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SetCommandInfoFromToken( cmd, infoPtr ) + Tcl_Command cmd; + CONST Tcl_CmdInfo* infoPtr; +{ + Command* cmdPtr; /* Internal representation of the command */ + if (cmd == (Tcl_Command) NULL) { return 0; } @@ -2079,16 +2153,46 @@ int Tcl_GetCommandInfo(interp, cmdName, infoPtr) Tcl_Interp *interp; /* Interpreter in which to look * for command. */ - char *cmdName; /* Name of desired command. */ + CONST char *cmdName; /* Name of desired command. */ Tcl_CmdInfo *infoPtr; /* Where to store information about * command. */ { Tcl_Command cmd; - Command *cmdPtr; cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL, /*flags*/ 0); - if (cmd == (Tcl_Command) NULL) { + + return Tcl_GetCommandInfoFromToken( cmd, infoPtr ); + +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetCommandInfoFromToken -- + * + * Returns various information about a Tcl command. + * + * Results: + * Copies information from the command identified by 'cmd' into + * a caller-supplied structure and returns 1. If the 'cmd' is + * NULL, leaves the structure untouched and returns 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetCommandInfoFromToken( cmd, infoPtr ) + Tcl_Command cmd; + Tcl_CmdInfo* infoPtr; +{ + + Command* cmdPtr; /* Internal representation of the command */ + + if ( cmd == (Tcl_Command) NULL ) { return 0; } @@ -2107,7 +2211,9 @@ Tcl_GetCommandInfo(interp, cmdName, infoPtr) infoPtr->deleteProc = cmdPtr->deleteProc; infoPtr->deleteData = cmdPtr->deleteData; infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr; + return 1; + } /* @@ -2128,7 +2234,7 @@ Tcl_GetCommandInfo(interp, cmdName, infoPtr) *---------------------------------------------------------------------- */ -char * +CONST char * Tcl_GetCommandName(interp, command) Tcl_Interp *interp; /* Interpreter containing the command. */ Tcl_Command command; /* Token for command returned by a previous @@ -2225,7 +2331,7 @@ int Tcl_DeleteCommand(interp, cmdName) Tcl_Interp *interp; /* Token for command interpreter (returned * by a previous Tcl_CreateInterp call). */ - char *cmdName; /* Name of command to remove. */ + CONST char *cmdName; /* Name of command to remove. */ { Tcl_Command cmd; @@ -2281,7 +2387,7 @@ Tcl_DeleteCommandFromToken(interp, cmd) * flag allows us to detect these cases and skip nested deletes. */ - if (cmdPtr->deleted) { + if (cmdPtr->flags & CMD_IS_DELETED) { /* * Another deletion is already in progress. Remove the hash * table entry now, but don't invoke a callback or free the @@ -2293,6 +2399,33 @@ Tcl_DeleteCommandFromToken(interp, cmd) return 0; } + /* + * We must delete this command, even though both traces and + * delete procs may try to avoid this (renaming the command etc). + * Also traces and delete procs may try to delete the command + * themsevles. This flag declares that a delete is in progress + * and that recursive deletes should be ignored. + */ + cmdPtr->flags |= CMD_IS_DELETED; + + /* + * Call trace procedures for the command being deleted. Then delete + * its traces. + */ + + if (cmdPtr->tracePtr != NULL) { + CommandTrace *tracePtr; + CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE); + /* Now delete these traces */ + tracePtr = cmdPtr->tracePtr; + while (tracePtr != NULL) { + CommandTrace *nextPtr = tracePtr->nextPtr; + Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); + tracePtr = nextPtr; + } + cmdPtr->tracePtr = NULL; + } + /* * If the command being deleted has a compile procedure, increment the * interpreter's compileEpoch to invalidate its compiled code. This @@ -2306,7 +2439,6 @@ Tcl_DeleteCommandFromToken(interp, cmd) iPtr->compileEpoch++; } - cmdPtr->deleted = 1; if (cmdPtr->deleteProc != NULL) { /* * Delete the command's client data. If this was an imported command @@ -2381,6 +2513,98 @@ Tcl_DeleteCommandFromToken(interp, cmd) TclCleanupCommand(cmdPtr); return 0; } +static char * +CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags) + Interp *iPtr; /* Interpreter containing command. */ + Command *cmdPtr; /* Command whose traces are to be + * invoked. */ + CONST char *oldName; /* Command's old name, or NULL if we + * must get the name from cmdPtr */ + CONST char *newName; /* Command's new name, or NULL if + * the command is not being renamed */ + int flags; /* Flags passed to trace procedures: + * indicates what's happening to command, + * plus other stuff like TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY, and + * TCL_INTERP_DESTROYED. */ +{ + register CommandTrace *tracePtr; + ActiveCommandTrace active; + char *result; + Tcl_Obj *oldNamePtr = NULL; + + if (cmdPtr->flags & CMD_TRACE_ACTIVE) { + /* + * 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 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 "oldName" is deleted. + */ + if (cmdPtr->flags & TCL_TRACE_RENAME) { + flags &= ~TCL_TRACE_RENAME; + } + if (flags == 0) { + return NULL; + } + } + cmdPtr->flags |= CMD_TRACE_ACTIVE; + cmdPtr->refCount++; + + result = NULL; + active.nextPtr = iPtr->activeCmdTracePtr; + iPtr->activeCmdTracePtr = &active; + + if (flags & TCL_TRACE_DELETE) { + flags |= TCL_TRACE_DESTROYED; + } + active.cmdPtr = cmdPtr; + Tcl_Preserve((ClientData) iPtr); + for (tracePtr = cmdPtr->tracePtr; tracePtr != NULL; + tracePtr = active.nextTracePtr) { + active.nextTracePtr = tracePtr->nextPtr; + if (!(tracePtr->flags & flags)) { + continue; + } + cmdPtr->flags |= tracePtr->flags; + if (oldName == NULL) { + TclNewObj(oldNamePtr); + Tcl_IncrRefCount(oldNamePtr); + Tcl_GetCommandFullName((Tcl_Interp *) iPtr, + (Tcl_Command) cmdPtr, oldNamePtr); + oldName = TclGetString(oldNamePtr); + } + Tcl_Preserve((ClientData) tracePtr); + (*tracePtr->traceProc)(tracePtr->clientData, + (Tcl_Interp *) iPtr, oldName, newName, flags); + cmdPtr->flags &= ~tracePtr->flags; + Tcl_Release((ClientData) tracePtr); + } + + /* + * If a new object was created to hold the full oldName, + * free it now. + */ + + if (oldNamePtr != NULL) { + TclDecrRefCount(oldNamePtr); + } + + /* + * Restore the variable's flags, remove the record of our active + * traces, and then return. + */ + + cmdPtr->flags &= ~CMD_TRACE_ACTIVE; + cmdPtr->refCount--; + iPtr->activeCmdTracePtr = active.nextPtr; + Tcl_Release((ClientData) iPtr); + return result; +} + /* *---------------------------------------------------------------------- @@ -2441,7 +2665,7 @@ void Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData) Tcl_Interp *interp; /* Interpreter in which function is * to be available. */ - char *name; /* Name of function (e.g. "sin"). */ + CONST char *name; /* Name of function (e.g. "sin"). */ int numArgs; /* Nnumber of arguments required by * function. */ Tcl_ValueType *argTypes; /* Array of types acceptable for @@ -2502,294 +2726,1254 @@ Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData) /* *---------------------------------------------------------------------- * - * Tcl_EvalObjEx -- + * Tcl_GetMathFuncInfo -- * - * Execute Tcl commands stored in a Tcl object. These commands are - * compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT - * is specified. + * Discovers how a particular math function was created in a given + * interpreter. * * Results: - * The return value is one of the return codes defined in tcl.h - * (such as TCL_OK), and the interpreter's result contains a value - * to supplement the return code. + * TCL_OK if it succeeds, TCL_ERROR else (leaving an error message + * in the interpreter result if that happens.) * * Side effects: - * The object is converted, if necessary, to a ByteCode object that - * holds the bytecode instructions for the commands. Executing the - * commands will almost certainly have side effects that depend - * on those commands. - * - * Just as in Tcl_Eval, interp->termOffset is set to the offset of the - * last character executed in the objPtr's string. + * If this function succeeds, the variables pointed to by the + * numArgsPtr and argTypePtr arguments will be updated to detail the + * arguments allowed by the function. The variable pointed to by the + * procPtr argument will be set to NULL if the function is a builtin + * function, and will be set to the address of the C function used to + * implement the math function otherwise (in which case the variable + * pointed to by the clientDataPtr argument will also be updated.) * *---------------------------------------------------------------------- */ int -Tcl_EvalObjEx(interp, objPtr, flags) - Tcl_Interp *interp; /* Token for command interpreter - * (returned by a previous call to - * Tcl_CreateInterp). */ - register Tcl_Obj *objPtr; /* Pointer to object containing - * commands to execute. */ - int flags; /* Collection of OR-ed bits that - * control the evaluation of the - * script. Supported values are - * TCL_EVAL_GLOBAL and - * TCL_EVAL_DIRECT. */ +Tcl_GetMathFuncInfo(interp, name, numArgsPtr, argTypesPtr, procPtr, + clientDataPtr) + Tcl_Interp *interp; + CONST char *name; + int *numArgsPtr; + Tcl_ValueType **argTypesPtr; + Tcl_MathProc **procPtr; + ClientData *clientDataPtr; { - register Interp *iPtr = (Interp *) interp; - int evalFlags; /* Interp->evalFlags value when the - * procedure was called. */ - register ByteCode* codePtr; /* Tcl Internal type of bytecode. */ - int oldCount = iPtr->cmdCount; /* Used to tell whether any commands - * at all were executed. */ - int numSrcBytes; - int result; - CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr - * in case TCL_EVAL_GLOBAL was set. */ - Namespace *namespacePtr; + Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hPtr; + MathFunc *mathFuncPtr; + Tcl_ValueType *argTypes; + int i,numArgs; - Tcl_IncrRefCount(objPtr); + hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, name); + if (hPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "math function \"", name, "\" not known in this interpreter", + (char *) NULL); + return TCL_ERROR; + } + mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); - if ((iPtr->flags & USE_EVAL_DIRECT) || (flags & TCL_EVAL_DIRECT)) { - /* - * We're not supposed to use the compiler or byte-code interpreter. - * Let Tcl_EvalEx evaluate the command directly (and probably - * more slowly). - * - * Pure List Optimization (no string representation). In this - * case, we can safely use Tcl_EvalObjv instead and get an - * appreciable improvement in execution speed. This is because it - * allows us to avoid a setFromAny step that would just pack - * everything into a string and back out again. - * - * USE_EVAL_DIRECT is a special flag used for testing purpose only - * (ensure we go into the TCL_EVAL_DIRECT path, avoiding opt) - */ - if (!(iPtr->flags & USE_EVAL_DIRECT) && - (objPtr->typePtr == &tclListType) && /* is a list... */ - (objPtr->bytes == NULL) /* ...without a string rep */) { - register List *listRepPtr = - (List *) objPtr->internalRep.otherValuePtr; - result = Tcl_EvalObjv(interp, listRepPtr->elemCount, - listRepPtr->elements, flags); - } else { - register char *p; - p = Tcl_GetStringFromObj(objPtr, &numSrcBytes); - result = Tcl_EvalEx(interp, p, numSrcBytes, flags); - } - Tcl_DecrRefCount(objPtr); - return result; + *numArgsPtr = numArgs = mathFuncPtr->numArgs; + if (numArgs == 0) { + /* Avoid doing zero-sized allocs... */ + numArgs = 1; + } + *argTypesPtr = argTypes = + (Tcl_ValueType *)ckalloc(numArgs * sizeof(Tcl_ValueType)); + for (i = 0; i < mathFuncPtr->numArgs; i++) { + argTypes[i] = mathFuncPtr->argTypes[i]; } - /* - * Prevent the object from being deleted as a side effect of evaling it. - */ + if (mathFuncPtr->builtinFuncIndex == -1) { + *procPtr = (Tcl_MathProc *) NULL; + } else { + *procPtr = mathFuncPtr->proc; + *clientDataPtr = mathFuncPtr->clientData; + } - savedVarFramePtr = iPtr->varFramePtr; - if (flags & TCL_EVAL_GLOBAL) { - iPtr->varFramePtr = NULL; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ListMathFuncs -- + * + * Produces a list of all the math functions defined in a given + * interpreter. + * + * Results: + * A pointer to a Tcl_Obj structure with a reference count of zero, + * or NULL in the case of an error (in which case a suitable error + * message will be left in the interpreter result.) + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +Tcl_ListMathFuncs(interp, pattern) + Tcl_Interp *interp; + CONST char *pattern; +{ + Interp *iPtr = (Interp *) interp; + Tcl_Obj *resultList = Tcl_NewObj(); + register Tcl_HashEntry *hPtr; + Tcl_HashSearch hSearch; + CONST char *name; + + for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &hSearch); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { + name = Tcl_GetHashKey(&iPtr->mathFuncTable, hPtr); + if ((pattern == NULL || Tcl_StringMatch(name, pattern)) && + /* I don't expect this to fail, but... */ + Tcl_ListObjAppendElement(interp, resultList, + Tcl_NewStringObj(name,-1)) != TCL_OK) { + Tcl_DecrRefCount(resultList); + return NULL; + } } + return resultList; +} + +/* + *---------------------------------------------------------------------- + * + * TclInterpReady -- + * + * Check if an interpreter is ready to eval commands or scripts, + * i.e., if it was not deleted and if the nesting level is not + * too high. + * + * Results: + * The return value is TCL_OK if it the interpreter is ready, + * TCL_ERROR otherwise. + * + * Side effects: + * The interpreters object and string results are cleared. + * + *---------------------------------------------------------------------- + */ + +int +TclInterpReady(interp) + Tcl_Interp *interp; +{ + register Interp *iPtr = (Interp *) interp; /* - * Reset both the interpreter's string and object results and clear out - * any error information. This makes sure that we return an empty - * result if there are no commands in the command string. + * Reset both the interpreter's string and object results and clear + * out any previous error information. */ Tcl_ResetResult(interp); /* + * If the interpreter has been deleted, return an error. + */ + + if (iPtr->flags & DELETED) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "attempt to call eval in deleted interpreter", -1); + Tcl_SetErrorCode(interp, "CORE", "IDELETE", + "attempt to call eval in deleted interpreter", + (char *) NULL); + return TCL_ERROR; + } + + /* * Check depth of nested calls to Tcl_Eval: if this gets too large, * it's probably because of an infinite loop somewhere. */ - iPtr->numLevels++; - if (iPtr->numLevels > iPtr->maxNestingDepth) { + if (((iPtr->numLevels) >= iPtr->maxNestingDepth) + || (TclpCheckStackSpace() == 0)) { Tcl_AppendToObj(Tcl_GetObjResult(interp), - "too many nested calls to Tcl_EvalObj (infinite loop?)", -1); - result = TCL_ERROR; - goto done; + "too many nested evaluations (infinite loop?)", -1); + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclEvalObjvInternal -- + * + * This procedure evaluates a Tcl command that has already been + * parsed into words, with one Tcl_Obj holding each word. The caller + * is responsible for checking that the interpreter is ready to + * evaluate (by calling TclInterpReady), and also to manage the + * iPtr->numLevels. + * + * Results: + * The return value is a standard Tcl completion code such as + * TCL_OK or TCL_ERROR. A result or error message is left in + * interp's result. If an error occurs, this procedure does + * NOT add any information to the errorInfo variable. + * + * Side effects: + * Depends on the command. + * + *---------------------------------------------------------------------- + */ + +int +TclEvalObjvInternal(interp, objc, objv, command, length, flags) + Tcl_Interp *interp; /* Interpreter in which to evaluate the + * command. Also used for error + * reporting. */ + int objc; /* Number of words in command. */ + Tcl_Obj *CONST objv[]; /* An array of pointers to objects that are + * the words that make up the command. */ + CONST char *command; /* Points to the beginning of the string + * representation of the command; this + * is used for traces. If the string + * representation of the command is + * unknown, an empty string should be + * supplied. If it is NULL, no traces will + * be called. */ + int length; /* Number of bytes in command; if -1, all + * characters up to the first null byte are + * used. */ + int flags; /* Collection of OR-ed bits that control + * the evaluation of the script. Only + * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE are + * currently supported. */ + +{ + Command *cmdPtr; + Interp *iPtr = (Interp *) interp; + Tcl_Obj **newObjv; + int i; + CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr + * in case TCL_EVAL_GLOBAL was set. */ + int code = TCL_OK; + int traceCode = TCL_OK; + int checkTraces = 1; + + if (objc == 0) { + return TCL_OK; } /* - * On the Mac, we will never reach the default recursion limit before - * blowing the stack. So we need to do a check here. + * If any execution traces rename or delete the current command, + * we may need (at most) two passes here. */ + while (1) { - if (TclpCheckStackSpace() == 0) { - /*NOTREACHED*/ - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "too many nested calls to Tcl_EvalObj (infinite loop?)", -1); - result = TCL_ERROR; - goto done; + /* + * Find the procedure to execute this command. If there isn't one, + * then see if there is a command "unknown". If so, create a new + * word array with "unknown" as the first word and the original + * command words as arguments. Then call ourselves recursively + * to execute it. + */ + + savedVarFramePtr = iPtr->varFramePtr; + if (flags & TCL_EVAL_INVOKE) { + iPtr->varFramePtr = NULL; + } + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); + iPtr->varFramePtr = savedVarFramePtr; + + if (cmdPtr == NULL) { + newObjv = (Tcl_Obj **) ckalloc((unsigned) + ((objc + 1) * sizeof (Tcl_Obj *))); + for (i = objc-1; i >= 0; i--) { + newObjv[i+1] = objv[i]; + } + newObjv[0] = Tcl_NewStringObj("::unknown", -1); + Tcl_IncrRefCount(newObjv[0]); + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]); + if (cmdPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "invalid command name \"", Tcl_GetString(objv[0]), "\"", + (char *) NULL); + code = TCL_ERROR; + } else if (TclInterpReady(interp) == TCL_ERROR) { + code = TCL_ERROR; + } else { + iPtr->numLevels++; + code = TclEvalObjvInternal(interp, objc+1, newObjv, command, length, 0); + iPtr->numLevels--; + } + Tcl_DecrRefCount(newObjv[0]); + ckfree((char *) newObjv); + goto done; + } + + /* + * Call trace procedures if needed. + */ + if ((checkTraces) && (command != NULL)) { + int cmdEpoch = cmdPtr->cmdEpoch; + cmdPtr->refCount++; + /* If the first set of traces modifies/deletes the command or + * any existing traces, then the set checkTraces to 0 and + * go through this while loop one more time. + */ + if (iPtr->tracePtr != NULL && traceCode == TCL_OK) { + traceCode = TclCheckInterpTraces(interp, command, length, + cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv); + } + if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) + && (traceCode == TCL_OK)) { + traceCode = TclCheckExecutionTraces(interp, command, length, + cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv); + } + cmdPtr->refCount--; + if (cmdEpoch != cmdPtr->cmdEpoch) { + /* The command has been modified in some way */ + checkTraces = 0; + continue; + } + } + break; } /* - * If the interpreter has been deleted, return an error. + * Finally, invoke the command's Tcl_ObjCmdProc. */ - - if (iPtr->flags & DELETED) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "attempt to call eval in deleted interpreter", -1); - Tcl_SetErrorCode(interp, "CORE", "IDELETE", - "attempt to call eval in deleted interpreter", - (char *) NULL); - result = TCL_ERROR; - goto done; + cmdPtr->refCount++; + iPtr->cmdCount++; + if ( code == TCL_OK && traceCode == TCL_OK) { + savedVarFramePtr = iPtr->varFramePtr; + if (flags & TCL_EVAL_GLOBAL) { + iPtr->varFramePtr = NULL; + } + code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv); + iPtr->varFramePtr = savedVarFramePtr; + } + if (Tcl_AsyncReady()) { + code = Tcl_AsyncInvoke(interp, code); } /* - * Get the ByteCode from the object. If it exists, make sure it hasn't - * been invalidated by, e.g., someone redefining a command with a - * compile procedure (this might make the compiled code wrong). If - * necessary, convert the object to be a ByteCode object and compile it. - * Also, if the code was compiled in/for a different interpreter, - * or for a different namespace, or for the same namespace but - * with different name resolution rules, we recompile it. - * - * Precompiled objects, however, are immutable and therefore - * they are not recompiled, even if the epoch has changed. - * - * To be pedantically correct, we should also check that the - * originating procPtr is the same as the current context procPtr - * (assuming one exists at all - none for global level). This - * code is #def'ed out because [info body] was changed to never - * return a bytecode type object, which should obviate us from - * the extra checks here. + * Call 'leave' command traces */ + if (!(cmdPtr->flags & CMD_IS_DELETED)) { + if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { + traceCode = TclCheckExecutionTraces (interp, command, length, + cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv); + } + if (iPtr->tracePtr != NULL && traceCode == TCL_OK) { + traceCode = TclCheckInterpTraces(interp, command, length, + cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv); + } + } + TclCleanupCommand(cmdPtr); - if (iPtr->varFramePtr != NULL) { - namespacePtr = iPtr->varFramePtr->nsPtr; - } else { - namespacePtr = iPtr->globalNsPtr; + /* + * If one of the trace invocation resulted in error, then + * change the result code accordingly. Note, that the + * interp->result should already be set correctly by the + * call to TraceExecutionProc. + */ + + if (traceCode != TCL_OK) { + code = traceCode; + } + + /* + * If the interpreter has a non-empty string result, the result + * object is either empty or stale because some procedure set + * interp->result directly. If so, move the string result to the + * result object, then reset the string result. + */ + + if (*(iPtr->result) != 0) { + (void) Tcl_GetObjResult(interp); } - if (objPtr->typePtr == &tclByteCodeType) { - codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; - - if (((Interp *) *codePtr->interpHandle != iPtr) - || (codePtr->compileEpoch != iPtr->compileEpoch) -#ifdef CHECK_PROC_ORIGINATION /* [Bug: 3412 Pedantic] */ - || (codePtr->procPtr != NULL && !(iPtr->varFramePtr && - iPtr->varFramePtr->procPtr == codePtr->procPtr)) -#endif - || (codePtr->nsPtr != namespacePtr) - || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) { - if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { - if ((Interp *) *codePtr->interpHandle != iPtr) { - panic("Tcl_EvalObj: compiled script jumped interps"); - } - codePtr->compileEpoch = iPtr->compileEpoch; - } else { - tclByteCodeType.freeIntRepProc(objPtr); - } + done: + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_EvalObjv -- + * + * This procedure evaluates a Tcl command that has already been + * parsed into words, with one Tcl_Obj holding each word. + * + * Results: + * The return value is a standard Tcl completion code such as + * TCL_OK or TCL_ERROR. A result or error message is left in + * interp's result. + * + * Side effects: + * Depends on the command. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_EvalObjv(interp, objc, objv, flags) + Tcl_Interp *interp; /* Interpreter in which to evaluate the + * command. Also used for error + * reporting. */ + int objc; /* Number of words in command. */ + Tcl_Obj *CONST objv[]; /* An array of pointers to objects that are + * the words that make up the command. */ + int flags; /* Collection of OR-ed bits that control + * the evaluation of the script. Only + * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE + * are currently supported. */ +{ + Interp *iPtr = (Interp *)interp; + Trace *tracePtr; + Tcl_DString cmdBuf; + char *cmdString = ""; /* A command string is only necessary for + * command traces or error logs; it will be + * generated to replace this default value if + * necessary. */ + int cmdLen = 0; /* a non-zero value indicates that a command + * string was generated. */ + int code = TCL_OK; + int i; + int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); + + for (tracePtr = iPtr->tracePtr; tracePtr; tracePtr = tracePtr->nextPtr) { + if ((tracePtr->level == 0) || (iPtr->numLevels <= tracePtr->level)) { + /* + * The command may be needed for an execution trace. Generate a + * command string. + */ + + Tcl_DStringInit(&cmdBuf); + for (i = 0; i < objc; i++) { + Tcl_DStringAppendElement(&cmdBuf, Tcl_GetString(objv[i])); + } + cmdString = Tcl_DStringValue(&cmdBuf); + cmdLen = Tcl_DStringLength(&cmdBuf); + break; } } - if (objPtr->typePtr != &tclByteCodeType) { - iPtr->errorLine = 1; - result = tclByteCodeType.setFromAnyProc(interp, objPtr); - if (result != TCL_OK) { - goto done; + + code = TclInterpReady(interp); + if (code == TCL_OK) { + iPtr->numLevels++; + code = TclEvalObjvInternal(interp, objc, objv, cmdString, cmdLen, + flags); + iPtr->numLevels--; + } + + /* + * If we are again at the top level, process any unusual + * return code returned by the evaluated code. + */ + + if (iPtr->numLevels == 0) { + if (code == TCL_RETURN) { + code = TclUpdateReturnInfo(iPtr); } - } else { - codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; - if (((Interp *) *codePtr->interpHandle != iPtr) - || (codePtr->compileEpoch != iPtr->compileEpoch)) { - (*tclByteCodeType.freeIntRepProc)(objPtr); - iPtr->errorLine = 1; - result = (*tclByteCodeType.setFromAnyProc)(interp, objPtr); - if (result != TCL_OK) { - iPtr->numLevels--; - return result; + if ((code != TCL_OK) && (code != TCL_ERROR) + && !allowExceptions) { + ProcessUnexpectedResult(interp, code); + code = TCL_ERROR; + } + } + + if ((code == TCL_ERROR) && !(flags & TCL_EVAL_INVOKE)) { + + /* + * If there was an error, a command string will be needed for the + * error log: generate it now if it was not done previously. + */ + + if (cmdLen == 0) { + Tcl_DStringInit(&cmdBuf); + for (i = 0; i < objc; i++) { + Tcl_DStringAppendElement(&cmdBuf, Tcl_GetString(objv[i])); } + cmdString = Tcl_DStringValue(&cmdBuf); + cmdLen = Tcl_DStringLength(&cmdBuf); } + Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen); + } + + if (cmdLen != 0) { + Tcl_DStringFree(&cmdBuf); + } + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LogCommandInfo -- + * + * This procedure is invoked after an error occurs in an interpreter. + * It adds information to the "errorInfo" variable to describe the + * command that was being executed when the error occurred. + * + * Results: + * None. + * + * Side effects: + * Information about the command is added to errorInfo and the + * line number stored internally in the interpreter is set. If this + * is the first call to this procedure or Tcl_AddObjErrorInfo since + * an error occurred, then old information in errorInfo is + * deleted. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_LogCommandInfo(interp, script, command, length) + Tcl_Interp *interp; /* Interpreter in which to log information. */ + CONST char *script; /* First character in script containing + * command (must be <= command). */ + CONST char *command; /* First character in command that + * generated the error. */ + int length; /* Number of bytes in command (-1 means + * use all bytes up to first null byte). */ +{ + char buffer[200]; + register CONST char *p; + char *ellipsis = ""; + Interp *iPtr = (Interp *) interp; + + if (iPtr->flags & ERR_ALREADY_LOGGED) { + /* + * Someone else has already logged error information for this + * command; we shouldn't add anything more. + */ + + return; } - codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; /* - * Extract then reset the compilation flags in the interpreter. - * Resetting the flags must be done after any compilation. + * Compute the line number where the error occurred. */ - evalFlags = iPtr->evalFlags; - iPtr->evalFlags = 0; + iPtr->errorLine = 1; + for (p = script; p != command; p++) { + if (*p == '\n') { + iPtr->errorLine++; + } + } + + /* + * Create an error message to add to errorInfo, including up to a + * maximum number of characters of the command. + */ + + if (length < 0) { + length = strlen(command); + } + if (length > 150) { + length = 150; + ellipsis = "..."; + } + if (!(iPtr->flags & ERR_IN_PROGRESS)) { + sprintf(buffer, "\n while executing\n\"%.*s%s\"", + length, command, ellipsis); + } else { + sprintf(buffer, "\n invoked from within\n\"%.*s%s\"", + length, command, ellipsis); + } + Tcl_AddObjErrorInfo(interp, buffer, -1); + iPtr->flags &= ~ERR_ALREADY_LOGGED; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_EvalTokensStandard -- + * + * Given an array of tokens parsed from a Tcl command (e.g., the + * tokens that make up a word or the index for an array variable) + * this procedure evaluates the tokens and concatenates their + * values to form a single result value. + * + * Results: + * The return value is a standard Tcl completion code such as + * TCL_OK or TCL_ERROR. A result or error message is left in + * interp's result. + * + * Side effects: + * Depends on the array of tokens being evaled. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_EvalTokensStandard(interp, tokenPtr, count) + Tcl_Interp *interp; /* Interpreter in which to lookup + * variables, execute nested commands, + * and report errors. */ + Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens + * to evaluate and concatenate. */ + int count; /* Number of tokens to consider at tokenPtr. + * Must be at least 1. */ +{ + Tcl_Obj *resultPtr, *indexPtr, *valuePtr; + char buffer[TCL_UTF_MAX]; +#ifdef TCL_MEM_DEBUG +# define MAX_VAR_CHARS 5 +#else +# define MAX_VAR_CHARS 30 +#endif + char nameBuffer[MAX_VAR_CHARS+1]; + char *varName, *index; + CONST char *p = NULL; /* Initialized to avoid compiler warning. */ + int length, code; /* - * Execute the commands. If the code was compiled from an empty string, - * don't bother executing the code. + * The only tricky thing about this procedure is that it attempts to + * avoid object creation and string copying whenever possible. For + * example, if the value is just a nested command, then use the + * command's result object directly. */ - numSrcBytes = codePtr->numSrcBytes; - if ((numSrcBytes > 0) || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { + code = TCL_OK; + resultPtr = NULL; + Tcl_ResetResult(interp); + for ( ; count > 0; count--, tokenPtr++) { + valuePtr = NULL; + /* - * Increment the code's ref count while it is being executed. If - * afterwards no references to it remain, free the code. + * The switch statement below computes the next value to be + * concat to the result, as either a range of text or an + * object. */ - - codePtr->refCount++; - result = TclExecuteByteCode(interp, codePtr); - codePtr->refCount--; - if (codePtr->refCount <= 0) { - TclCleanupByteCode(codePtr); + + switch (tokenPtr->type) { + case TCL_TOKEN_TEXT: + p = tokenPtr->start; + length = tokenPtr->size; + break; + + case TCL_TOKEN_BS: + length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL, + buffer); + p = buffer; + break; + + case TCL_TOKEN_COMMAND: + code = Tcl_EvalEx(interp, tokenPtr->start+1, tokenPtr->size-2, + 0); + if (code != TCL_OK) { + goto done; + } + valuePtr = Tcl_GetObjResult(interp); + break; + + case TCL_TOKEN_VARIABLE: + if (tokenPtr->numComponents == 1) { + indexPtr = NULL; + index = NULL; + } else { + code = Tcl_EvalTokensStandard(interp, tokenPtr+2, + tokenPtr->numComponents - 1); + if (code != TCL_OK) { + goto done; + } + indexPtr = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(indexPtr); + index = Tcl_GetString(indexPtr); + } + + /* + * We have to make a copy of the variable name in order + * to have a null-terminated string. We can't make a + * temporary modification to the script to null-terminate + * the name, because a trace callback might potentially + * reuse the script and be affected by the null character. + */ + + if (tokenPtr[1].size <= MAX_VAR_CHARS) { + varName = nameBuffer; + } else { + varName = ckalloc((unsigned) (tokenPtr[1].size + 1)); + } + strncpy(varName, tokenPtr[1].start, (size_t) tokenPtr[1].size); + varName[tokenPtr[1].size] = 0; + valuePtr = Tcl_GetVar2Ex(interp, varName, index, + TCL_LEAVE_ERR_MSG); + if (varName != nameBuffer) { + ckfree(varName); + } + if (indexPtr != NULL) { + Tcl_DecrRefCount(indexPtr); + } + if (valuePtr == NULL) { + code = TCL_ERROR; + goto done; + } + count -= tokenPtr->numComponents; + tokenPtr += tokenPtr->numComponents; + break; + + default: + panic("unexpected token type in Tcl_EvalTokensStandard"); } + + /* + * If valuePtr isn't NULL, the next piece of text comes from that + * object; otherwise, take length bytes starting at p. + */ + + if (resultPtr == NULL) { + if (valuePtr != NULL) { + resultPtr = valuePtr; + } else { + resultPtr = Tcl_NewStringObj(p, length); + } + Tcl_IncrRefCount(resultPtr); + } else { + if (Tcl_IsShared(resultPtr)) { + Tcl_DecrRefCount(resultPtr); + resultPtr = Tcl_DuplicateObj(resultPtr); + Tcl_IncrRefCount(resultPtr); + } + if (valuePtr != NULL) { + p = Tcl_GetStringFromObj(valuePtr, &length); + } + Tcl_AppendToObj(resultPtr, p, length); + } + } + if (resultPtr != NULL) { + Tcl_SetObjResult(interp, resultPtr); } else { - result = TCL_OK; + code = TCL_ERROR; + } + + done: + if (resultPtr != NULL) { + Tcl_DecrRefCount(resultPtr); } + return code; +} + + +/* + *---------------------------------------------------------------------- + * + * Tcl_EvalTokens -- + * + * Given an array of tokens parsed from a Tcl command (e.g., the + * tokens that make up a word or the index for an array variable) + * this procedure evaluates the tokens and concatenates their + * values to form a single result value. + * + * Results: + * The return value is a pointer to a newly allocated Tcl_Obj + * containing the value of the array of tokens. The reference + * count of the returned object has been incremented. If an error + * occurs in evaluating the tokens then a NULL value is returned + * and an error message is left in interp's result. + * + * Side effects: + * A new object is allocated to hold the result. + * + *---------------------------------------------------------------------- + * + * This uses a non-standard return convention; its use is now deprecated. + * It is a wrapper for the new function Tcl_EvalTokensStandard, and is not + * used in the core any longer. It is only kept for backward compatibility. + */ + +Tcl_Obj * +Tcl_EvalTokens(interp, tokenPtr, count) + Tcl_Interp *interp; /* Interpreter in which to lookup + * variables, execute nested commands, + * and report errors. */ + Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens + * to evaluate and concatenate. */ + int count; /* Number of tokens to consider at tokenPtr. + * Must be at least 1. */ +{ + int code; + Tcl_Obj *resPtr; + + code = Tcl_EvalTokensStandard(interp, tokenPtr, count); + if (code == TCL_OK) { + resPtr = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(resPtr); + Tcl_ResetResult(interp); + return resPtr; + } else { + return NULL; + } +} + + +/* + *---------------------------------------------------------------------- + * + * Tcl_EvalEx -- + * + * This procedure evaluates a Tcl script without using the compiler + * or byte-code interpreter. It just parses the script, creates + * values for each word of each command, then calls EvalObjv + * to execute each command. + * + * Results: + * The return value is a standard Tcl completion code such as + * TCL_OK or TCL_ERROR. A result or error message is left in + * interp's result. + * + * Side effects: + * Depends on the script. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_EvalEx(interp, script, numBytes, flags) + Tcl_Interp *interp; /* Interpreter in which to evaluate the + * script. Also used for error reporting. */ + CONST char *script; /* First character of script to evaluate. */ + int numBytes; /* Number of bytes in script. If < 0, the + * script consists of all bytes up to the + * first null character. */ + int flags; /* Collection of OR-ed bits that control + * the evaluation of the script. Only + * TCL_EVAL_GLOBAL is currently + * supported. */ +{ + Interp *iPtr = (Interp *) interp; + CONST char *p, *next; + Tcl_Parse parse; +#define NUM_STATIC_OBJS 20 + Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv; + Tcl_Token *tokenPtr; + int i, code, commandLength, bytesLeft, nested; + CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr + * in case TCL_EVAL_GLOBAL was set. */ + int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); + + /* For nested scripts, this variable will be set to point to the first + * char after the end of the script - needed only to compare pointers, + * nothing will be read nor written there. + */ + + CONST char *onePast = NULL; /* - * If no commands at all were executed, check for asynchronous - * handlers so that they at least get one change to execute. - * This is needed to handle event loops written in Tcl with - * empty bodies. + * The variables below keep track of how much state has been + * allocated while evaluating the script, so that it can be freed + * properly if an error occurs. */ - if ((oldCount == iPtr->cmdCount) && Tcl_AsyncReady()) { - result = Tcl_AsyncInvoke(interp, result); + int gotParse = 0, objectsUsed = 0; + + if (numBytes < 0) { + numBytes = strlen(script); + } + Tcl_ResetResult(interp); + + savedVarFramePtr = iPtr->varFramePtr; + if (flags & TCL_EVAL_GLOBAL) { + iPtr->varFramePtr = NULL; } /* - * Update the interpreter's evaluation level count. If we are again at - * the top level, process any unusual return code returned by the - * evaluated code. + * Each iteration through the following loop parses the next + * command from the script and then executes it. */ - if (iPtr->numLevels == 1) { - if (result == TCL_RETURN) { - result = TclUpdateReturnInfo(iPtr); + objv = staticObjArray; + p = script; + bytesLeft = numBytes; + if (iPtr->evalFlags & TCL_BRACKET_TERM) { + nested = 1; + onePast = script + numBytes; + } else { + nested = 0; + } + iPtr->evalFlags = 0; + do { + if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse) + != TCL_OK) { + code = TCL_ERROR; + goto error; } - if ((result != TCL_OK) && (result != TCL_ERROR) - && ((evalFlags & TCL_ALLOW_EXCEPTIONS) == 0)) { - ProcessUnexpectedResult(interp, result); - result = TCL_ERROR; + gotParse = 1; + + /* + * A nested script can only terminate in ']'. If the script is not + * nested, onePast is NULL and the second test is not performed. + */ + + next = parse.commandStart + parse.commandSize; + if ((next == onePast) && (onePast[-1] != ']')) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("missing close-bracket", -1)); + code = TCL_ERROR; + goto error; } - } + if (parse.numWords > 0) { + /* + * Generate an array of objects for the words of the command. + */ + + if (parse.numWords <= NUM_STATIC_OBJS) { + objv = staticObjArray; + } else { + objv = (Tcl_Obj **) ckalloc((unsigned) + (parse.numWords * sizeof (Tcl_Obj *))); + } + for (objectsUsed = 0, tokenPtr = parse.tokenPtr; + objectsUsed < parse.numWords; + objectsUsed++, tokenPtr += (tokenPtr->numComponents + 1)) { + code = Tcl_EvalTokensStandard(interp, tokenPtr+1, + tokenPtr->numComponents); + if (code == TCL_OK) { + objv[objectsUsed] = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(objv[objectsUsed]); + } else { + goto error; + } + } + + /* + * Execute the command and free the objects for its words. + */ + + if (TclInterpReady(interp) == TCL_ERROR) { + code = TCL_ERROR; + } else { + iPtr->numLevels++; + code = TclEvalObjvInternal(interp, objectsUsed, objv, p, + parse.commandStart + parse.commandSize - p, 0); + iPtr->numLevels--; + } + if (code != TCL_OK) { + if (iPtr->numLevels == 0) { + if (code == TCL_RETURN) { + code = TclUpdateReturnInfo(iPtr); + } + if ((code != TCL_OK) && (code != TCL_ERROR) + && !allowExceptions) { + ProcessUnexpectedResult(interp, code); + code = TCL_ERROR; + } + } + goto error; + } + for (i = 0; i < objectsUsed; i++) { + Tcl_DecrRefCount(objv[i]); + } + objectsUsed = 0; + if (objv != staticObjArray) { + ckfree((char *) objv); + objv = staticObjArray; + } + } + + /* + * Advance to the next command in the script. + */ + + bytesLeft -= next - p; + p = next; + Tcl_FreeParse(&parse); + gotParse = 0; + if ((nested != 0) && (p > script) && (p[-1] == ']')) { + /* + * We get here in the special case where the TCL_BRACKET_TERM + * flag was set in the interpreter and we reached a close + * bracket in the script. Return immediately. + */ + + iPtr->termOffset = (p - 1) - script; + iPtr->varFramePtr = savedVarFramePtr; + return TCL_OK; + } + } while (bytesLeft > 0); + iPtr->termOffset = p - script; + iPtr->varFramePtr = savedVarFramePtr; + return TCL_OK; + + error: /* - * If an error occurred, record information about what was being - * executed when the error occurred. + * Generate various pieces of error information, such as the line + * number where the error occurred and information to add to the + * errorInfo variable. Then free resources that had been allocated + * to the command. */ - if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { - RecordTracebackInfo(interp, objPtr, numSrcBytes); + if ((code == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { + commandLength = parse.commandSize; + if ((parse.commandStart + commandLength) != (script + numBytes)) { + /* + * The command where the error occurred didn't end at the end + * of the script (i.e. it ended at a terminator character such + * as ";". Reduce the length by one so that the error message + * doesn't include the terminator character. + */ + + commandLength -= 1; + } + Tcl_LogCommandInfo(interp, script, parse.commandStart, commandLength); + } + + for (i = 0; i < objectsUsed; i++) { + Tcl_DecrRefCount(objv[i]); } + if (gotParse) { + next = parse.commandStart + parse.commandSize; + bytesLeft -= next - p; + p = next; + Tcl_FreeParse(&parse); + + if ((nested != 0) && (p > script)) { + CONST char *nextCmd = NULL; /* pointer to start of next command */ + + /* + * We get here in the special case where the TCL_BRACKET_TERM + * flag was set in the interpreter. + * + * At this point, we want to find the end of the script + * (either end of script or the closing ']'). + */ + + while ((p[-1] != ']') && bytesLeft) { + if (Tcl_ParseCommand(NULL, p, bytesLeft, nested, &parse) + != TCL_OK) { + /* + * We were looking for the ']' to close the script. + * But if we find a syntax error, it is ok to quit + * early since in that case we no longer need to know + * where the ']' is (if there was one). We reset the + * pointer to the start of the command that after the + * one causing the return. -- hobbs + */ + + p = (nextCmd == NULL) ? parse.commandStart : nextCmd; + break; + } + + if (nextCmd == NULL) { + nextCmd = parse.commandStart; + } + + /* + * Advance to the next command in the script. + */ + + next = parse.commandStart + parse.commandSize; + bytesLeft -= next - p; + p = next; + Tcl_FreeParse(&parse); + } + iPtr->termOffset = (p - 1) - script; + } else { + iPtr->termOffset = p - script; + } + } + if (objv != staticObjArray) { + ckfree((char *) objv); + } + iPtr->varFramePtr = savedVarFramePtr; + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Eval -- + * + * Execute a Tcl command in a string. This procedure executes the + * script directly, rather than compiling it to bytecodes. Before + * the arrival of the bytecode compiler in Tcl 8.0 Tcl_Eval was + * the main procedure used for executing Tcl commands, but nowadays + * it isn't used much. + * + * Results: + * The return value is one of the return codes defined in tcl.h + * (such as TCL_OK), and interp's result contains a value + * to supplement the return code. The value of the result + * will persist only until the next call to Tcl_Eval or Tcl_EvalObj: + * you must copy it or lose it! + * + * Side effects: + * Can be almost arbitrary, depending on the commands in the script. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Eval(interp, string) + Tcl_Interp *interp; /* Token for command interpreter (returned + * by previous call to Tcl_CreateInterp). */ + CONST char *string; /* Pointer to TCL command to execute. */ +{ + int code = Tcl_EvalEx(interp, string, -1, 0); /* - * Set the interpreter's termOffset member to the offset of the - * character just after the last one executed. We approximate the offset - * of the last character executed by using the number of characters - * compiled. + * For backwards compatibility with old C code that predates the + * object system in Tcl 8.0, we have to mirror the object result + * back into the string result (some callers may expect it there). */ - iPtr->termOffset = numSrcBytes; - iPtr->flags &= ~ERR_ALREADY_LOGGED; + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), + TCL_VOLATILE); + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_EvalObj, Tcl_GlobalEvalObj -- + * + * These functions are deprecated but we keep them around for backwards + * compatibility reasons. + * + * Results: + * See the functions they call. + * + * Side effects: + * See the functions they call. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_EvalObj +int +Tcl_EvalObj(interp, objPtr) + Tcl_Interp * interp; + Tcl_Obj * objPtr; +{ + return Tcl_EvalObjEx(interp, objPtr, 0); +} + +#undef Tcl_GlobalEvalObj +int +Tcl_GlobalEvalObj(interp, objPtr) + Tcl_Interp * interp; + Tcl_Obj * objPtr; +{ + return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_EvalObjEx -- + * + * Execute Tcl commands stored in a Tcl object. These commands are + * compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT + * is specified. + * + * Results: + * The return value is one of the return codes defined in tcl.h + * (such as TCL_OK), and the interpreter's result contains a value + * to supplement the return code. + * + * Side effects: + * The object is converted, if necessary, to a ByteCode object that + * holds the bytecode instructions for the commands. Executing the + * commands will almost certainly have side effects that depend + * on those commands. + * + * Just as in Tcl_Eval, interp->termOffset is set to the offset of the + * last character executed in the objPtr's string. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_EvalObjEx(interp, objPtr, flags) + Tcl_Interp *interp; /* Token for command interpreter + * (returned by a previous call to + * Tcl_CreateInterp). */ + register Tcl_Obj *objPtr; /* Pointer to object containing + * commands to execute. */ + int flags; /* Collection of OR-ed bits that + * control the evaluation of the + * script. Supported values are + * TCL_EVAL_GLOBAL and + * TCL_EVAL_DIRECT. */ +{ + register Interp *iPtr = (Interp *) interp; + char *script; + int numSrcBytes; + int result; + CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr + * in case TCL_EVAL_GLOBAL was set. */ + int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); + + Tcl_IncrRefCount(objPtr); + + if ((iPtr->flags & USE_EVAL_DIRECT) || (flags & TCL_EVAL_DIRECT)) { + /* + * We're not supposed to use the compiler or byte-code interpreter. + * Let Tcl_EvalEx evaluate the command directly (and probably + * more slowly). + * + * Pure List Optimization (no string representation). In this + * case, we can safely use Tcl_EvalObjv instead and get an + * appreciable improvement in execution speed. This is because it + * allows us to avoid a setFromAny step that would just pack + * everything into a string and back out again. + * + * USE_EVAL_DIRECT is a special flag used for testing purpose only + * (ensure we go into the TCL_EVAL_DIRECT path, avoiding opt) + */ + if (!(iPtr->flags & USE_EVAL_DIRECT) && + (objPtr->typePtr == &tclListType) && /* is a list... */ + (objPtr->bytes == NULL) /* ...without a string rep */) { + register List *listRepPtr = + (List *) objPtr->internalRep.twoPtrValue.ptr1; + result = Tcl_EvalObjv(interp, listRepPtr->elemCount, + listRepPtr->elements, flags); + } else { + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + result = Tcl_EvalEx(interp, script, numSrcBytes, flags); + } + } else { + /* + * Let the compiler/engine subsystem do the evaluation. + */ + + savedVarFramePtr = iPtr->varFramePtr; + if (flags & TCL_EVAL_GLOBAL) { + iPtr->varFramePtr = NULL; + } + + result = TclCompEvalObj(interp, objPtr); + + /* + * If we are again at the top level, process any unusual + * return code returned by the evaluated code. + */ + + if (iPtr->numLevels == 0) { + if (result == TCL_RETURN) { + result = TclUpdateReturnInfo(iPtr); + } + if ((result != TCL_OK) && (result != TCL_ERROR) + && !allowExceptions) { + ProcessUnexpectedResult(interp, result); + result = TCL_ERROR; + + /* + * If an error was created here, record information about + * what was being executed when the error occurred. + */ + + if (!(iPtr->flags & ERR_ALREADY_LOGGED)) { + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + Tcl_LogCommandInfo(interp, script, script, numSrcBytes); + iPtr->flags &= ~ERR_ALREADY_LOGGED; + } + } + } + iPtr->evalFlags = 0; + iPtr->varFramePtr = savedVarFramePtr; + } - done: TclDecrRefCount(objPtr); - iPtr->varFramePtr = savedVarFramePtr; - iPtr->numLevels--; return result; } @@ -2835,61 +4019,6 @@ ProcessUnexpectedResult(interp, returnCode) } /* - *---------------------------------------------------------------------- - * - * RecordTracebackInfo -- - * - * Procedure called by Tcl_EvalObj to record information about what was - * being executed when the error occurred. - * - * Results: - * None. - * - * Side effects: - * Appends information about the script being evaluated to the - * interpreter's "errorInfo" variable. - * - *---------------------------------------------------------------------- - */ - -static void -RecordTracebackInfo(interp, objPtr, numSrcBytes) - Tcl_Interp *interp; /* The interpreter in which the error - * occurred. */ - Tcl_Obj *objPtr; /* Points to object containing script whose - * evaluation resulted in an error. */ - int numSrcBytes; /* Number of bytes compiled in script. */ -{ - Interp *iPtr = (Interp *) interp; - char buf[200]; - char *ellipsis, *bytes; - int length; - - /* - * Decide how much of the command to print in the error message - * (up to a certain number of bytes). - */ - - bytes = Tcl_GetStringFromObj(objPtr, &length); - length = TclMin(numSrcBytes, length); - - ellipsis = ""; - if (length > 150) { - length = 150; - ellipsis = " ..."; - } - - if (!(iPtr->flags & ERR_IN_PROGRESS)) { - sprintf(buf, "\n while executing\n\"%.*s%s\"", - length, bytes, ellipsis); - } else { - sprintf(buf, "\n invoked from within\n\"%.*s%s\"", - length, bytes, ellipsis); - } - Tcl_AddObjErrorInfo(interp, buf, -1); -} - -/* *--------------------------------------------------------------------------- * * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean -- @@ -2914,7 +4043,7 @@ int Tcl_ExprLong(interp, string, ptr) Tcl_Interp *interp; /* Context in which to evaluate the * expression. */ - char *string; /* Expression to evaluate. */ + CONST char *string; /* Expression to evaluate. */ long *ptr; /* Where to store result. */ { register Tcl_Obj *exprPtr; @@ -2965,7 +4094,7 @@ int Tcl_ExprDouble(interp, string, ptr) Tcl_Interp *interp; /* Context in which to evaluate the * expression. */ - char *string; /* Expression to evaluate. */ + CONST char *string; /* Expression to evaluate. */ double *ptr; /* Where to store result. */ { register Tcl_Obj *exprPtr; @@ -3016,7 +4145,7 @@ int Tcl_ExprBoolean(interp, string, ptr) Tcl_Interp *interp; /* Context in which to evaluate the * expression. */ - char *string; /* Expression to evaluate. */ + CONST char *string; /* Expression to evaluate. */ int *ptr; /* Where to store 0/1 result. */ { register Tcl_Obj *exprPtr; @@ -3185,7 +4314,7 @@ int TclInvoke(interp, argc, argv, flags) Tcl_Interp *interp; /* Where to invoke the command. */ int argc; /* Count of args. */ - register char **argv; /* The arg strings; argv[0] is the name of + register CONST char **argv; /* The arg strings; argv[0] is the name of * the command to invoke. */ int flags; /* Combination of flags controlling the * call: TCL_INVOKE_HIDDEN and @@ -3282,7 +4411,7 @@ int TclGlobalInvoke(interp, argc, argv, flags) Tcl_Interp *interp; /* Where to invoke the command. */ int argc; /* Count of args. */ - register char **argv; /* The arg strings; argv[0] is the name of + register CONST char **argv; /* The arg strings; argv[0] is the name of * the command to invoke. */ int flags; /* Combination of flags controlling the * call: TCL_INVOKE_HIDDEN and @@ -3537,7 +4666,7 @@ int Tcl_ExprString(interp, string) Tcl_Interp *interp; /* Context in which to evaluate the * expression. */ - char *string; /* Expression to evaluate. */ + CONST char *string; /* Expression to evaluate. */ { register Tcl_Obj *exprPtr; Tcl_Obj *resultPtr; @@ -3593,214 +4722,112 @@ Tcl_ExprString(interp, string) } /* - *-------------------------------------------------------------- + *---------------------------------------------------------------------- * - * Tcl_ExprObj -- + * Tcl_CreateObjTrace -- * - * Evaluate an expression in a Tcl_Obj. + * Arrange for a procedure to be called to trace command execution. * * Results: - * A standard Tcl object result. If the result is other than TCL_OK, - * then the interpreter's result contains an error message. If the - * result is TCL_OK, then a pointer to the expression's result value - * object is stored in resultPtrPtr. In that case, the object's ref - * count is incremented to reflect the reference returned to the - * caller; the caller is then responsible for the resulting object - * and must, for example, decrement the ref count when it is finished - * with the object. + * The return value is a token for the trace, which may be passed + * to Tcl_DeleteTrace to eliminate the trace. * * Side effects: - * Any side effects caused by subcommands in the expression, if any. - * The interpreter result is not modified unless there is an error. + * From now on, proc will be called just before a command procedure + * is called to execute a Tcl command. Calls to proc will have the + * following form: * - *-------------------------------------------------------------- + * void proc( ClientData clientData, + * Tcl_Interp* interp, + * int level, + * CONST char* command, + * Tcl_Command commandInfo, + * int objc, + * Tcl_Obj *CONST objv[] ); + * + * The 'clientData' and 'interp' arguments to 'proc' will be the + * same as the arguments to Tcl_CreateObjTrace. The 'level' + * argument gives the nesting depth of command interpretation within + * the interpreter. The 'command' argument is the ASCII text of + * the command being evaluated -- before any substitutions are + * performed. The 'commandInfo' argument gives a handle to the + * command procedure that will be evaluated. The 'objc' and 'objv' + * parameters give the parameter vector that will be passed to the + * command procedure. proc does not return a value. + * + * It is permissible for 'proc' to call Tcl_SetCommandTokenInfo + * to change the command procedure or client data for the command + * being evaluated, and these changes will take effect with the + * current evaluation. + * + * The 'level' argument specifies the maximum nesting level of calls + * to be traced. If the execution depth of the interpreter exceeds + * 'level', the trace callback is not executed. + * + * The 'flags' argument is either zero or the value, + * TCL_ALLOW_INLINE_COMPILATION. If the TCL_ALLOW_INLINE_COMPILATION + * flag is not present, the bytecode compiler will not generate inline + * code for Tcl's built-in commands. This behavior will have a significant + * impact on performance, but will ensure that all command evaluations are + * traced. If the TCL_ALLOW_INLINE_COMPILATION flag is present, the + * bytecode compiler will have its normal behavior of compiling in-line + * code for some of Tcl's built-in commands. In this case, the tracing + * will be imprecise -- in-line code will not be traced -- but run-time + * performance will be improved. The latter behavior is desired for + * many applications such as profiling of run time. + * + * When the trace is deleted, the 'delProc' procedure will be invoked, + * passing it the original client data. + * + *---------------------------------------------------------------------- */ -int -Tcl_ExprObj(interp, objPtr, resultPtrPtr) - Tcl_Interp *interp; /* Context in which to evaluate the - * expression. */ - register 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. */ +Tcl_Trace +Tcl_CreateObjTrace( interp, level, flags, proc, clientData, delProc ) + Tcl_Interp* interp; /* Tcl interpreter */ + int level; /* Maximum nesting level */ + int flags; /* Flags, see above */ + Tcl_CmdObjTraceProc* proc; /* Trace callback */ + ClientData clientData; /* Client data for the callback */ + Tcl_CmdObjTraceDeleteProc* delProc; + /* Procedure to call when trace is deleted */ { - Interp *iPtr = (Interp *) interp; - CompileEnv compEnv; /* Compilation environment structure - * allocated in frame. */ - LiteralTable *localTablePtr = &(compEnv.localLitTable); - register ByteCode *codePtr = NULL; - /* Tcl Internal type of bytecode. - * Initialized to avoid compiler warning. */ - AuxData *auxDataPtr; - LiteralEntry *entryPtr; - Tcl_Obj *saveObjPtr; - char *string; - int length, i, result; - - /* - * First handle some common expressions specially. - */ - - string = Tcl_GetStringFromObj(objPtr, &length); - if (length == 1) { - if (*string == '0') { - *resultPtrPtr = Tcl_NewLongObj(0); - Tcl_IncrRefCount(*resultPtrPtr); - return TCL_OK; - } else if (*string == '1') { - *resultPtrPtr = Tcl_NewLongObj(1); - Tcl_IncrRefCount(*resultPtrPtr); - return TCL_OK; - } - } else if ((length == 2) && (*string == '!')) { - if (*(string+1) == '0') { - *resultPtrPtr = Tcl_NewLongObj(1); - Tcl_IncrRefCount(*resultPtrPtr); - return TCL_OK; - } else if (*(string+1) == '1') { - *resultPtrPtr = Tcl_NewLongObj(0); - Tcl_IncrRefCount(*resultPtrPtr); - return TCL_OK; - } - } + register Trace *tracePtr; + register Interp *iPtr = (Interp *) interp; - /* - * Get the ByteCode from the object. If it exists, make sure it hasn't - * been invalidated by, e.g., someone redefining a command with a - * compile procedure (this might make the compiled code wrong). If - * necessary, convert the object to be a ByteCode object and compile it. - * Also, if the code was compiled in/for a different interpreter, we - * recompile it. - * - * Precompiled expressions, however, are immutable and therefore - * they are not recompiled, even if the epoch has changed. - * - */ + /* Test if this trace allows inline compilation of commands */ - if (objPtr->typePtr == &tclByteCodeType) { - codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; - if (((Interp *) *codePtr->interpHandle != iPtr) - || (codePtr->compileEpoch != iPtr->compileEpoch)) { - if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { - if ((Interp *) *codePtr->interpHandle != iPtr) { - panic("Tcl_ExprObj: compiled expression jumped interps"); - } - codePtr->compileEpoch = iPtr->compileEpoch; - } else { - (*tclByteCodeType.freeIntRepProc)(objPtr); - objPtr->typePtr = (Tcl_ObjType *) NULL; - } - } - } - if (objPtr->typePtr != &tclByteCodeType) { - TclInitCompileEnv(interp, &compEnv, string, length); - result = TclCompileExpr(interp, string, length, &compEnv); + if ( ! ( flags & TCL_ALLOW_INLINE_COMPILATION ) ) { - /* - * Free the compilation environment's literal table bucket array if - * it was dynamically allocated. - */ + if ( iPtr->tracesForbiddingInline == 0 ) { - if (localTablePtr->buckets != localTablePtr->staticBuckets) { - ckfree((char *) localTablePtr->buckets); - } - - if (result != TCL_OK) { /* - * Compilation errors. Free storage allocated for compilation. + * When the first trace forbidding inline compilation is + * created, invalidate existing compiled code for this + * interpreter and arrange (by setting the + * DONT_COMPILE_CMDS_INLINE flag) that when compiling new + * code, no commands will be compiled inline (i.e., into + * an inline sequence of instructions). We do this because + * commands that were compiled inline will never result in + * a command trace being called. */ -#ifdef TCL_COMPILE_DEBUG - TclVerifyLocalLiteralTable(&compEnv); -#endif /*TCL_COMPILE_DEBUG*/ - entryPtr = compEnv.literalArrayPtr; - for (i = 0; i < compEnv.literalArrayNext; i++) { - TclReleaseLiteral(interp, entryPtr->objPtr); - entryPtr++; - } -#ifdef TCL_COMPILE_DEBUG - TclVerifyGlobalLiteralTable(iPtr); -#endif /*TCL_COMPILE_DEBUG*/ - - auxDataPtr = compEnv.auxDataArrayPtr; - for (i = 0; i < compEnv.auxDataArrayNext; i++) { - if (auxDataPtr->type->freeProc != NULL) { - auxDataPtr->type->freeProc(auxDataPtr->clientData); - } - auxDataPtr++; - } - TclFreeCompileEnv(&compEnv); - return result; - } - - /* - * Successful compilation. If the expression yielded no - * instructions, push an zero object as the expression's result. - */ - - if (compEnv.codeNext == compEnv.codeStart) { - TclEmitPush(TclRegisterLiteral(&compEnv, "0", 1, /*onHeap*/ 0), - &compEnv); - } - - /* - * Add a "done" instruction as the last instruction and change the - * object into a ByteCode object. Ownership of the literal objects - * and aux data items is given to the ByteCode object. - */ - - compEnv.numSrcBytes = iPtr->termOffset; - TclEmitOpcode(INST_DONE, &compEnv); - TclInitByteCodeObj(objPtr, &compEnv); - TclFreeCompileEnv(&compEnv); - codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; -#ifdef TCL_COMPILE_DEBUG - if (tclTraceCompile == 2) { - TclPrintByteCodeObj(interp, objPtr); + iPtr->compileEpoch++; + iPtr->flags |= DONT_COMPILE_CMDS_INLINE; } -#endif /* TCL_COMPILE_DEBUG */ + ++ iPtr->tracesForbiddingInline; } - - /* - * Execute the expression after first saving the interpreter's result. - */ - saveObjPtr = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(saveObjPtr); - Tcl_ResetResult(interp); + tracePtr = (Trace *) ckalloc(sizeof(Trace)); + tracePtr->level = level; + tracePtr->proc = proc; + tracePtr->clientData = clientData; + tracePtr->delProc = delProc; + tracePtr->nextPtr = iPtr->tracePtr; + tracePtr->flags = flags; + iPtr->tracePtr = tracePtr; - /* - * Increment the code's ref count while it is being executed. If - * afterwards no references to it remain, free the code. - */ - - codePtr->refCount++; - result = TclExecuteByteCode(interp, codePtr); - codePtr->refCount--; - if (codePtr->refCount <= 0) { - TclCleanupByteCode(codePtr); - objPtr->typePtr = NULL; - objPtr->internalRep.otherValuePtr = NULL; - } - - /* - * If the expression evaluated successfully, store a pointer to its - * value object in resultPtrPtr then restore the old interpreter result. - * We increment the object's ref count to reflect the reference that we - * are returning to the caller. We also decrement the ref count of the - * interpreter's result object after calling Tcl_SetResult since we - * next store into that field directly. - */ - - if (result == TCL_OK) { - *resultPtrPtr = iPtr->objResultPtr; - Tcl_IncrRefCount(iPtr->objResultPtr); - - Tcl_SetObjResult(interp, saveObjPtr); - } - Tcl_DecrRefCount(saveObjPtr); - return result; + return (Tcl_Trace) tracePtr; } /* @@ -3855,28 +4882,95 @@ Tcl_CreateTrace(interp, level, proc, clientData) * command. */ ClientData clientData; /* Arbitrary value word to pass to proc. */ { - register Trace *tracePtr; - register Interp *iPtr = (Interp *) interp; + StringTraceData* data; + data = (StringTraceData*) ckalloc( sizeof( *data )); + data->clientData = clientData; + data->proc = proc; + return Tcl_CreateObjTrace( interp, level, 0, StringTraceProc, + (ClientData) data, StringTraceDeleteProc ); +} + +/* + *---------------------------------------------------------------------- + * + * StringTraceProc -- + * + * Invoke a string-based trace procedure from an object-based + * callback. + * + * Results: + * None. + * + * Side effects: + * Whatever the string-based trace procedure does. + * + *---------------------------------------------------------------------- + */ + +static int +StringTraceProc( clientData, interp, level, command, commandInfo, objc, objv ) + ClientData clientData; + Tcl_Interp* interp; + int level; + CONST char* command; + Tcl_Command commandInfo; + int 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; /* - * Invalidate existing compiled code for this interpreter and arrange - * (by setting the DONT_COMPILE_CMDS_INLINE flag) that when compiling - * new code, no commands will be compiled inline (i.e., into an inline - * sequence of instructions). We do this because commands that were - * compiled inline will never result in a command trace being called. + * This is a bit messy because we have to emulate the old trace + * interface, which uses strings for everything. */ + + argv = (CONST char **) ckalloc((unsigned) ( (objc + 1) + * sizeof(CONST char *) )); + for (i = 0; i < objc; i++) { + argv[i] = Tcl_GetString(objv[i]); + } + argv[objc] = 0; - iPtr->compileEpoch++; - iPtr->flags |= DONT_COMPILE_CMDS_INLINE; + /* + * Invoke the command procedure. Note that we cast away const-ness + * on two parameters for compatibility with legacy code; the code + * MUST NOT modify either command or argv. + */ + + ( data->proc )( data->clientData, interp, level, + (char*) command, cmdPtr->proc, cmdPtr->clientData, + objc, argv ); + ckfree( (char*) argv ); - tracePtr = (Trace *) ckalloc(sizeof(Trace)); - tracePtr->level = level; - tracePtr->proc = proc; - tracePtr->clientData = clientData; - tracePtr->nextPtr = iPtr->tracePtr; - iPtr->tracePtr = tracePtr; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * StringTraceDeleteProc -- + * + * Clean up memory when a string-based trace is deleted. + * + * Results: + * None. + * + * Side effects: + * Allocated memory is returned to the system. + * + *---------------------------------------------------------------------- + */ - return (Tcl_Trace) tracePtr; +static void +StringTraceDeleteProc( clientData ) + ClientData clientData; +{ + ckfree( (char*) clientData ); } /* @@ -3902,31 +4996,49 @@ Tcl_DeleteTrace(interp, trace) Tcl_Trace trace; /* Token for trace (returned previously by * Tcl_CreateTrace). */ { - register Interp *iPtr = (Interp *) interp; - register Trace *tracePtr = (Trace *) trace; - register Trace *tracePtr2; + Interp *iPtr = (Interp *) interp; + Trace *tracePtr = (Trace *) trace; + register Trace **tracePtr2 = &( iPtr->tracePtr ); - if (iPtr->tracePtr == tracePtr) { - iPtr->tracePtr = tracePtr->nextPtr; - ckfree((char *) tracePtr); - } else { - for (tracePtr2 = iPtr->tracePtr; tracePtr2 != NULL; - tracePtr2 = tracePtr2->nextPtr) { - if (tracePtr2->nextPtr == tracePtr) { - tracePtr2->nextPtr = tracePtr->nextPtr; - ckfree((char *) tracePtr); - break; - } + /* + * Locate the trace entry in the interpreter's trace list, + * and remove it from the list. + */ + + while ( (*tracePtr2) != NULL && (*tracePtr2) != tracePtr ) { + tracePtr2 = &((*tracePtr2)->nextPtr); + } + if ( *tracePtr2 == NULL ) { + return; + } + (*tracePtr2) = (*tracePtr2)->nextPtr; + + /* + * If the trace forbids bytecode compilation, change the interpreter's + * state. If bytecode compilation is now permitted, flag the fact and + * advance the compilation epoch so that procs will be recompiled to + * take advantage of it. + */ + + if ( ! (tracePtr->flags & TCL_ALLOW_INLINE_COMPILATION ) ) { + -- iPtr->tracesForbiddingInline; + if ( iPtr->tracesForbiddingInline == 0 ) { + iPtr->flags &= ~DONT_COMPILE_CMDS_INLINE; + ++ iPtr->compileEpoch; } } - if (iPtr->tracePtr == NULL) { - /* - * When compiling new code, allow commands to be compiled inline. - */ + /* + * Execute any delete callback. + */ - iPtr->flags &= ~DONT_COMPILE_CMDS_INLINE; + if ( tracePtr->delProc != NULL ) { + ( tracePtr->delProc )( tracePtr->clientData ); } + + /* Delete the trace object */ + + Tcl_EventuallyFree( (char*) tracePtr, TCL_DYNAMIC); } /* @@ -4004,11 +5116,11 @@ Tcl_AddObjErrorInfo(interp, message, length) iPtr->flags |= ERR_IN_PROGRESS; if (iPtr->result[0] == 0) { - (void) Tcl_SetVar2Ex(interp, "errorInfo", NULL, iPtr->objResultPtr, - TCL_GLOBAL_ONLY); + Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL, + iPtr->objResultPtr, TCL_GLOBAL_ONLY); } else { /* use the string result */ - Tcl_SetVar2(interp, "errorInfo", (char *) NULL, interp->result, - TCL_GLOBAL_ONLY); + Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL, + Tcl_NewStringObj(interp->result, -1), TCL_GLOBAL_ONLY); } /* @@ -4017,8 +5129,8 @@ Tcl_AddObjErrorInfo(interp, message, length) */ if (!(iPtr->flags & ERROR_CODE_SET)) { - (void) Tcl_SetVar2(interp, "errorCode", (char *) NULL, "NONE", - TCL_GLOBAL_ONLY); + Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorCode, NULL, + Tcl_NewStringObj("NONE", -1), TCL_GLOBAL_ONLY); } } @@ -4029,8 +5141,8 @@ Tcl_AddObjErrorInfo(interp, message, length) if (length != 0) { messagePtr = Tcl_NewStringObj(message, length); Tcl_IncrRefCount(messagePtr); - Tcl_SetVar2Ex(interp, "errorInfo", NULL, messagePtr, - (TCL_GLOBAL_ONLY | TCL_APPEND_VALUE)); + Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL, + messagePtr, (TCL_GLOBAL_ONLY | TCL_APPEND_VALUE)); Tcl_DecrRefCount(messagePtr); /* free msg object appended above */ } } @@ -4138,7 +5250,7 @@ Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1) int Tcl_GlobalEval(interp, command) Tcl_Interp *interp; /* Interpreter in which to evaluate command. */ - char *command; /* Command to evaluate. */ + CONST char *command; /* Command to evaluate. */ { register Interp *iPtr = (Interp *) interp; int result; @@ -4232,7 +5344,8 @@ Tcl_AllowExceptions(interp) *---------------------------------------------------------------------- */ -void Tcl_GetVersion(majorV, minorV, patchLevelV, type) +void +Tcl_GetVersion(majorV, minorV, patchLevelV, type) int *majorV; int *minorV; int *patchLevelV; @@ -4252,4 +5365,3 @@ void Tcl_GetVersion(majorV, minorV, patchLevelV, type) } } - diff --git a/tcl/generic/tclBinary.c b/tcl/generic/tclBinary.c index 199109637a5..6065d018d5a 100644 --- a/tcl/generic/tclBinary.c +++ b/tcl/generic/tclBinary.c @@ -13,9 +13,9 @@ * RCS: @(#) $Id$ */ -#include <math.h> #include "tclInt.h" #include "tclPort.h" +#include <math.h> /* * The following constants are used by GetFormatSpec to indicate various @@ -26,6 +26,26 @@ #define BINARY_NOCOUNT -2 /* No count was specified in format. */ /* + * The following defines the maximum number of different (integer) + * numbers placed in the object cache by 'binary scan' before it bails + * out and switches back to Plan A (creating a new object for each + * value.) Theoretically, it would be possible to keep the cache + * about for the values that are already in it, but that makes the + * code slower in practise when overflow happens, and makes little + * odds the rest of the time (as measured on my machine.) It is also + * slower (on the sample I tried at least) to grow the cache to hold + * all items we might want to put in it; presumably the extra cost of + * managing the memory for the enlarged table outweighs the benefit + * from allocating fewer objects. This is probably because as the + * number of objects increases, the likelihood of reuse of any + * particular one drops, and there is very little gain from larger + * maximum cache sizes (the value below is chosen to allow caching to + * work in full with conversion of bytes.) - DKF + */ + +#define BINARY_SCAN_MAX_CACHE 260 + +/* * Prototypes for local procedures defined in this file: */ @@ -36,7 +56,8 @@ static int FormatNumber _ANSI_ARGS_((Tcl_Interp *interp, int type, static void FreeByteArrayInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr)); static int GetFormatSpec _ANSI_ARGS_((char **formatPtr, char *cmdPtr, int *countPtr)); -static Tcl_Obj * ScanNumber _ANSI_ARGS_((unsigned char *buffer, int type)); +static Tcl_Obj * ScanNumber _ANSI_ARGS_((unsigned char *buffer, + int type, Tcl_HashTable **numberCachePtr)); static int SetByteArrayFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); static void UpdateStringOfByteArray _ANSI_ARGS_((Tcl_Obj *listPtr)); @@ -125,7 +146,7 @@ typedef struct ByteArray { Tcl_Obj * Tcl_NewByteArrayObj(bytes, length) - unsigned char *bytes; /* The array of bytes used to initialize + 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. */ @@ -137,7 +158,7 @@ Tcl_NewByteArrayObj(bytes, length) Tcl_Obj * Tcl_NewByteArrayObj(bytes, length) - unsigned char *bytes; /* The array of bytes used to initialize + 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. */ @@ -159,8 +180,8 @@ Tcl_NewByteArrayObj(bytes, length) * TCL_MEM_DEBUG is defined. It is the same as the Tcl_NewByteArrayObj * above except that it calls Tcl_DbCkalloc directly with the file name * and line number from its caller. This simplifies debugging since then - * the checkmem command will report the correct file name and line number - * when reporting objects that haven't been freed. + * 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 procedure just returns the * result of calling Tcl_NewByteArrayObj. @@ -180,11 +201,11 @@ Tcl_NewByteArrayObj(bytes, length) Tcl_Obj * Tcl_DbNewByteArrayObj(bytes, length, file, line) - unsigned char *bytes; /* The array of bytes used to initialize + 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. */ - char *file; /* The name of the source file calling this + 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. */ @@ -200,11 +221,11 @@ Tcl_DbNewByteArrayObj(bytes, length, file, line) Tcl_Obj * Tcl_DbNewByteArrayObj(bytes, length, file, line) - unsigned char *bytes; /* The array of bytes used to initialize + 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. */ - char *file; /* The name of the source file calling this + 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. */ @@ -234,7 +255,7 @@ Tcl_DbNewByteArrayObj(bytes, length, file, line) void Tcl_SetByteArrayObj(objPtr, bytes, length) Tcl_Obj *objPtr; /* Object to initialize as a ByteArray. */ - unsigned char *bytes; /* The array of bytes to use as the new + CONST unsigned char *bytes; /* The array of bytes to use as the new * value. */ int length; /* Length of the array of bytes, which must * be >= 0. */ @@ -561,7 +582,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) * cursor has visited.*/ char *errorString, *errorValue, *str; int offset, size, length, index; - static char *options[] = { + static CONST char *options[] = { "format", "scan", NULL }; enum options { @@ -644,6 +665,11 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) size = 4; goto doNumbers; } + case 'w': + case 'W': { + size = 8; + goto doNumbers; + } case 'f': { size = sizeof(float); goto doNumbers; @@ -924,6 +950,8 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) case 'S': case 'i': case 'I': + case 'w': + case 'W': case 'd': case 'f': { int listc, i; @@ -996,12 +1024,16 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) case BINARY_SCAN: { int i; Tcl_Obj *valuePtr, *elementPtr; + Tcl_HashTable numberCacheHash; + Tcl_HashTable *numberCachePtr; if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, "value formatString ?varName varName ...?"); return TCL_ERROR; } + numberCachePtr = &numberCacheHash; + Tcl_InitHashTable(numberCachePtr, TCL_ONE_WORD_KEYS); buffer = Tcl_GetByteArrayFromObj(objv[2], &length); format = Tcl_GetString(objv[3]); cursor = buffer; @@ -1018,6 +1050,9 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) unsigned char *src; if (arg >= objc) { + if (numberCachePtr != NULL) { + Tcl_DeleteHashTable(numberCachePtr); + } goto badIndex; } if (count == BINARY_ALL) { @@ -1051,6 +1086,9 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) NULL, valuePtr, TCL_LEAVE_ERR_MSG); arg++; if (resultPtr == NULL) { + if (numberCachePtr != NULL) { + Tcl_DeleteHashTable(numberCachePtr); + } Tcl_DecrRefCount(valuePtr); /* unneeded */ return TCL_ERROR; } @@ -1063,6 +1101,9 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) char *dest; if (arg >= objc) { + if (numberCachePtr != NULL) { + Tcl_DeleteHashTable(numberCachePtr); + } goto badIndex; } if (count == BINARY_ALL) { @@ -1104,6 +1145,9 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) NULL, valuePtr, TCL_LEAVE_ERR_MSG); arg++; if (resultPtr == NULL) { + if (numberCachePtr != NULL) { + Tcl_DeleteHashTable(numberCachePtr); + } Tcl_DecrRefCount(valuePtr); /* unneeded */ return TCL_ERROR; } @@ -1118,6 +1162,9 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) static char hexdigit[] = "0123456789abcdef"; if (arg >= objc) { + if (numberCachePtr != NULL) { + Tcl_DeleteHashTable(numberCachePtr); + } goto badIndex; } if (count == BINARY_ALL) { @@ -1159,6 +1206,9 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) NULL, valuePtr, TCL_LEAVE_ERR_MSG); arg++; if (resultPtr == NULL) { + if (numberCachePtr != NULL) { + Tcl_DeleteHashTable(numberCachePtr); + } Tcl_DecrRefCount(valuePtr); /* unneeded */ return TCL_ERROR; } @@ -1179,6 +1229,11 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) size = 4; goto scanNumber; } + case 'w': + case 'W': { + size = 8; + goto scanNumber; + } case 'f': { size = sizeof(float); goto scanNumber; @@ -1191,13 +1246,17 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) scanNumber: if (arg >= objc) { + if (numberCachePtr != NULL) { + Tcl_DeleteHashTable(numberCachePtr); + } goto badIndex; } if (count == BINARY_NOCOUNT) { if ((length - offset) < size) { goto done; } - valuePtr = ScanNumber(buffer+offset, cmd); + valuePtr = ScanNumber(buffer+offset, cmd, + &numberCachePtr); offset += size; } else { if (count == BINARY_ALL) { @@ -1209,7 +1268,8 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) valuePtr = Tcl_NewObj(); src = buffer+offset; for (i = 0; i < count; i++) { - elementPtr = ScanNumber(src, cmd); + elementPtr = ScanNumber(src, cmd, + &numberCachePtr); src += size; Tcl_ListObjAppendElement(NULL, valuePtr, elementPtr); @@ -1221,6 +1281,9 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) NULL, valuePtr, TCL_LEAVE_ERR_MSG); arg++; if (resultPtr == NULL) { + if (numberCachePtr != NULL) { + Tcl_DeleteHashTable(numberCachePtr); + } Tcl_DecrRefCount(valuePtr); /* unneeded */ return TCL_ERROR; } @@ -1251,6 +1314,9 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) } case '@': { if (count == BINARY_NOCOUNT) { + if (numberCachePtr != NULL) { + Tcl_DeleteHashTable(numberCachePtr); + } goto badCount; } if ((count == BINARY_ALL) || (count > length)) { @@ -1261,6 +1327,9 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) break; } default: { + if (numberCachePtr != NULL) { + Tcl_DeleteHashTable(numberCachePtr); + } errorString = str; goto badfield; } @@ -1274,6 +1343,9 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) done: Tcl_ResetResult(interp); Tcl_SetLongObj(Tcl_GetObjResult(interp), arg - 4); + if (numberCachePtr != NULL) { + Tcl_DeleteHashTable(numberCachePtr); + } break; } } @@ -1393,10 +1465,13 @@ FormatNumber(interp, type, src, cursorPtr) Tcl_Obj *src; /* Number to format. */ unsigned char **cursorPtr; /* Pointer to index into destination buffer. */ { - int value; + long value; double dvalue; + Tcl_WideInt wvalue; - if ((type == 'd') || (type == 'f')) { + switch (type) { + case 'd': + case 'f': /* * For floating point types, we need to copy the data using * memcpy to avoid alignment issues. @@ -1425,8 +1500,39 @@ FormatNumber(interp, type, src, cursorPtr) memcpy((VOID *) *cursorPtr, (VOID *) &fvalue, sizeof(float)); *cursorPtr += sizeof(float); } - } else { - if (Tcl_GetIntFromObj(interp, src, &value) != TCL_OK) { + return TCL_OK; + + /* + * Next cases separate from other integer cases because we + * need a different API to get a wide. + */ + case 'w': + case 'W': + if (Tcl_GetWideIntFromObj(interp, src, &wvalue) != TCL_OK) { + return TCL_ERROR; + } + if (type == 'w') { + *(*cursorPtr)++ = (unsigned char) wvalue; + *(*cursorPtr)++ = (unsigned char) (wvalue >> 8); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 16); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 24); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 32); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 40); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 48); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 56); + } else { + *(*cursorPtr)++ = (unsigned char) (wvalue >> 56); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 48); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 40); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 32); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 24); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 16); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 8); + *(*cursorPtr)++ = (unsigned char) wvalue; + } + return TCL_OK; + default: + if (Tcl_GetLongFromObj(interp, src, &value) != TCL_OK) { return TCL_ERROR; } if (type == 'c') { @@ -1448,8 +1554,8 @@ FormatNumber(interp, type, src, cursorPtr) *(*cursorPtr)++ = (unsigned char) (value >> 8); *(*cursorPtr)++ = (unsigned char) value; } + return TCL_OK; } - return TCL_OK; } /* @@ -1465,17 +1571,24 @@ FormatNumber(interp, type, src, cursorPtr) * This object has a ref count of zero. * * Side effects: - * None. + * Might reuse an object in the number cache, place a new object + * in the cache, or delete the cache and set the reference to + * it (itself passed in by reference) to NULL. * *---------------------------------------------------------------------- */ static Tcl_Obj * -ScanNumber(buffer, type) +ScanNumber(buffer, type, numberCachePtrPtr) unsigned char *buffer; /* Buffer to scan number from. */ int type; /* Format character from "binary scan" */ + Tcl_HashTable **numberCachePtrPtr; + /* Place to look for cache of scanned + * value objects, or NULL if too many + * different numbers have been scanned. */ { long value; + Tcl_WideInt wvalue; /* * We cannot rely on the compiler to properly sign extend integer values @@ -1486,7 +1599,7 @@ ScanNumber(buffer, type) */ switch (type) { - case 'c': { + case 'c': /* * Characters need special handling. We want to produce a * signed result, but on some platforms (such as AIX) chars @@ -1498,28 +1611,26 @@ ScanNumber(buffer, type) if (value & 0x80) { value |= -0x100; } - return Tcl_NewLongObj((long)value); - } - case 's': { + goto returnNumericObject; + + case 's': value = (long) (buffer[0] + (buffer[1] << 8)); goto shortValue; - } - case 'S': { + case 'S': value = (long) (buffer[1] + (buffer[0] << 8)); shortValue: if (value & 0x8000) { value |= -0x10000; } - return Tcl_NewLongObj(value); - } - case 'i': { + goto returnNumericObject; + + case 'i': value = (long) (buffer[0] + (buffer[1] << 8) + (buffer[2] << 16) + (buffer[3] << 24)); goto intValue; - } - case 'I': { + case 'I': value = (long) (buffer[3] + (buffer[2] << 8) + (buffer[1] << 16) @@ -1534,8 +1645,58 @@ ScanNumber(buffer, type) value -= (((unsigned int)1)<<31); value -= (((unsigned int)1)<<31); } - return Tcl_NewLongObj(value); - } + returnNumericObject: + if (*numberCachePtrPtr == NULL) { + return Tcl_NewLongObj(value); + } else { + register Tcl_HashTable *tablePtr = *numberCachePtrPtr; + register Tcl_HashEntry *hPtr; + int isNew; + + hPtr = Tcl_CreateHashEntry(tablePtr, (char *)value, &isNew); + if (!isNew) { + return (Tcl_Obj *) Tcl_GetHashValue(hPtr); + } + if (tablePtr->numEntries > BINARY_SCAN_MAX_CACHE) { + /* + * We've overflowed the cache! Someone's parsing + * a LOT of varied binary data in a single call! + * Bail out by switching back to the old behaviour + * for the rest of the scan. + * + * Note that anyone just using the 'c' conversion + * (for bytes) cannot trigger this. + */ + Tcl_DeleteHashTable(tablePtr); + *numberCachePtrPtr = NULL; + return Tcl_NewLongObj(value); + } else { + register Tcl_Obj *objPtr = Tcl_NewLongObj(value); + /* Don't need to fiddle with refcount... */ + Tcl_SetHashValue(hPtr, (ClientData) objPtr); + return objPtr; + } + } + case 'w': + value = (long) (buffer[4] + | (buffer[5] << 8) + | (buffer[6] << 16) + | (buffer[7] << 24)); + wvalue = ((Tcl_WideInt) value) << 32 | (buffer[0] + | (buffer[1] << 8) + | (buffer[2] << 16) + | (buffer[3] << 24)); + return Tcl_NewWideIntObj(wvalue); + case 'W': + value = (long) (buffer[3] + | (buffer[2] << 8) + | (buffer[1] << 16) + | (buffer[0] << 24)); + wvalue = ((Tcl_WideInt) value) << 32 | (buffer[7] + | (buffer[6] << 8) + | (buffer[5] << 16) + | (buffer[4] << 24)); + return Tcl_NewWideIntObj(wvalue); case 'f': { float fvalue; memcpy((VOID *) &fvalue, (VOID *) buffer, sizeof(float)); diff --git a/tcl/generic/tclCkalloc.c b/tcl/generic/tclCkalloc.c index 1eb906d2af8..ff0917972ca 100644 --- a/tcl/generic/tclCkalloc.c +++ b/tcl/generic/tclCkalloc.c @@ -54,7 +54,7 @@ struct mem_header { struct mem_header *blink; MemTag *tagPtr; /* Tag from "memory tag" command; may be * NULL. */ - char *file; + CONST char *file; long length; int line; unsigned char low_guard[LOW_GUARD_SIZE]; @@ -111,6 +111,7 @@ static int init_malloced_bodies = TRUE; char *tclMemDumpFileName = NULL; +static char *onExitMemDumpFileName = NULL; static char dumpFile[100]; /* Records where to dump memory allocation * information. */ @@ -127,11 +128,11 @@ static int ckallocInit = 0; */ static int CheckmemCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char *argv[])); + Tcl_Interp *interp, int argc, CONST char *argv[])); static int MemoryCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); + Tcl_Interp *interp, int argc, CONST char **argv)); static void ValidateMemory _ANSI_ARGS_(( - struct mem_header *memHeaderP, char *file, + struct mem_header *memHeaderP, CONST char *file, int line, int nukeGuards)); /* @@ -200,7 +201,7 @@ TclDumpMemoryInfo(outFile) static void ValidateMemory(memHeaderP, file, line, nukeGuards) struct mem_header *memHeaderP; /* Memory chunk to validate */ - char *file; /* File containing the call to + CONST char *file; /* File containing the call to * Tcl_ValidateAllMemory */ int line; /* Line number of call to * Tcl_ValidateAllMemory */ @@ -280,8 +281,8 @@ ValidateMemory(memHeaderP, file, line, nukeGuards) */ void Tcl_ValidateAllMemory (file, line) - char *file; /* File from which Tcl_ValidateAllMemory was called */ - int line; /* Line number of call to Tcl_ValidateAllMemory */ + CONST char *file; /* File from which Tcl_ValidateAllMemory was called */ + int line; /* Line number of call to Tcl_ValidateAllMemory */ { struct mem_header *memScanP; @@ -304,13 +305,13 @@ Tcl_ValidateAllMemory (file, line) * information will be written to stderr. * * Results: - * Return TCL_ERROR if an error accessing the file occures, `errno' + * Return TCL_ERROR if an error accessing the file occurs, `errno' * will have the file error number left in it. *---------------------------------------------------------------------- */ int Tcl_DumpActiveMemory (fileName) - char *fileName; /* Name of the file to write info to */ + CONST char *fileName; /* Name of the file to write info to */ { FILE *fileP; struct mem_header *memScanP; @@ -364,7 +365,7 @@ Tcl_DumpActiveMemory (fileName) char * Tcl_DbCkalloc(size, file, line) unsigned int size; - char *file; + CONST char *file; int line; { struct mem_header *result; @@ -377,7 +378,7 @@ Tcl_DbCkalloc(size, file, line) if (result == NULL) { fflush(stdout); TclDumpMemoryInfo(stderr); - panic("unable to alloc %d bytes, %s line %d", size, file, line); + panic("unable to alloc %ud bytes, %s line %d", size, file, line); } /* @@ -421,7 +422,7 @@ Tcl_DbCkalloc(size, file, line) } if (alloc_tracing) - fprintf(stderr,"ckalloc %lx %d %s %d\n", + fprintf(stderr,"ckalloc %lx %ud %s %d\n", (long unsigned int) result->body, size, file, line); if (break_on_malloc && (total_mallocs >= break_on_malloc)) { @@ -445,6 +446,92 @@ Tcl_DbCkalloc(size, file, line) return result->body; } + +char * +Tcl_AttemptDbCkalloc(size, file, line) + unsigned int size; + CONST char *file; + int line; +{ + struct mem_header *result; + + if (validate_memory) + Tcl_ValidateAllMemory (file, line); + + result = (struct mem_header *) TclpAlloc((unsigned)size + + sizeof(struct mem_header) + HIGH_GUARD_SIZE); + if (result == NULL) { + fflush(stdout); + TclDumpMemoryInfo(stderr); + return NULL; + } + + /* + * Fill in guard zones and size. Also initialize the contents of + * the block with bogus bytes to detect uses of initialized data. + * Link into allocated list. + */ + if (init_malloced_bodies) { + memset ((VOID *) result, GUARD_VALUE, + size + sizeof(struct mem_header) + HIGH_GUARD_SIZE); + } else { + memset ((char *) result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE); + memset (result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE); + } + if (!ckallocInit) { + TclInitDbCkalloc(); + } + Tcl_MutexLock(ckallocMutexPtr); + result->length = size; + result->tagPtr = curTagPtr; + if (curTagPtr != NULL) { + curTagPtr->refCount++; + } + result->file = file; + result->line = line; + result->flink = allocHead; + result->blink = NULL; + + if (allocHead != NULL) + allocHead->blink = result; + allocHead = result; + + 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", + total_mallocs); + fflush(stderr); + alloc_tracing = TRUE; + trace_on_at_malloc = 0; + } + + if (alloc_tracing) + fprintf(stderr,"ckalloc %lx %ud %s %d\n", + (long unsigned int) result->body, size, file, line); + + if (break_on_malloc && (total_mallocs >= break_on_malloc)) { + break_on_malloc = 0; + (void) fflush(stdout); + fprintf(stderr,"reached malloc break limit (%d)\n", + total_mallocs); + fprintf(stderr, "program will now enter C debugger\n"); + (void) fflush(stderr); + abort(); + } + + current_malloc_packets++; + if (current_malloc_packets > maximum_malloc_packets) + maximum_malloc_packets = current_malloc_packets; + current_bytes_malloced += size; + if (current_bytes_malloced > maximum_bytes_malloced) + maximum_bytes_malloced = current_bytes_malloced; + + Tcl_MutexUnlock(ckallocMutexPtr); + + return result->body; +} + /* *---------------------------------------------------------------------- @@ -467,9 +554,9 @@ Tcl_DbCkalloc(size, file, line) int Tcl_DbCkfree(ptr, file, line) - char *ptr; - char *file; - int line; + char *ptr; + CONST char *file; + int line; { struct mem_header *memp; @@ -542,10 +629,10 @@ Tcl_DbCkfree(ptr, file, line) */ char * Tcl_DbCkrealloc(ptr, size, file, line) - char *ptr; + char *ptr; unsigned int size; - char *file; - int line; + CONST char *file; + int line; { char *new; unsigned int copySize; @@ -572,6 +659,41 @@ Tcl_DbCkrealloc(ptr, size, file, line) return new; } +char * +Tcl_AttemptDbCkrealloc(ptr, size, file, line) + char *ptr; + unsigned int size; + CONST char *file; + int line; +{ + char *new; + unsigned int copySize; + struct mem_header *memp; + + if (ptr == NULL) { + return Tcl_AttemptDbCkalloc(size, file, line); + } + + /* + * See comment from Tcl_DbCkfree before you change the following + * line. + */ + + memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET); + + copySize = size; + if (copySize > (unsigned int) memp->length) { + copySize = memp->length; + } + new = Tcl_AttemptDbCkalloc(size, file, line); + if (new == NULL) { + return NULL; + } + memcpy((VOID *) new, (VOID *) ptr, (size_t) copySize); + Tcl_DbCkfree(ptr, file, line); + return new; +} + /* *---------------------------------------------------------------------- @@ -593,6 +715,8 @@ Tcl_DbCkrealloc(ptr, size, file, line) #undef Tcl_Alloc #undef Tcl_Free #undef Tcl_Realloc +#undef Tcl_AttemptAlloc +#undef Tcl_AttemptRealloc char * Tcl_Alloc(size) @@ -601,6 +725,13 @@ Tcl_Alloc(size) return Tcl_DbCkalloc(size, "unknown", 0); } +char * +Tcl_AttemptAlloc(size) + unsigned int size; +{ + return Tcl_AttemptDbCkalloc(size, "unknown", 0); +} + void Tcl_Free(ptr) char *ptr; @@ -615,6 +746,13 @@ Tcl_Realloc(ptr, size) { return Tcl_DbCkrealloc(ptr, size, "unknown", 0); } +char * +Tcl_AttemptRealloc(ptr, size) + char *ptr; + unsigned int size; +{ + return Tcl_AttemptDbCkrealloc(ptr, size, "unknown", 0); +} /* *---------------------------------------------------------------------- @@ -622,11 +760,14 @@ Tcl_Realloc(ptr, size) * MemoryCmd -- * Implements the Tcl "memory" command, which provides Tcl-level * control of Tcl memory debugging information. + * memory active $file + * memory break_on_malloc $count * memory info - * memory display - * memory break_on_malloc count - * memory trace_on_at_malloc count + * memory init on|off + * memory onexit $file + * memory tag $string * memory trace on|off + * memory trace_on_at_malloc $count * memory validate on|off * * Results: @@ -640,9 +781,9 @@ MemoryCmd (clientData, interp, argc, argv) ClientData clientData; Tcl_Interp *interp; int argc; - char **argv; + CONST char **argv; { - char *fileName; + CONST char *fileName; Tcl_DString buffer; int result; @@ -652,10 +793,10 @@ MemoryCmd (clientData, interp, argc, argv) return TCL_ERROR; } - if (strcmp(argv[1],"active") == 0) { + if ((strcmp(argv[1],"active") == 0) || (strcmp(argv[1],"display") == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " active file\"", (char *) NULL); + argv[0], " ", argv[1], " file\"", (char *) NULL); return TCL_ERROR; } fileName = Tcl_TranslateFileName(interp, argv[2], &buffer); @@ -681,14 +822,14 @@ MemoryCmd (clientData, interp, argc, argv) return TCL_OK; } if (strcmp(argv[1],"info") == 0) { - char buffer[400]; - sprintf(buffer, "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n", + char buf[400]; + sprintf(buf, "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n", "total mallocs", total_mallocs, "total frees", total_frees, "current packets allocated", current_malloc_packets, "current bytes allocated", current_bytes_malloced, "maximum packets allocated", maximum_malloc_packets, "maximum bytes allocated", maximum_bytes_malloced); - Tcl_SetResult(interp, buffer, TCL_VOLATILE); + Tcl_SetResult(interp, buf, TCL_VOLATILE); return TCL_OK; } if (strcmp(argv[1],"init") == 0) { @@ -698,6 +839,21 @@ MemoryCmd (clientData, interp, argc, argv) init_malloced_bodies = (strcmp(argv[2],"on") == 0); return TCL_OK; } + if (strcmp(argv[1],"onexit") == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " onexit file\"", (char *) NULL); + return TCL_ERROR; + } + fileName = Tcl_TranslateFileName(interp, argv[2], &buffer); + if (fileName == NULL) { + return TCL_ERROR; + } + onExitMemDumpFileName = dumpFile; + strcpy(onExitMemDumpFileName,fileName); + Tcl_DStringFree(&buffer); + return TCL_OK; + } if (strcmp(argv[1],"tag") == 0) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], @@ -738,7 +894,7 @@ MemoryCmd (clientData, interp, argc, argv) } Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": should be active, break_on_malloc, info, init, ", + "\": should be active, break_on_malloc, info, init, onexit, ", "tag, trace, trace_on_at_malloc, or validate", (char *) NULL); return TCL_ERROR; @@ -777,7 +933,7 @@ CheckmemCmd(clientData, interp, argc, argv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Interpreter for evaluation. */ int argc; /* Number of arguments. */ - char *argv[]; /* String values of arguments. */ + CONST char *argv[]; /* String values of arguments. */ { if (argc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], @@ -854,7 +1010,7 @@ Tcl_Alloc (size) * a special pointer on failure, but we only check for NULL */ if ((result == NULL) && size) { - panic("unable to alloc %d bytes", size); + panic("unable to alloc %ud bytes", size); } return result; } @@ -862,7 +1018,7 @@ Tcl_Alloc (size) char * Tcl_DbCkalloc(size, file, line) unsigned int size; - char *file; + CONST char *file; int line; { char *result; @@ -871,10 +1027,42 @@ Tcl_DbCkalloc(size, file, line) if ((result == NULL) && size) { fflush(stdout); - panic("unable to alloc %d bytes, %s line %d", size, file, line); + panic("unable to alloc %ud bytes, %s line %d", size, file, line); } return result; } + +/* + *---------------------------------------------------------------------- + * + * Tcl_AttemptAlloc -- + * Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does not + * check that memory was actually allocated. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_AttemptAlloc (size) + unsigned int size; +{ + char *result; + + result = TclpAlloc(size); + return result; +} + +char * +Tcl_AttemptDbCkalloc(size, file, line) + unsigned int size; + CONST char *file; + int line; +{ + char *result; + + result = (char *) TclpAlloc(size); + return result; +} /* @@ -897,17 +1085,17 @@ Tcl_Realloc(ptr, size) result = TclpRealloc(ptr, size); if ((result == NULL) && size) { - panic("unable to realloc %d bytes", size); + panic("unable to realloc %ud bytes", size); } return result; } char * Tcl_DbCkrealloc(ptr, size, file, line) - char *ptr; + char *ptr; unsigned int size; - char *file; - int line; + CONST char *file; + int line; { char *result; @@ -915,7 +1103,7 @@ Tcl_DbCkrealloc(ptr, size, file, line) if ((result == NULL) && size) { fflush(stdout); - panic("unable to realloc %d bytes, %s line %d", size, file, line); + panic("unable to realloc %ud bytes, %s line %d", size, file, line); } return result; } @@ -923,6 +1111,40 @@ Tcl_DbCkrealloc(ptr, size, file, line) /* *---------------------------------------------------------------------- * + * Tcl_AttemptRealloc -- + * Interface to TclpRealloc when TCL_MEM_DEBUG is disabled. It does + * not check that memory was actually allocated. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_AttemptRealloc(ptr, size) + char *ptr; + unsigned int size; +{ + char *result; + + result = TclpRealloc(ptr, size); + return result; +} + +char * +Tcl_AttemptDbCkrealloc(ptr, size, file, line) + char *ptr; + unsigned int size; + CONST char *file; + int line; +{ + char *result; + + result = (char *) TclpRealloc(ptr, size); + return result; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_Free -- * Interface to TclpFree when TCL_MEM_DEBUG is disabled. Done here * rather in the macro to keep some modules from being compiled with @@ -940,9 +1162,9 @@ Tcl_Free (ptr) int Tcl_DbCkfree(ptr, file, line) - char *ptr; - char *file; - int line; + char *ptr; + CONST char *file; + int line; { TclpFree(ptr); return 0; @@ -966,15 +1188,15 @@ Tcl_InitMemory(interp) int Tcl_DumpActiveMemory(fileName) - char *fileName; + CONST char *fileName; { return TCL_OK; } void Tcl_ValidateAllMemory(file, line) - char *file; - int line; + CONST char *file; + int line; { } @@ -1010,12 +1232,15 @@ void TclFinalizeMemorySubsystem() { #ifdef TCL_MEM_DEBUG - Tcl_MutexLock(ckallocMutexPtr); if (tclMemDumpFileName != NULL) { Tcl_DumpActiveMemory(tclMemDumpFileName); + } else if (onExitMemDumpFileName != NULL) { + Tcl_DumpActiveMemory(onExitMemDumpFileName); } + Tcl_MutexLock(ckallocMutexPtr); if (curTagPtr != NULL) { TclpFree((char *) curTagPtr); + curTagPtr = NULL; } allocHead = NULL; Tcl_MutexUnlock(ckallocMutexPtr); @@ -1025,4 +1250,3 @@ TclFinalizeMemorySubsystem() TclFinalizeAllocSubsystem(); #endif } - diff --git a/tcl/generic/tclClock.c b/tcl/generic/tclClock.c index ed79949feaa..f68ca6a26a5 100644 --- a/tcl/generic/tclClock.c +++ b/tcl/generic/tclClock.c @@ -67,13 +67,13 @@ Tcl_ClockObjCmd (client, interp, objc, objv) Tcl_Obj *baseObjPtr = NULL; char *scanStr; - static char *switches[] = + static CONST char *switches[] = {"clicks", "format", "scan", "seconds", (char *) NULL}; enum command { COMMAND_CLICKS, COMMAND_FORMAT, COMMAND_SCAN, COMMAND_SECONDS }; - static char *formatSwitches[] = {"-format", "-gmt", (char *) NULL}; - static char *scanSwitches[] = {"-base", "-gmt", (char *) NULL}; + static CONST char *formatSwitches[] = {"-format", "-gmt", (char *) NULL}; + static CONST char *scanSwitches[] = {"-base", "-gmt", (char *) NULL}; resultPtr = Tcl_GetObjResult(interp); if (objc < 2) { @@ -109,7 +109,7 @@ Tcl_ClockObjCmd (client, interp, objc, objv) * We can enforce at least millisecond granularity */ Tcl_Time time; - TclpGetTime(&time); + Tcl_GetTime(&time); Tcl_SetLongObj(resultPtr, (long) (time.sec*1000 + time.usec/1000)); } else { @@ -289,7 +289,7 @@ FormatClock(interp, clockVal, useGMT, format) return TCL_OK; } -#ifndef HAVE_TM_ZONE +#if !defined(HAVE_TM_ZONE) && !defined(WIN32) /* * This is a kludge for systems not having the timezone string in * struct tm. No matter what was specified, they use the local @@ -297,7 +297,7 @@ FormatClock(interp, clockVal, useGMT, format) */ if (useGMT) { - char *varValue; + CONST char *varValue; varValue = Tcl_GetVar2(interp, "env", "TZ", TCL_GLOBAL_ONLY); if (varValue != NULL) { @@ -327,15 +327,18 @@ FormatClock(interp, clockVal, useGMT, format) bufSize++; } } + Tcl_DStringInit(&uniBuffer); + Tcl_UtfToExternalDString(NULL, format, -1, &uniBuffer); Tcl_DStringInit(&buffer); Tcl_DStringSetLength(&buffer, bufSize); Tcl_MutexLock(&clockMutex); - result = TclpStrftime(buffer.string, (unsigned int) bufSize, format, - timeDataPtr); + result = TclpStrftime(buffer.string, (unsigned int) bufSize, + Tcl_DStringValue(&uniBuffer), timeDataPtr, useGMT); Tcl_MutexUnlock(&clockMutex); + Tcl_DStringFree(&uniBuffer); -#ifndef HAVE_TM_ZONE +#if !defined(HAVE_TM_ZONE) && !defined(WIN32) if (useGMT) { if (savedTZEnv != NULL) { Tcl_SetVar2(interp, "env", "TZ", savedTZEnv, TCL_GLOBAL_ONLY); @@ -361,8 +364,7 @@ FormatClock(interp, clockVal, useGMT, format) } /* - * Convert the time to external encoding, in case we asked for - * a localized return value. [Bug: 3345] + * Convert the time to UTF from external encoding [Bug: 3345] */ Tcl_DStringInit(&uniBuffer); Tcl_ExternalToUtfDString(NULL, buffer.string, -1, &uniBuffer); @@ -374,4 +376,3 @@ FormatClock(interp, clockVal, useGMT, format) return TCL_OK; } - diff --git a/tcl/generic/tclCmdAH.c b/tcl/generic/tclCmdAH.c index 7788917ef99..e82dee2b03c 100644 --- a/tcl/generic/tclCmdAH.c +++ b/tcl/generic/tclCmdAH.c @@ -18,8 +18,6 @@ #include "tclPort.h" #include <locale.h> -typedef int (StatProc)_ANSI_ARGS_((CONST char *path, struct stat *buf)); - /* * Prototypes for local procedures defined in this file: */ @@ -27,15 +25,11 @@ typedef int (StatProc)_ANSI_ARGS_((CONST char *path, struct stat *buf)); static int CheckAccess _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, int mode)); static int GetStatBuf _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr, StatProc *statProc, - struct stat *statPtr)); + Tcl_Obj *objPtr, Tcl_FSStatProc *statProc, + Tcl_StatBuf *statPtr)); static char * GetTypeFromMode _ANSI_ARGS_((int mode)); -static int SplitPath _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr, int *argcPtr, char ***argvPtr)); static int StoreStatData _ANSI_ARGS_((Tcl_Interp *interp, - char *varName, struct stat *statPtr)); -static char ** StringifyObjects _ANSI_ARGS_((int objc, - Tcl_Obj *CONST objv[])); + char *varName, Tcl_StatBuf *statPtr)); /* *---------------------------------------------------------------------- @@ -99,9 +93,8 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { register int i; - int body, result; + int body, result, caseObjc; char *string, *arg; - int caseObjc; Tcl_Obj *CONST *caseObjv; Tcl_Obj *armPtr; @@ -137,7 +130,7 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv) for (i = 0; i < caseObjc; i += 2) { int patObjc, j; - char **patObjv; + CONST char **patObjv; char *pat; unsigned char *p; @@ -307,8 +300,7 @@ Tcl_CdObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - char *dirName; - Tcl_DString ds; + Tcl_Obj *dir; int result; if (objc > 2) { @@ -317,23 +309,25 @@ Tcl_CdObjCmd(dummy, interp, objc, objv) } if (objc == 2) { - dirName = Tcl_GetString(objv[1]); + dir = objv[1]; } else { - dirName = "~"; + dir = Tcl_NewStringObj("~",1); + Tcl_IncrRefCount(dir); } - if (Tcl_TranslateFileName(interp, dirName, &ds) == NULL) { - return TCL_ERROR; + if (Tcl_FSConvertToPathType(interp, dir) != TCL_OK) { + result = TCL_ERROR; + } else { + result = Tcl_FSChdir(dir); + if (result != TCL_OK) { + Tcl_AppendResult(interp, "couldn't change working directory to \"", + Tcl_GetString(dir), "\": ", Tcl_PosixError(interp), (char *) NULL); + result = TCL_ERROR; + } } - - result = Tcl_Chdir(Tcl_DStringValue(&ds)); - Tcl_DStringFree(&ds); - - if (result != 0) { - Tcl_AppendResult(interp, "couldn't change working directory to \"", - dirName, "\": ", Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; + if (objc != 2) { + Tcl_DecrRefCount(dir); } - return TCL_OK; + return result; } /* @@ -432,7 +426,7 @@ Tcl_EncodingObjCmd(dummy, interp, objc, objv) Tcl_DString ds; Tcl_Obj *resultPtr; - static char *optionStrings[] = { + static CONST char *optionStrings[] = { "convertfrom", "convertto", "names", "system", NULL }; @@ -517,7 +511,8 @@ Tcl_EncodingObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } if (objc == 2) { - Tcl_SetResult(interp, Tcl_GetEncodingName(NULL), TCL_STATIC); + Tcl_SetStringObj(Tcl_GetObjResult(interp), + Tcl_GetEncodingName(NULL), -1); } else { return Tcl_SetSystemEncoding(interp, Tcl_GetStringFromObj(objv[2], NULL)); @@ -729,6 +724,7 @@ Tcl_ExprObjCmd(dummy, interp, objc, objv) * Create a new object holding the concatenated argument strings. */ + /*** QUESTION: Do we need to copy the slow way? ***/ bytes = Tcl_GetStringFromObj(objv[1], &length); objPtr = Tcl_NewStringObj(bytes, length); Tcl_IncrRefCount(objPtr); @@ -765,7 +761,9 @@ Tcl_ExprObjCmd(dummy, interp, objc, objv) * See the user documentation for details on what it does. * PLEASE NOTE THAT THIS FAILS WITH FILENAMES AND PATHS WITH * EMBEDDED NULLS, WHICH COULD THEORETICALLY HAPPEN ON A MAC. - * + * With the object-based Tcl_FS APIs, the above NOTE may no + * longer be true. In any case this assertion should be tested. + * * Results: * A standard Tcl result. * @@ -783,21 +781,22 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - Tcl_Obj *resultPtr; int index; /* * This list of constants should match the fileOption string array below. */ - static char *fileOptions[] = { + static CONST char *fileOptions[] = { "atime", "attributes", "channels", "copy", "delete", "dirname", "executable", "exists", "extension", - "isdirectory", "isfile", "join", "lstat", - "mtime", "mkdir", "nativename", "owned", + "isdirectory", "isfile", "join", "link", + "lstat", "mtime", "mkdir", "nativename", + "normalize", "owned", "pathtype", "readable", "readlink", "rename", - "rootname", "size", "split", "stat", + "rootname", "separator", "size", "split", + "stat", "system", "tail", "type", "volumes", "writable", (char *) NULL }; @@ -805,10 +804,12 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) FILE_ATIME, FILE_ATTRIBUTES, FILE_CHANNELS, FILE_COPY, FILE_DELETE, FILE_DIRNAME, FILE_EXECUTABLE, FILE_EXISTS, FILE_EXTENSION, - FILE_ISDIRECTORY, FILE_ISFILE, FILE_JOIN, FILE_LSTAT, - FILE_MTIME, FILE_MKDIR, FILE_NATIVENAME, FILE_OWNED, + FILE_ISDIRECTORY, FILE_ISFILE, FILE_JOIN, FILE_LINK, + FILE_LSTAT, FILE_MTIME, FILE_MKDIR, FILE_NATIVENAME, + FILE_NORMALIZE, FILE_OWNED, FILE_PATHTYPE, FILE_READABLE, FILE_READLINK, FILE_RENAME, - FILE_ROOTNAME, FILE_SIZE, FILE_SPLIT, FILE_STAT, + FILE_ROOTNAME, FILE_SEPARATOR, FILE_SIZE, FILE_SPLIT, + FILE_STAT, FILE_SYSTEM, FILE_TAIL, FILE_TYPE, FILE_VOLUMES, FILE_WRITABLE }; @@ -821,18 +822,16 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } - resultPtr = Tcl_GetObjResult(interp); switch ((enum options) index) { case FILE_ATIME: { - struct stat buf; - char *fileName; + Tcl_StatBuf buf; struct utimbuf tval; if ((objc < 3) || (objc > 4)) { Tcl_WrongNumArgs(interp, 2, objv, "name ?time?"); return TCL_ERROR; } - if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) { + if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } if (objc == 4) { @@ -842,11 +841,10 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) } tval.actime = buf.st_atime; tval.modtime = buf.st_mtime; - fileName = Tcl_GetString(objv[2]); - if (utime(fileName, &tval) != 0) { - Tcl_AppendStringsToObj(resultPtr, + if (Tcl_FSUtime(objv[2], &tval) != 0) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "could not set access time for file \"", - fileName, "\": ", + Tcl_GetString(objv[2]), "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } @@ -856,11 +854,11 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) * one we sent in. However, fs's like FAT don't * even know what atime is. */ - if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) { + if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } } - Tcl_SetLongObj(resultPtr, (long) buf.st_atime); + Tcl_SetLongObj(Tcl_GetObjResult(interp), (long) buf.st_atime); return TCL_OK; } case FILE_ATTRIBUTES: { @@ -875,57 +873,24 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) ((objc == 2) ? NULL : Tcl_GetString(objv[2]))); } case FILE_COPY: { - int result; - char **argv; - - argv = StringifyObjects(objc, objv); - result = TclFileCopyCmd(interp, objc, argv); - ckfree((char *) argv); - return result; + return TclFileCopyCmd(interp, objc, objv); } case FILE_DELETE: { - int result; - char **argv; - - argv = StringifyObjects(objc, objv); - result = TclFileDeleteCmd(interp, objc, argv); - ckfree((char *) argv); - return result; + return TclFileDeleteCmd(interp, objc, objv); } case FILE_DIRNAME: { - int argc; - char **argv; - + Tcl_Obj *dirPtr; if (objc != 3) { goto only3Args; } - if (SplitPath(interp, objv[2], &argc, &argv) != TCL_OK) { - return TCL_ERROR; - } - - /* - * Return all but the last component. If there is only one - * component, return it if the path was non-relative, otherwise - * return the current directory. - */ - - if (argc > 1) { - Tcl_DString ds; - - Tcl_DStringInit(&ds); - Tcl_JoinPath(argc - 1, argv, &ds); - Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&ds), - Tcl_DStringLength(&ds)); - Tcl_DStringFree(&ds); - } else if ((argc == 0) - || (Tcl_GetPathType(argv[0]) == TCL_PATH_RELATIVE)) { - Tcl_SetStringObj(resultPtr, - ((tclPlatform == TCL_PLATFORM_MAC) ? ":" : "."), 1); + dirPtr = TclFileDirname(interp, objv[2]); + if (dirPtr == NULL) { + return TCL_ERROR; } else { - Tcl_SetStringObj(resultPtr, argv[0], -1); + Tcl_SetObjResult(interp, dirPtr); + Tcl_DecrRefCount(dirPtr); + return TCL_OK; } - ckfree((char *) argv); - return TCL_OK; } case FILE_EXECUTABLE: { if (objc != 3) { @@ -947,79 +912,162 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) fileName = Tcl_GetString(objv[2]); extension = TclGetExtension(fileName); if (extension != NULL) { - Tcl_SetStringObj(resultPtr, extension, -1); + Tcl_SetStringObj(Tcl_GetObjResult(interp), extension, -1); } return TCL_OK; } case FILE_ISDIRECTORY: { int value; - struct stat buf; + Tcl_StatBuf buf; if (objc != 3) { goto only3Args; } value = 0; - if (GetStatBuf(NULL, objv[2], TclStat, &buf) == TCL_OK) { + if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { value = S_ISDIR(buf.st_mode); } - Tcl_SetBooleanObj(resultPtr, value); + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value); return TCL_OK; } case FILE_ISFILE: { int value; - struct stat buf; + Tcl_StatBuf buf; if (objc != 3) { goto only3Args; } value = 0; - if (GetStatBuf(NULL, objv[2], TclStat, &buf) == TCL_OK) { + if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { value = S_ISREG(buf.st_mode); } - Tcl_SetBooleanObj(resultPtr, value); + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value); return TCL_OK; } case FILE_JOIN: { - char **argv; - Tcl_DString ds; + Tcl_Obj *resObj; if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?"); return TCL_ERROR; } - argv = StringifyObjects(objc - 2, objv + 2); - Tcl_DStringInit(&ds); - Tcl_JoinPath(objc - 2, argv, &ds); - Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&ds), - Tcl_DStringLength(&ds)); - Tcl_DStringFree(&ds); - ckfree((char *) argv); + resObj = Tcl_FSJoinToPath(NULL, objc - 2, objv + 2); + Tcl_SetObjResult(interp, resObj); + return TCL_OK; + } + case FILE_LINK: { + Tcl_Obj *contents; + int index; + + if (objc < 3 || objc > 5) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-linktype? linkname ?target?"); + return TCL_ERROR; + } + + /* Index of the 'source' argument */ + if (objc == 5) { + index = 3; + } else { + index = 2; + } + + if (objc > 3) { + int linkAction; + if (objc == 5) { + /* We have a '-linktype' argument */ + static CONST char *linkTypes[] = { + "-symbolic", "-hard", NULL + }; + if (Tcl_GetIndexFromObj(interp, objv[2], linkTypes, + "switch", 0, &linkAction) != TCL_OK) { + return TCL_ERROR; + } + if (linkAction == 0) { + linkAction = TCL_CREATE_SYMBOLIC_LINK; + } else { + linkAction = TCL_CREATE_HARD_LINK; + } + } else { + linkAction = TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK; + } + if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) { + return TCL_ERROR; + } + /* Create link from source to target */ + contents = Tcl_FSLink(objv[index], objv[index+1], linkAction); + if (contents == NULL) { + /* + * We handle two common error cases specially, and + * for all other errors, we use the standard posix + * error message. + */ + if (errno == EEXIST) { + Tcl_AppendResult(interp, "could not create new link \"", + Tcl_GetString(objv[index]), + "\": that path already exists", (char *) NULL); + } else if (errno == ENOENT) { + Tcl_AppendResult(interp, "could not create new link \"", + Tcl_GetString(objv[index]), + "\" since target \"", + Tcl_GetString(objv[index+1]), + "\" doesn't exist", + (char *) NULL); + } else { + Tcl_AppendResult(interp, "could not create new link \"", + Tcl_GetString(objv[index]), "\" pointing to \"", + Tcl_GetString(objv[index+1]), "\": ", + Tcl_PosixError(interp), (char *) NULL); + } + return TCL_ERROR; + } + } else { + if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) { + return TCL_ERROR; + } + /* Read link */ + contents = Tcl_FSLink(objv[index], NULL, 0); + if (contents == NULL) { + Tcl_AppendResult(interp, "could not read link \"", + Tcl_GetString(objv[index]), "\": ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + } + Tcl_SetObjResult(interp, contents); + if (objc == 3) { + /* + * If we are reading a link, we need to free this + * result refCount. If we are creating a link, this + * will just be objv[index+1], and so we don't own it. + */ + Tcl_DecrRefCount(contents); + } return TCL_OK; } case FILE_LSTAT: { char *varName; - struct stat buf; + Tcl_StatBuf buf; if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "name varName"); return TCL_ERROR; } - if (GetStatBuf(interp, objv[2], TclpLstat, &buf) != TCL_OK) { + if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) { return TCL_ERROR; } varName = Tcl_GetString(objv[3]); return StoreStatData(interp, varName, &buf); } case FILE_MTIME: { - struct stat buf; - char *fileName; + Tcl_StatBuf buf; struct utimbuf tval; if ((objc < 3) || (objc > 4)) { Tcl_WrongNumArgs(interp, 2, objv, "name ?time?"); return TCL_ERROR; } - if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) { + if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } if (objc == 4) { @@ -1029,11 +1077,10 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) } tval.actime = buf.st_atime; tval.modtime = buf.st_mtime; - fileName = Tcl_GetString(objv[2]); - if (utime(fileName, &tval) != 0) { - Tcl_AppendStringsToObj(resultPtr, + if (Tcl_FSUtime(objv[2], &tval) != 0) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "could not set modification time for file \"", - fileName, "\": ", + Tcl_GetString(objv[2]), "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } @@ -1043,28 +1090,22 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) * one we sent in. However, fs's like FAT don't * even know what atime is. */ - if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) { + if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } } - Tcl_SetLongObj(resultPtr, (long) buf.st_mtime); + Tcl_SetLongObj(Tcl_GetObjResult(interp), (long) buf.st_mtime); return TCL_OK; } case FILE_MKDIR: { - char **argv; - int result; - if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?"); return TCL_ERROR; } - argv = StringifyObjects(objc, objv); - result = TclFileMakeDirsCmd(interp, objc, argv); - ckfree((char *) argv); - return result; + return TclFileMakeDirsCmd(interp, objc, objv); } case FILE_NATIVENAME: { - char *fileName; + CONST char *fileName; Tcl_DString ds; if (objc != 3) { @@ -1075,19 +1116,32 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) if (fileName == NULL) { return TCL_ERROR; } - Tcl_SetStringObj(resultPtr, fileName, Tcl_DStringLength(&ds)); + Tcl_SetStringObj(Tcl_GetObjResult(interp), fileName, + Tcl_DStringLength(&ds)); Tcl_DStringFree(&ds); return TCL_OK; } + case FILE_NORMALIZE: { + Tcl_Obj *fileName; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "filename"); + return TCL_ERROR; + } + + fileName = Tcl_FSGetNormalizedPath(interp, objv[2]); + Tcl_SetObjResult(interp, fileName); + return TCL_OK; + } case FILE_OWNED: { int value; - struct stat buf; + Tcl_StatBuf buf; if (objc != 3) { goto only3Args; } value = 0; - if (GetStatBuf(NULL, objv[2], TclStat, &buf) == TCL_OK) { + if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { /* * For Windows and Macintosh, there are no user ids * associated with a file, so we always return 1. @@ -1099,25 +1153,23 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) value = (geteuid() == buf.st_uid); #endif } - Tcl_SetBooleanObj(resultPtr, value); + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value); return TCL_OK; } case FILE_PATHTYPE: { - char *fileName; - if (objc != 3) { goto only3Args; } - fileName = Tcl_GetString(objv[2]); - switch (Tcl_GetPathType(fileName)) { + switch (Tcl_FSGetPathType(objv[2])) { case TCL_PATH_ABSOLUTE: - Tcl_SetStringObj(resultPtr, "absolute", -1); + Tcl_SetStringObj(Tcl_GetObjResult(interp), "absolute", -1); break; case TCL_PATH_RELATIVE: - Tcl_SetStringObj(resultPtr, "relative", -1); + Tcl_SetStringObj(Tcl_GetObjResult(interp), "relative", -1); break; case TCL_PATH_VOLUME_RELATIVE: - Tcl_SetStringObj(resultPtr, "volumerelative", -1); + Tcl_SetStringObj(Tcl_GetObjResult(interp), + "volumerelative", -1); break; } return TCL_OK; @@ -1129,52 +1181,30 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) return CheckAccess(interp, objv[2], R_OK); } case FILE_READLINK: { - char *fileName, *contents; - Tcl_DString name, link; + Tcl_Obj *contents; if (objc != 3) { goto only3Args; } - fileName = Tcl_GetString(objv[2]); - fileName = Tcl_TranslateFileName(interp, fileName, &name); - if (fileName == NULL) { + if (Tcl_FSConvertToPathType(interp, objv[2]) != TCL_OK) { return TCL_ERROR; } - /* - * 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. - */ - -#ifndef S_IFLNK - contents = NULL; - errno = EINVAL; -#else - contents = TclpReadlink(fileName, &link); -#endif /* S_IFLNK */ + contents = Tcl_FSLink(objv[2], NULL, 0); - Tcl_DStringFree(&name); if (contents == NULL) { Tcl_AppendResult(interp, "could not readlink \"", Tcl_GetString(objv[2]), "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } - Tcl_DStringResult(interp, &link); + Tcl_SetObjResult(interp, contents); + Tcl_DecrRefCount(contents); return TCL_OK; } case FILE_RENAME: { - int result; - char **argv; - - argv = StringifyObjects(objc, objv); - result = TclFileRenameCmd(interp, objc, argv); - ckfree((char *) argv); - return result; + return TclFileRenameCmd(interp, objc, objv); } case FILE_ROOTNAME: { int length; @@ -1188,64 +1218,113 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) if (extension == NULL) { Tcl_SetObjResult(interp, objv[2]); } else { - Tcl_SetStringObj(resultPtr, fileName, + Tcl_SetStringObj(Tcl_GetObjResult(interp), fileName, (int) (length - strlen(extension))); } return TCL_OK; } + case FILE_SEPARATOR: { + if ((objc < 2) || (objc > 3)) { + Tcl_WrongNumArgs(interp, 2, objv, "?name?"); + return TCL_ERROR; + } + if (objc == 2) { + char *separator = NULL; /* lint */ + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: + separator = "/"; + break; + case TCL_PLATFORM_WINDOWS: + separator = "\\"; + break; + case TCL_PLATFORM_MAC: + separator = ":"; + break; + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(separator,1)); + } else { + Tcl_Obj *separatorObj = Tcl_FSPathSeparator(objv[2]); + if (separatorObj != NULL) { + Tcl_SetObjResult(interp, separatorObj); + } else { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("Unrecognised path",-1)); + return TCL_ERROR; + } + } + return TCL_OK; + } case FILE_SIZE: { - struct stat buf; + Tcl_StatBuf buf; if (objc != 3) { goto only3Args; } - if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) { + if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } - Tcl_SetLongObj(resultPtr, (long) buf.st_size); + Tcl_SetWideIntObj(Tcl_GetObjResult(interp), + (Tcl_WideInt) buf.st_size); return TCL_OK; } case FILE_SPLIT: { - int i, argc; - char **argv; - char *fileName; - Tcl_Obj *objPtr; - if (objc != 3) { goto only3Args; } - fileName = Tcl_GetString(objv[2]); - Tcl_SplitPath(fileName, &argc, &argv); - for (i = 0; i < argc; i++) { - objPtr = Tcl_NewStringObj(argv[i], -1); - Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); - } - ckfree((char *) argv); + Tcl_SetObjResult(interp, Tcl_FSSplitPath(objv[2], NULL)); return TCL_OK; } case FILE_STAT: { char *varName; - struct stat buf; + Tcl_StatBuf buf; if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "stat name varName"); return TCL_ERROR; } - if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) { + if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } varName = Tcl_GetString(objv[3]); return StoreStatData(interp, varName, &buf); } + case FILE_SYSTEM: { + Tcl_Obj* fsInfo; + if (objc != 3) { + goto only3Args; + } + fsInfo = Tcl_FSFileSystemInfo(objv[2]); + if (fsInfo != NULL) { + Tcl_SetObjResult(interp, fsInfo); + return TCL_OK; + } else { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("Unrecognised path",-1)); + return TCL_ERROR; + } + } case FILE_TAIL: { - int argc; - char **argv; + int splitElements; + Tcl_Obj *splitPtr; if (objc != 3) { goto only3Args; } - if (SplitPath(interp, objv[2], &argc, &argv) != TCL_OK) { - return TCL_ERROR; + /* + * 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 actual full path name, if we + * had just a single component. + */ + splitPtr = Tcl_FSSplitPath(objv[2], &splitElements); + if ((splitElements == 1) && (Tcl_GetString(objv[2])[0] == '~')) { + Tcl_DecrRefCount(splitPtr); + splitPtr = Tcl_FSGetNormalizedPath(interp, objv[2]); + if (splitPtr == NULL) { + return TCL_ERROR; + } + splitPtr = Tcl_FSSplitPath(splitPtr, &splitElements); } /* @@ -1253,25 +1332,28 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) * and it is the root of an absolute path. */ - if (argc > 0) { - if ((argc > 1) - || (Tcl_GetPathType(argv[0]) == TCL_PATH_RELATIVE)) { - Tcl_SetStringObj(resultPtr, argv[argc - 1], -1); + if (splitElements > 0) { + if ((splitElements > 1) + || (Tcl_FSGetPathType(objv[2]) == TCL_PATH_RELATIVE)) { + + Tcl_Obj *tail = NULL; + Tcl_ListObjIndex(NULL, splitPtr, splitElements-1, &tail); + Tcl_SetObjResult(interp, tail); } } - ckfree((char *) argv); + Tcl_DecrRefCount(splitPtr); return TCL_OK; } case FILE_TYPE: { - struct stat buf; + Tcl_StatBuf buf; if (objc != 3) { goto only3Args; } - if (GetStatBuf(interp, objv[2], TclpLstat, &buf) != TCL_OK) { + if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) { return TCL_ERROR; } - Tcl_SetStringObj(resultPtr, + Tcl_SetStringObj(Tcl_GetObjResult(interp), GetTypeFromMode((unsigned short) buf.st_mode), -1); return TCL_OK; } @@ -1280,7 +1362,8 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } - return TclpListVolumes(interp); + Tcl_SetObjResult(interp, Tcl_FSListVolumes()); + return TCL_OK; } case FILE_WRITABLE: { if (objc != 3) { @@ -1298,63 +1381,6 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) /* *--------------------------------------------------------------------------- * - * SplitPath -- - * - * Utility procedure used by Tcl_FileObjCmd() to split a path. - * Differs from standard Tcl_SplitPath in its handling of home - * directories; Tcl_SplitPath preserves the "~" while this - * procedure computes the actual full path name. - * - * Results: - * The return value is TCL_OK if the path could be split, TCL_ERROR - * otherwise. If TCL_ERROR was returned, an error message is left - * in interp. If TCL_OK was returned, *argvPtr is set to a newly - * allocated array of strings that represent the individual - * directories in the specified path, and *argcPtr is filled with - * the length of that array. - * - * Side effects: - * Memory allocated. The caller must eventually free this memory - * by calling ckfree() on *argvPtr. - * - *--------------------------------------------------------------------------- - */ - -static int -SplitPath(interp, objPtr, argcPtr, argvPtr) - Tcl_Interp *interp; /* Interp for error return. May be NULL. */ - Tcl_Obj *objPtr; /* Path to be split. */ - int *argcPtr; /* Filled with length of following array. */ - char ***argvPtr; /* Filled with array of strings representing - * the elements of the specified path. */ -{ - char *fileName; - - fileName = Tcl_GetString(objPtr); - - /* - * If there is only one element, and it starts with a tilde, - * perform tilde substitution and resplit the path. - */ - - Tcl_SplitPath(fileName, argcPtr, argvPtr); - if ((*argcPtr == 1) && (fileName[0] == '~')) { - Tcl_DString ds; - - ckfree((char *) *argvPtr); - fileName = Tcl_TranslateFileName(interp, fileName, &ds); - if (fileName == NULL) { - return TCL_ERROR; - } - Tcl_SplitPath(fileName, argcPtr, argvPtr); - Tcl_DStringFree(&ds); - } - return TCL_OK; -} - -/* - *--------------------------------------------------------------------------- - * * CheckAccess -- * * Utility procedure used by Tcl_FileObjCmd() to query file @@ -1379,16 +1405,11 @@ CheckAccess(interp, objPtr, mode) * access(). */ { int value; - char *fileName; - Tcl_DString ds; - fileName = Tcl_GetString(objPtr); - fileName = Tcl_TranslateFileName(interp, fileName, &ds); - if (fileName == NULL) { + if (Tcl_FSConvertToPathType(interp, objPtr) != TCL_OK) { value = 0; } else { - value = (TclAccess(fileName, mode) == 0); - Tcl_DStringFree(&ds); + value = (Tcl_FSAccess(objPtr, mode) == 0); } Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value); @@ -1419,23 +1440,18 @@ static int GetStatBuf(interp, objPtr, statProc, statPtr) Tcl_Interp *interp; /* Interp for error return. May be NULL. */ Tcl_Obj *objPtr; /* Path name to examine. */ - StatProc *statProc; /* Either stat() or lstat() depending on + Tcl_FSStatProc *statProc; /* Either stat() or lstat() depending on * desired behavior. */ - struct stat *statPtr; /* Filled with info about file obtained by + Tcl_StatBuf *statPtr; /* Filled with info about file obtained by * calling (*statProc)(). */ { - char *fileName; - Tcl_DString ds; int status; - fileName = Tcl_GetString(objPtr); - fileName = Tcl_TranslateFileName(interp, fileName, &ds); - if (fileName == NULL) { + if (Tcl_FSConvertToPathType(interp, objPtr) != TCL_OK) { return TCL_ERROR; } - status = (*statProc)(Tcl_DStringValue(&ds), statPtr); - Tcl_DStringFree(&ds); + status = (*statProc)(objPtr, statPtr); if (status < 0) { if (interp != NULL) { @@ -1472,66 +1488,52 @@ StoreStatData(interp, varName, statPtr) Tcl_Interp *interp; /* Interpreter for error reports. */ char *varName; /* Name of associative array variable * in which to store stat results. */ - struct stat *statPtr; /* Pointer to buffer containing + Tcl_StatBuf *statPtr; /* Pointer to buffer containing * stat data to store in varName. */ { - char string[TCL_INTEGER_SPACE]; + Tcl_Obj *var = Tcl_NewStringObj(varName, -1); + Tcl_Obj *field = Tcl_NewObj(); + Tcl_Obj *value; + register unsigned short mode; - TclFormatInt(string, (long) statPtr->st_dev); - if (Tcl_SetVar2(interp, varName, "dev", string, TCL_LEAVE_ERR_MSG) - == NULL) { - return TCL_ERROR; - } - TclFormatInt(string, (long) statPtr->st_ino); - if (Tcl_SetVar2(interp, varName, "ino", string, TCL_LEAVE_ERR_MSG) - == NULL) { - return TCL_ERROR; - } - TclFormatInt(string, (unsigned short) statPtr->st_mode); - if (Tcl_SetVar2(interp, varName, "mode", string, TCL_LEAVE_ERR_MSG) - == NULL) { - return TCL_ERROR; - } - TclFormatInt(string, (long) statPtr->st_nlink); - if (Tcl_SetVar2(interp, varName, "nlink", string, TCL_LEAVE_ERR_MSG) - == NULL) { - return TCL_ERROR; - } - TclFormatInt(string, (long) statPtr->st_uid); - if (Tcl_SetVar2(interp, varName, "uid", string, TCL_LEAVE_ERR_MSG) - == NULL) { - return TCL_ERROR; - } - TclFormatInt(string, (long) statPtr->st_gid); - if (Tcl_SetVar2(interp, varName, "gid", string, TCL_LEAVE_ERR_MSG) - == NULL) { - return TCL_ERROR; - } - sprintf(string, "%lu", (unsigned long) statPtr->st_size); - if (Tcl_SetVar2(interp, varName, "size", string, TCL_LEAVE_ERR_MSG) - == NULL) { - return TCL_ERROR; - } - TclFormatInt(string, (long) statPtr->st_atime); - if (Tcl_SetVar2(interp, varName, "atime", string, TCL_LEAVE_ERR_MSG) - == NULL) { - return TCL_ERROR; - } - TclFormatInt(string, (long) statPtr->st_mtime); - if (Tcl_SetVar2(interp, varName, "mtime", string, TCL_LEAVE_ERR_MSG) - == NULL) { - return TCL_ERROR; - } - TclFormatInt(string, (long) statPtr->st_ctime); - if (Tcl_SetVar2(interp, varName, "ctime", string, TCL_LEAVE_ERR_MSG) - == NULL) { - return TCL_ERROR; - } - if (Tcl_SetVar2(interp, varName, "type", - GetTypeFromMode((unsigned short) statPtr->st_mode), - TCL_LEAVE_ERR_MSG) == NULL) { - return TCL_ERROR; - } + /* + * Assume Tcl_ObjSetVar2() does not keep a copy of the field name! + */ +#define STORE_ARY(fieldName, object) \ + Tcl_SetStringObj(field, (fieldName), -1); \ + value = (object); \ + if (Tcl_ObjSetVar2(interp,var,field,value,TCL_LEAVE_ERR_MSG) == NULL) { \ + Tcl_DecrRefCount(var); \ + Tcl_DecrRefCount(field); \ + Tcl_DecrRefCount(value); \ + return TCL_ERROR; \ + } + + Tcl_IncrRefCount(var); + Tcl_IncrRefCount(field); + STORE_ARY("dev", Tcl_NewLongObj((long)statPtr->st_dev)); + /* + * Watch out porters; the inode is meant to be an *unsigned* value, + * so the cast might fail when there isn't a real arithmentic 'long + * long' type... + */ + 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)); +#ifdef HAVE_ST_BLOCKS + STORE_ARY("blocks",Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_blocks)); +#endif + STORE_ARY("atime", Tcl_NewLongObj((long)statPtr->st_atime)); + STORE_ARY("mtime", Tcl_NewLongObj((long)statPtr->st_mtime)); + STORE_ARY("ctime", Tcl_NewLongObj((long)statPtr->st_ctime)); + mode = (unsigned short) statPtr->st_mode; + STORE_ARY("mode", Tcl_NewIntObj(mode)); + STORE_ARY("type", Tcl_NewStringObj(GetTypeFromMode(mode), -1)); +#undef STORE_ARY + Tcl_DecrRefCount(var); + Tcl_DecrRefCount(field); return TCL_OK; } @@ -1710,17 +1712,17 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv) Tcl_Obj **argObjv = argObjStorage; #define STATIC_LIST_SIZE 4 - int indexArray[STATIC_LIST_SIZE]; /* Array of value list indices */ - int varcListArray[STATIC_LIST_SIZE]; /* # loop variables per list */ - Tcl_Obj **varvListArray[STATIC_LIST_SIZE]; /* Array of var name lists */ - int argcListArray[STATIC_LIST_SIZE]; /* Array of value list sizes */ - Tcl_Obj **argvListArray[STATIC_LIST_SIZE]; /* Array of value lists */ - - int *index = indexArray; - int *varcList = varcListArray; - Tcl_Obj ***varvList = varvListArray; - int *argcList = argcListArray; - Tcl_Obj ***argvList = argvListArray; + int indexArray[STATIC_LIST_SIZE]; + int varcListArray[STATIC_LIST_SIZE]; + Tcl_Obj **varvListArray[STATIC_LIST_SIZE]; + int argcListArray[STATIC_LIST_SIZE]; + Tcl_Obj **argvListArray[STATIC_LIST_SIZE]; + + int *index = indexArray; /* Array of value list indices */ + int *varcList = varcListArray; /* # loop variables per list */ + Tcl_Obj ***varvList = varvListArray; /* Array of var name lists */ + int *argcList = argcListArray; /* Array of value list sizes */ + Tcl_Obj ***argvList = argvListArray; /* Array of value lists */ if (objc < 4 || (objc%2 != 0)) { Tcl_WrongNumArgs(interp, 1, objv, @@ -1806,24 +1808,23 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv) for (j = 0; j < maxj; j++) { for (i = 0; i < numLists; i++) { /* - * If a variable or value list object has been converted to - * another kind of Tcl object, convert it back to a list object - * and refetch the pointer to its element array. + * Refetch the list members; we assume that the sizes are + * the same, but the array of elements might be different + * if the internal rep of the objects has been lost and + * recreated (it is too difficult to accurately tell when + * this happens, which can lead to some wierd crashes, + * like Bug #494348...) */ - if (argObjv[1+i*2]->typePtr != &tclListType) { - result = Tcl_ListObjGetElements(interp, argObjv[1+i*2], - &varcList[i], &varvList[i]); - if (result != TCL_OK) { - panic("Tcl_ForeachObjCmd: could not reconvert variable list %d to a list object\n", i); - } + result = Tcl_ListObjGetElements(interp, argObjv[1+i*2], + &varcList[i], &varvList[i]); + if (result != TCL_OK) { + panic("Tcl_ForeachObjCmd: could not reconvert variable list %d to a list object\n", i); } - if (argObjv[2+i*2]->typePtr != &tclListType) { - result = Tcl_ListObjGetElements(interp, argObjv[2+i*2], - &argcList[i], &argvList[i]); - if (result != TCL_OK) { - panic("Tcl_ForeachObjCmd: could not reconvert value list %d to a list object\n", i); - } + result = Tcl_ListObjGetElements(interp, argObjv[2+i*2], + &argcList[i], &argvList[i]); + if (result != TCL_OK) { + panic("Tcl_ForeachObjCmd: could not reconvert value list %d to a list object\n", i); } for (v = 0; v < varcList[i]; v++) { @@ -1920,9 +1921,9 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) { char *format; /* Used to read characters from the format * string. */ - int formatLen; /* The length of the format string */ + int formatLen; /* The length of the format string */ char *endPtr; /* Points to the last char in format array */ - char newFormat[40]; /* A new format specifier is generated here. */ + char newFormat[43]; /* A new format specifier is generated here. */ int width; /* Field width from field specifier, or 0 if * no width given. */ int precision; /* Field precision from field specifier, or 0 @@ -1930,12 +1931,16 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) int size; /* Number of bytes needed for result of * conversion, based on type of conversion * ("e", "s", etc.), width, and precision. */ - int intValue; /* Used to hold value to pass to sprintf, if + long intValue; /* Used to hold value to pass to sprintf, if * it's a one-word integer or char value */ char *ptrValue = NULL; /* Used to hold value to pass to sprintf, if * it's a one-word value. */ double doubleValue; /* Used to hold value to pass to sprintf if * it's a double value. */ +#ifndef TCL_WIDE_INT_IS_LONG + Tcl_WideInt wideValue; /* Used to hold value to pass to sprintf if + * it's a 'long long' value. */ +#endif /* TCL_WIDE_INT_IS_LONG */ int whichValue; /* Indicates which of intValue, ptrValue, * or doubleValue has the value to pass to * sprintf, according to the following @@ -1945,8 +1950,9 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) # define PTR_VALUE 2 # define DOUBLE_VALUE 3 # define STRING_VALUE 4 +# define WIDE_VALUE 5 # define MAX_FLOAT_SIZE 320 - + Tcl_Obj *resultPtr; /* Where result is stored finally. */ char staticBuf[MAX_FLOAT_SIZE + 1]; /* A static buffer to copy the format results @@ -1973,6 +1979,9 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) * been set for the current field. */ int gotZero; /* Non-zero indicates that a zero flag has * been seen in the current field. */ +#ifndef TCL_WIDE_INT_IS_LONG + int useWide; /* Value to be printed is Tcl_WideInt. */ +#endif /* TCL_WIDE_INT_IS_LONG */ /* * This procedure is a bit nasty. The goal is to use sprintf to @@ -1982,7 +1991,8 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) * whatever's generated. This is hard to estimate. * 3. there's no way to move the arguments from objv to the call * to sprintf in a reasonable way. This is particularly nasty - * because some of the arguments may be two-word values (doubles). + * because some of the arguments may be two-word values (doubles + * and wide-ints). * So, what happens here is to scan the format string one % group * at a time, making many individual calls to sprintf. */ @@ -1992,7 +2002,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } - format = (char *) Tcl_GetStringFromObj(objv[1], &formatLen); + format = Tcl_GetStringFromObj(objv[1], &formatLen); endPtr = format + formatLen; resultPtr = Tcl_NewObj(); objIndex = 2; @@ -2002,6 +2012,9 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) width = precision = noPercent = useShort = 0; gotZero = gotMinus = gotPrecision = 0; +#ifndef TCL_WIDE_INT_IS_LONG + useWide = 0; +#endif /* TCL_WIDE_INT_IS_LONG */ whichValue = PTR_VALUE; /* @@ -2081,7 +2094,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) newPtr++; format++; } - if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */ + if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */ width = strtoul(format, &end, 10); /* INTL: Tcl source. */ format = end; } else if (*format == '*') { @@ -2124,7 +2137,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) format++; gotPrecision = 1; } - if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */ + if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */ precision = strtoul(format, &end, 10); /* INTL: "C" locale. */ format = end; } else if (*format == '*') { @@ -2145,6 +2158,11 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) } } if (*format == 'l') { +#ifndef TCL_WIDE_INT_IS_LONG + useWide = 1; + strcpy(newPtr, TCL_LL_MODIFIER); + newPtr += TCL_LL_MODIFIER_SIZE; +#endif /* TCL_WIDE_INT_IS_LONG */ format++; } else if (*format == 'h') { useShort = 1; @@ -2166,10 +2184,32 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) case 'u': case 'x': case 'X': - if (Tcl_GetIntFromObj(interp, /* INTL: Tcl source. */ +#ifndef TCL_WIDE_INT_IS_LONG + if (useWide) { + if (Tcl_GetWideIntFromObj(interp, /* INTL: Tcl source. */ + objv[objIndex], &wideValue) != TCL_OK) { + goto fmtError; + } + whichValue = WIDE_VALUE; + size = 40 + precision; + break; + } +#endif /* TCL_WIDE_INT_IS_LONG */ + if (Tcl_GetLongFromObj(interp, /* INTL: Tcl source. */ objv[objIndex], &intValue) != TCL_OK) { goto fmtError; } +#if (LONG_MAX > INT_MAX) + /* + * Add the 'l' for long format type because we are on + * an LP64 archtecture and we are really going to pass + * a long argument to sprintf. + */ + newPtr++; + *newPtr = 0; + newPtr[-1] = newPtr[-2]; + newPtr[-2] = 'l'; +#endif /* LONG_MAX > INT_MAX */ whichValue = INT_VALUE; size = 40 + precision; break; @@ -2193,7 +2233,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) } break; case 'c': - if (Tcl_GetIntFromObj(interp, /* INTL: Tcl source. */ + if (Tcl_GetLongFromObj(interp, /* INTL: Tcl source. */ objv[objIndex], &intValue) != TCL_OK) { goto fmtError; } @@ -2254,6 +2294,12 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) sprintf(dst, newFormat, doubleValue); /* INTL: user locale. */ break; } +#ifndef TCL_WIDE_INT_IS_LONG + case WIDE_VALUE: { + sprintf(dst, newFormat, wideValue); + break; + } +#endif /* TCL_WIDE_INT_IS_LONG */ case INT_VALUE: { if (useShort) { sprintf(dst, newFormat, (short) intValue); @@ -2345,43 +2391,3 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) Tcl_DecrRefCount(resultPtr); return TCL_ERROR; } - -/* - *--------------------------------------------------------------------------- - * - * StringifyObjects -- - * - * Helper function to bridge the gap between an object-based procedure - * and an older string-based procedure. - * - * Given an array of objects, allocate an array that consists of the - * string representations of those objects. - * - * Results: - * The return value is a pointer to the newly allocated array of - * strings. Elements 0 to (objc-1) of the string array point to the - * string representation of the corresponding element in the source - * object array; element objc of the string array is NULL. - * - * Side effects: - * Memory allocated. The caller must eventually free this memory - * by calling ckfree() on the return value. - * - *--------------------------------------------------------------------------- - */ - -static char ** -StringifyObjects(objc, objv) - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ -{ - int i; - char **argv; - - argv = (char **) ckalloc((objc + 1) * sizeof(char *)); - for (i = 0; i < objc; i++) { - argv[i] = Tcl_GetString(objv[i]); - } - argv[i] = NULL; - return argv; -} diff --git a/tcl/generic/tclCmdIL.c b/tcl/generic/tclCmdIL.c index 54ed56fa0e8..dae26d8f10a 100644 --- a/tcl/generic/tclCmdIL.c +++ b/tcl/generic/tclCmdIL.c @@ -10,6 +10,7 @@ * 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. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -19,7 +20,6 @@ #include "tclInt.h" #include "tclPort.h" -#include "tclCompile.h" #include "tclRegexp.h" /* @@ -73,11 +73,18 @@ typedef struct SortInfo { #define SORTMODE_DICTIONARY 4 /* + * Magic values for the index field of the SortInfo structure. + * Note that the index "end-1" will be translated to SORTIDX_END-1, etc. + */ +#define SORTIDX_NONE -1 /* Not indexed; use whole value. */ +#define SORTIDX_END -2 /* Indexed from end. */ + +/* * Forward declarations for procedures defined in this file: */ static void AppendLocals _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *listPtr, char *pattern, + Tcl_Obj *listPtr, CONST char *pattern, int includeLinks)); static int DictionaryCompare _ANSI_ARGS_((char *left, char *right)); @@ -102,6 +109,9 @@ static int InfoDefaultCmd _ANSI_ARGS_((ClientData dummy, static int InfoExistsCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +static int InfoFunctionsCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); static int InfoGlobalsCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); @@ -313,10 +323,36 @@ Tcl_IncrObjCmd(dummy, interp, objc, objv) if (objc == 2) { incrAmount = 1; } else { +#ifdef TCL_WIDE_INT_IS_LONG if (Tcl_GetLongFromObj(interp, objv[2], &incrAmount) != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (reading increment)"); return TCL_ERROR; } +#else + /* + * Need to be a bit cautious to ensure that [expr]-like rules + * are enforced for interpretation of wide integers, despite + * the fact that the underlying API itself is a 'long' only one. + */ + if (objv[2]->typePtr == &tclIntType) { + incrAmount = objv[2]->internalRep.longValue; + } else if (objv[2]->typePtr == &tclWideIntType) { + incrAmount = Tcl_WideAsLong(objv[2]->internalRep.wideValue); + } else { + Tcl_WideInt wide; + + if (Tcl_GetWideIntFromObj(interp, objv[2], &wide) != TCL_OK) { + Tcl_AddErrorInfo(interp, "\n (reading increment)"); + return TCL_ERROR; + } + incrAmount = Tcl_WideAsLong(wide); + if ((wide <= Tcl_LongAsWide(LONG_MAX)) + && (wide >= Tcl_LongAsWide(LONG_MIN))) { + objv[2]->typePtr = &tclIntType; + objv[2]->internalRep.longValue = incrAmount; + } + } +#endif } /* @@ -363,16 +399,16 @@ Tcl_InfoObjCmd(clientData, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - static char *subCmds[] = { + static CONST char *subCmds[] = { "args", "body", "cmdcount", "commands", - "complete", "default", "exists", "globals", + "complete", "default", "exists", "functions", "globals", "hostname", "level", "library", "loaded", "locals", "nameofexecutable", "patchlevel", "procs", "script", "sharedlibextension", "tclversion", "vars", (char *) NULL}; enum ISubCmdIdx { IArgsIdx, IBodyIdx, ICmdCountIdx, ICommandsIdx, - ICompleteIdx, IDefaultIdx, IExistsIdx, IGlobalsIdx, + ICompleteIdx, IDefaultIdx, IExistsIdx, IFunctionsIdx, IGlobalsIdx, IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx, ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx, IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx @@ -412,6 +448,9 @@ Tcl_InfoObjCmd(clientData, interp, objc, objv) case IExistsIdx: result = InfoExistsCmd(clientData, interp, objc, objv); break; + case IFunctionsIdx: + result = InfoFunctionsCmd(clientData, interp, objc, objv); + break; case IGlobalsIdx: result = InfoGlobalsCmd(clientData, interp, objc, objv); break; @@ -562,23 +601,24 @@ InfoBodyCmd(dummy, interp, objc, objv) return TCL_ERROR; } - /* - * We should not return a bytecompiled body. If it is precompiled, - * then the bodyPtr's string representation is bogus, since sources - * are not available. If it was just a bytecompiled body, then it - * is likely to not be of any use to the caller, as it was compiled - * for a separate procedure context [Bug: 3412], and noone else can - * reasonably use it. - * In order to make sure that later manipulations of the object do not - * invalidate the internal representation, we make a copy of the string - * representation and return that one, instead. + /* + * Here we used to return procPtr->bodyPtr, except when the body was + * bytecompiled - in that case, the return was a copy of the body's + * string rep. In order to better isolate the implementation details + * of the compiler/engine subsystem, we now always return a copy of + * the string rep. It is important to return a copy so that later + * manipulations of the object do not invalidate the internal rep. */ bodyPtr = procPtr->bodyPtr; - resultPtr = bodyPtr; - if (bodyPtr->typePtr == &tclByteCodeType) { - resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length); + if (bodyPtr->bytes == NULL) { + /* + * The string rep might not be valid if the procedure has + * never been run before. [Bug #545644] + */ + (void) Tcl_GetString(bodyPtr); } + resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length); Tcl_SetObjResult(interp, resultPtr); return TCL_OK; @@ -654,7 +694,8 @@ InfoCommandsCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - char *cmdName, *pattern, *simplePattern; + char *cmdName, *pattern; + CONST char *simplePattern; register Tcl_HashEntry *entryPtr; Tcl_HashSearch search; Namespace *nsPtr; @@ -927,6 +968,54 @@ InfoExistsCmd(dummy, interp, objc, objv) /* *---------------------------------------------------------------------- * + * InfoFunctionsCmd -- + * + * Called to implement the "info functions" command that returns the + * list of math functions matching an optional pattern. Handles the + * following syntax: + * + * info functions ?pattern? + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoFunctionsCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + char *pattern; + Tcl_Obj *listPtr; + + if (objc == 2) { + pattern = NULL; + } else if (objc == 3) { + pattern = Tcl_GetString(objv[2]); + } else { + Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + return TCL_ERROR; + } + + listPtr = Tcl_ListMathFuncs(interp, pattern); + if (listPtr == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * InfoGlobalsCmd -- * * Called to implement the "info globals" command that returns the list @@ -1018,7 +1107,7 @@ InfoHostnameCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - char *name; + CONST char *name; if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; @@ -1136,7 +1225,7 @@ InfoLibraryCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - char *libDirName; + CONST char *libDirName; if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); @@ -1276,7 +1365,7 @@ static void AppendLocals(interp, listPtr, pattern, includeLinks) Tcl_Interp *interp; /* Current interpreter. */ Tcl_Obj *listPtr; /* List object to append names to. */ - char *pattern; /* Pattern to match against. */ + CONST char *pattern; /* Pattern to match against. */ int includeLinks; /* 1 if upvars should be included, else 0. */ { Interp *iPtr = (Interp *) interp; @@ -1298,7 +1387,8 @@ AppendLocals(interp, listPtr, pattern, includeLinks) * Skip nameless (temporary) variables and undefined variables */ - if (!TclIsVarTemporary(localPtr) && !TclIsVarUndefined(varPtr)) { + if (!TclIsVarTemporary(localPtr) && !TclIsVarUndefined(varPtr) + && (includeLinks || !TclIsVarLink(varPtr))) { varName = varPtr->name; if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { Tcl_ListObjAppendElement(interp, listPtr, @@ -1365,7 +1455,7 @@ InfoNameOfExecutableCmd(dummy, interp, objc, objv) nameOfExecutable = Tcl_GetNameOfExecutable(); if (nameOfExecutable != NULL) { - Tcl_SetStringObj(Tcl_GetObjResult(interp), (char *)nameOfExecutable, -1); + Tcl_SetStringObj(Tcl_GetObjResult(interp), nameOfExecutable, -1); } return TCL_OK; } @@ -1398,7 +1488,7 @@ InfoPatchLevelCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - char *patchlevel; + CONST char *patchlevel; if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); @@ -1445,7 +1535,8 @@ InfoProcsCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - char *cmdName, *pattern, *simplePattern; + char *cmdName, *pattern; + CONST char *simplePattern; Namespace *nsPtr; #ifdef INFO_PROCS_SEARCH_GLOBAL_NS Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); @@ -1506,19 +1597,19 @@ InfoProcsCmd(dummy, interp, objc, objv) || Tcl_StringMatch(cmdName, simplePattern)) { cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); - if (specificNsInPattern) { - elemObjPtr = Tcl_NewObj(); - Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, - elemObjPtr); - } else { - elemObjPtr = Tcl_NewStringObj(cmdName, -1); - } - realCmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); if (TclIsProc(cmdPtr) || ((realCmdPtr != NULL) && TclIsProc(realCmdPtr))) { + if (specificNsInPattern) { + elemObjPtr = Tcl_NewObj(); + Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, + elemObjPtr); + } else { + elemObjPtr = Tcl_NewStringObj(cmdName, -1); + } + Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); } } @@ -1578,14 +1669,17 @@ InfoProcsCmd(dummy, interp, objc, objv) * script file that is currently being evaluated. Handles the * following syntax: * - * info script + * info script ?newName? + * + * If newName is specified, it will set that as the internal name. * * Results: * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * an error, the result is an error message. It may change the + * internal script filename. * *---------------------------------------------------------------------- */ @@ -1598,13 +1692,20 @@ InfoScriptCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { Interp *iPtr = (Interp *) interp; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); + if ((objc != 2) && (objc != 3)) { + Tcl_WrongNumArgs(interp, 2, objv, "?filename?"); return TCL_ERROR; } + if (objc == 3) { + if (iPtr->scriptFile != NULL) { + Tcl_DecrRefCount(iPtr->scriptFile); + } + iPtr->scriptFile = objv[2]; + Tcl_IncrRefCount(iPtr->scriptFile); + } if (iPtr->scriptFile != NULL) { - Tcl_SetStringObj(Tcl_GetObjResult(interp), iPtr->scriptFile, -1); + Tcl_SetObjResult(interp, iPtr->scriptFile); } return TCL_OK; } @@ -1675,7 +1776,7 @@ InfoTclVersionCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - char *version; + CONST char *version; if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); @@ -1723,7 +1824,8 @@ InfoVarsCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { Interp *iPtr = (Interp *) interp; - char *varName, *pattern, *simplePattern; + char *varName, *pattern; + CONST char *simplePattern; register Tcl_HashEntry *entryPtr; Tcl_HashSearch search; Var *varPtr; @@ -1936,61 +2038,334 @@ Tcl_LindexObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - Tcl_Obj *listPtr; - Tcl_Obj **elemPtrs; - int listLen, index, result; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "list index"); + Tcl_Obj *elemPtr; /* Pointer to the element being extracted */ + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "list ?index...?"); return TCL_ERROR; } /* - * Convert the first argument to a list if necessary. + * If objc == 3, then objv[ 2 ] may be either a single index or + * a list of indices: go to TclLindexList to determine which. + * If objc >= 4, or objc == 2, then objv[ 2 .. objc-2 ] are all + * single indices and processed as such in TclLindexFlat. */ - listPtr = objv[1]; - result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs); - if (result != TCL_OK) { - return result; - } + if ( objc == 3 ) { + + elemPtr = TclLindexList( interp, objv[ 1 ], objv[ 2 ] ); + + } else { + elemPtr = TclLindexFlat( interp, objv[ 1 ], objc-2, objv+2 ); + + } + /* - * Get the index from objv[2]. + * Set the interpreter's object result to the last element extracted */ - result = TclGetIntForIndex(interp, objv[2], /*endValue*/ (listLen - 1), - &index); - if (result != TCL_OK) { - return result; + if ( elemPtr == NULL ) { + return TCL_ERROR; + } else { + Tcl_SetObjResult(interp, elemPtr); + Tcl_DecrRefCount( elemPtr ); + return TCL_OK; } - if ((index < 0) || (index >= listLen)) { +} + +/* + *---------------------------------------------------------------------- + * + * TclLindexList -- + * + * This procedure handles the 'lindex' command when objc==3. + * + * Results: + * Returns a pointer to the object extracted, or NULL if an + * error occurred. + * + * Side effects: + * None. + * + * If objv[1] can be parsed as a list, TclLindexList handles extraction + * of the desired element locally. Otherwise, it invokes + * TclLindexFlat to treat objv[1] as a scalar. + * + * 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 * +TclLindexList( interp, listPtr, argPtr ) + Tcl_Interp* interp; /* Tcl interpreter */ + Tcl_Obj* listPtr; /* List being unpacked */ + Tcl_Obj* argPtr; /* Index or index list */ +{ + + Tcl_Obj **elemPtrs; /* Elements of the list being manipulated. */ + int listLen; /* Length of the list being manipulated. */ + int index; /* Index into the list */ + int result; /* Result returned from a Tcl library call */ + int i; /* Current index number */ + Tcl_Obj** indices; /* Array of list indices */ + int indexCount; /* Size of the array of list indices */ + Tcl_Obj* oldListPtr; /* Temp location to preserve the list + * pointer when replacing it with a sublist */ + + /* + * 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. + */ + + if ( argPtr->typePtr != &tclListType + && TclGetIntForIndex( NULL , argPtr, 0, &index ) == TCL_OK ) { + + /* + * argPtr designates a single index. + */ + + return TclLindexFlat( interp, listPtr, 1, &argPtr ); + + } else if ( Tcl_ListObjGetElements( NULL, argPtr, &indexCount, &indices ) + != TCL_OK ) { + /* - * The index is out of range: the result is an empty string object. + * argPtr designates something that is neither an index nor a + * well-formed list. Report the error via TclLindexFlat. */ - return TCL_OK; + return TclLindexFlat( interp, listPtr, 1, &argPtr ); } /* - * Make sure listPtr still refers to a list object. It might have been - * converted to an int above if the argument objects were shared. + * Record the reference to the list that we are maintaining in + * the activation record. */ - if (listPtr->typePtr != &tclListType) { - result = Tcl_ListObjGetElements(interp, listPtr, &listLen, - &elemPtrs); + Tcl_IncrRefCount( listPtr ); + + /* + * argPtr designates a list, and the 'else if' above has parsed it + * into indexCount and indices. + */ + + for ( i = 0; i < indexCount; ++i ) { + + /* + * Convert the current listPtr to a list if necessary. + */ + + result = Tcl_ListObjGetElements( interp, listPtr, + &listLen, &elemPtrs); if (result != TCL_OK) { - return result; + Tcl_DecrRefCount( listPtr ); + return NULL; } - } + + /* + * Get the index from indices[ i ] + */ + + result = TclGetIntForIndex( interp, indices[ i ], + /*endValue*/ (listLen - 1), + &index ); + if ( result != TCL_OK ) { + /* + * Index could not be parsed + */ + + Tcl_DecrRefCount( listPtr ); + return NULL; + + } else if ( index < 0 + || index >= listLen ) { + /* + * Index is out of range + */ + Tcl_DecrRefCount( listPtr ); + listPtr = Tcl_NewObj(); + Tcl_IncrRefCount( listPtr ); + return listPtr; + } + + /* + * Make sure listPtr still refers to a list object. + * If it shared a Tcl_Obj structure with the arguments, then + * it might have just been converted to something else. + */ + + if (listPtr->typePtr != &tclListType) { + result = Tcl_ListObjGetElements(interp, listPtr, &listLen, + &elemPtrs); + if (result != TCL_OK) { + Tcl_DecrRefCount( listPtr ); + return NULL; + } + } + + /* + * Extract the pointer to the appropriate element + */ + + oldListPtr = listPtr; + listPtr = elemPtrs[ index ]; + Tcl_IncrRefCount( listPtr ); + Tcl_DecrRefCount( oldListPtr ); + + /* + * The work we did above may have caused the internal rep + * of *argPtr to change to something else. Get it back. + */ + + result = Tcl_ListObjGetElements( interp, argPtr, + &indexCount, &indices ); + if ( result != TCL_OK ) { + /* + * This can't happen unless some extension corrupted a Tcl_Obj. + */ + Tcl_DecrRefCount( listPtr ); + return NULL; + } + + } /* end for */ /* - * Set the interpreter's object result to the index-th list element. + * Return the last object extracted. Its reference count will include + * the reference being returned. */ - Tcl_SetObjResult(interp, elemPtrs[index]); - return TCL_OK; + return listPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclLindexFlat -- + * + * This procedure handles the 'lindex' command, given that the + * arguments to the command are known to be a flat list. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * None. + * + * This procedure is called from either tclExecute.c or + * Tcl_LindexObjCmd whenever either is presented with + * objc == 2 or objc >= 4. It is also called from TclLindexList + * for the objc==3 case once it is determined that objv[2] cannot + * be parsed as a list. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclLindexFlat( interp, listPtr, indexCount, indexArray ) + Tcl_Interp* interp; /* Tcl interpreter */ + Tcl_Obj* listPtr; /* Tcl object representing the list */ + int indexCount; /* Count of indices */ + Tcl_Obj* CONST indexArray[]; + /* Array of pointers to Tcl objects + * representing the indices in the + * list */ +{ + + int i; /* Current list index */ + int result; /* Result of Tcl library calls */ + int listLen; /* Length of the current list being + * processed */ + Tcl_Obj** elemPtrs; /* Array of pointers to the elements + * of the current list */ + int index; /* Parsed version of the current element + * of indexArray */ + Tcl_Obj* oldListPtr; /* Temporary to hold listPtr so that + * its ref count can be decremented. */ + + /* + * Record the reference to the 'listPtr' object that we are + * maintaining in the C activation record. + */ + + Tcl_IncrRefCount( listPtr ); + + for ( i = 0; i < indexCount; ++i ) { + + /* + * Convert the current listPtr to a list if necessary. + */ + + result = Tcl_ListObjGetElements(interp, listPtr, + &listLen, &elemPtrs); + if (result != TCL_OK) { + Tcl_DecrRefCount( listPtr ); + return NULL; + } + + /* + * Get the index from objv[i] + */ + + result = TclGetIntForIndex( interp, indexArray[ i ], + /*endValue*/ (listLen - 1), + &index ); + if ( result != TCL_OK ) { + + /* Index could not be parsed */ + + Tcl_DecrRefCount( listPtr ); + return NULL; + + } else if ( index < 0 + || index >= listLen ) { + + /* + * Index is out of range + */ + + Tcl_DecrRefCount( listPtr ); + listPtr = Tcl_NewObj(); + Tcl_IncrRefCount( listPtr ); + return listPtr; + } + + /* + * Make sure listPtr still refers to a list object. + * It might have been converted to something else above + * if objv[1] overlaps with one of the other parameters. + */ + + if (listPtr->typePtr != &tclListType) { + result = Tcl_ListObjGetElements(interp, listPtr, &listLen, + &elemPtrs); + if (result != TCL_OK) { + Tcl_DecrRefCount( listPtr ); + return NULL; + } + } + + /* + * Extract the pointer to the appropriate element + */ + + oldListPtr = listPtr; + listPtr = elemPtrs[ index ]; + Tcl_IncrRefCount( listPtr ); + Tcl_DecrRefCount( oldListPtr ); + + } + + return listPtr; + } /* @@ -2019,77 +2394,58 @@ Tcl_LinsertObjCmd(dummy, interp, objc, objv) register int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - Tcl_Obj *listPtr, *resultPtr; - Tcl_ObjType *typePtr; + Tcl_Obj *listPtr; int index, isDuplicate, len, result; - + if (objc < 4) { Tcl_WrongNumArgs(interp, 1, objv, "list index element ?element ...?"); return TCL_ERROR; } - /* - * Get the index first since, if a conversion to int is needed, it - * will invalidate the list's internal representation. - */ - result = Tcl_ListObjLength(interp, objv[1], &len); if (result != TCL_OK) { return result; } - result = TclGetIntForIndex(interp, objv[2], /*endValue*/ len, &index); + /* + * Get the index. "end" is interpreted to be the index after the last + * element, such that using it will cause any inserted elements to be + * appended to the list. + */ + + result = TclGetIntForIndex(interp, objv[2], /*end*/ len, &index); if (result != TCL_OK) { return result; } + if (index > len) { + index = len; + } /* * If the list object is unshared we can modify it directly. Otherwise - * we create a copy to modify: this is "copy on write". We create the - * duplicate directly in the interpreter's object result. + * we create a copy to modify: this is "copy on write". */ - + listPtr = objv[1]; isDuplicate = 0; if (Tcl_IsShared(listPtr)) { - /* - * The following code must reflect the logic in Tcl_DuplicateObj() - * except that it must duplicate the list object directly into the - * interpreter's result. - */ - - Tcl_ResetResult(interp); - resultPtr = Tcl_GetObjResult(interp); - typePtr = listPtr->typePtr; - if (listPtr->bytes == NULL) { - resultPtr->bytes = NULL; - } else if (listPtr->bytes != tclEmptyStringRep) { - len = listPtr->length; - TclInitStringRep(resultPtr, listPtr->bytes, len); - } - if (typePtr != NULL) { - if (typePtr->dupIntRepProc == NULL) { - resultPtr->internalRep = listPtr->internalRep; - resultPtr->typePtr = typePtr; - } else { - (*typePtr->dupIntRepProc)(listPtr, resultPtr); - } - } - listPtr = resultPtr; + listPtr = Tcl_DuplicateObj(listPtr); isDuplicate = 1; } - - if ((objc == 4) && (index == INT_MAX)) { + + if ((objc == 4) && (index == len)) { /* * Special case: insert one element at the end of the list. */ - result = Tcl_ListObjAppendElement(interp, listPtr, objv[3]); } else if (objc > 3) { result = Tcl_ListObjReplace(interp, listPtr, index, 0, (objc-3), &(objv[3])); } if (result != TCL_OK) { + if (isDuplicate) { + Tcl_DecrRefCount(listPtr); /* free unneeded obj */ + } return result; } @@ -2097,9 +2453,7 @@ Tcl_LinsertObjCmd(dummy, interp, objc, objv) * Set the interpreter's object result. */ - if (!isDuplicate) { - Tcl_SetObjResult(interp, listPtr); - } + Tcl_SetObjResult(interp, listPtr); return TCL_OK; } @@ -2306,9 +2660,7 @@ Tcl_LreplaceObjCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { register Tcl_Obj *listPtr; - int createdNewObj, first, last, listLen, numToDelete; - int firstArgLen, result; - char *firstArg; + int isDuplicate, first, last, listLen, numToDelete, result; if (objc < 4) { Tcl_WrongNumArgs(interp, 1, objv, @@ -2316,53 +2668,43 @@ Tcl_LreplaceObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } - /* - * If the list object is unshared we can modify it directly, otherwise - * we create a copy to modify: this is "copy on write". - */ - - listPtr = objv[1]; - createdNewObj = 0; - if (Tcl_IsShared(listPtr)) { - listPtr = Tcl_DuplicateObj(listPtr); - createdNewObj = 1; - } - result = Tcl_ListObjLength(interp, listPtr, &listLen); + result = Tcl_ListObjLength(interp, objv[1], &listLen); if (result != TCL_OK) { - errorReturn: - if (createdNewObj) { - Tcl_DecrRefCount(listPtr); /* free unneeded obj */ - } return result; } /* - * Get the first and last indexes. + * Get the first and last indexes. "end" is interpreted to be the index + * for the last element, such that using it will cause that element to + * be included for deletion. */ - result = TclGetIntForIndex(interp, objv[2], /*endValue*/ (listLen - 1), - &first); + result = TclGetIntForIndex(interp, objv[2], /*end*/ (listLen - 1), &first); if (result != TCL_OK) { - goto errorReturn; + return result; } - firstArg = Tcl_GetStringFromObj(objv[2], &firstArgLen); - result = TclGetIntForIndex(interp, objv[3], /*endValue*/ (listLen - 1), - &last); + result = TclGetIntForIndex(interp, objv[3], /*end*/ (listLen - 1), &last); if (result != TCL_OK) { - goto errorReturn; + return result; } if (first < 0) { first = 0; } - if ((first >= listLen) && (listLen > 0) - && (strncmp(firstArg, "end", (unsigned) firstArgLen) != 0)) { + + /* + * Complain if the user asked for a start element that is greater than the + * list length. This won't ever trigger for the "end*" case as that will + * be properly constrained by TclGetIntForIndex because we use listLen-1 + * (to allow for replacing the last elem). + */ + + if ((first >= listLen) && (listLen > 0)) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "list doesn't contain element ", Tcl_GetString(objv[2]), (int *) NULL); - result = TCL_ERROR; - goto errorReturn; + return TCL_ERROR; } if (last >= listLen) { last = (listLen - 1); @@ -2373,6 +2715,17 @@ Tcl_LreplaceObjCmd(dummy, interp, objc, objv) numToDelete = 0; } + /* + * If the list object is unshared we can modify it directly, otherwise + * we create a copy to modify: this is "copy on write". + */ + + listPtr = objv[1]; + isDuplicate = 0; + if (Tcl_IsShared(listPtr)) { + listPtr = Tcl_DuplicateObj(listPtr); + isDuplicate = 1; + } if (objc > 4) { result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete, (objc-4), &(objv[4])); @@ -2381,7 +2734,10 @@ Tcl_LreplaceObjCmd(dummy, interp, objc, objv) 0, NULL); } if (result != TCL_OK) { - goto errorReturn; + if (isDuplicate) { + Tcl_DecrRefCount(listPtr); /* free unneeded obj */ + } + return result; } /* @@ -2418,23 +2774,120 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) { char *bytes, *patternBytes; int i, match, mode, index, result, listc, length, elemLen; - Tcl_Obj *patObj, **listv; - static char *options[] = { - "-exact", "-glob", "-regexp", NULL + int dataType, isIncreasing, lower, upper, patInt, objInt; + int offset, allMatches, inlineReturn, negatedMatch; + double patDouble, objDouble; + Tcl_Obj *patObj, **listv, *listPtr, *startPtr; + static CONST char *options[] = { + "-all", "-ascii", "-decreasing", "-dictionary", + "-exact", "-glob", "-increasing", "-inline", + "-integer", "-not", "-real", "-regexp", + "-sorted", "-start", NULL }; enum options { - LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_REGEXP + LSEARCH_ALL, LSEARCH_ASCII, LSEARCH_DECREASING, LSEARCH_DICTIONARY, + LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_INCREASING, LSEARCH_INLINE, + LSEARCH_INTEGER, LSEARCH_NOT, LSEARCH_REAL, LSEARCH_REGEXP, + LSEARCH_SORTED, LSEARCH_START }; + enum datatypes { + ASCII, DICTIONARY, INTEGER, REAL + }; + enum modes { + EXACT, GLOB, REGEXP, SORTED + }; + + mode = GLOB; + dataType = ASCII; + isIncreasing = 1; + allMatches = 0; + inlineReturn = 0; + negatedMatch = 0; + listPtr = NULL; + startPtr = NULL; + offset = 0; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "?options? list pattern"); + return TCL_ERROR; + } - mode = LSEARCH_GLOB; - if (objc == 4) { - if (Tcl_GetIndexFromObj(interp, objv[1], options, "search mode", 0, - &mode) != TCL_OK) { + for (i = 1; i < objc-2; i++) { + if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) + != TCL_OK) { + if (startPtr) { + Tcl_DecrRefCount(startPtr); + } return TCL_ERROR; } - } else if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "?mode? list pattern"); - return TCL_ERROR; + switch ((enum options) index) { + case LSEARCH_ALL: /* -all */ + allMatches = 1; + break; + case LSEARCH_ASCII: /* -ascii */ + dataType = ASCII; + break; + case LSEARCH_DECREASING: /* -decreasing */ + isIncreasing = 0; + break; + case LSEARCH_DICTIONARY: /* -dictionary */ + dataType = DICTIONARY; + break; + case LSEARCH_EXACT: /* -increasing */ + mode = EXACT; + break; + case LSEARCH_GLOB: /* -glob */ + mode = GLOB; + break; + case LSEARCH_INCREASING: /* -increasing */ + isIncreasing = 1; + break; + case LSEARCH_INLINE: /* -inline */ + inlineReturn = 1; + break; + case LSEARCH_INTEGER: /* -integer */ + dataType = INTEGER; + break; + case LSEARCH_NOT: /* -not */ + negatedMatch = 1; + break; + case LSEARCH_REAL: /* -real */ + dataType = REAL; + break; + case LSEARCH_REGEXP: /* -regexp */ + mode = REGEXP; + break; + case LSEARCH_SORTED: /* -sorted */ + mode = SORTED; + break; + case LSEARCH_START: /* -start */ + /* + * If there was a previous -start option, release its saved + * index because it will either be replaced or there will be + * an error. + */ + if (startPtr) { + Tcl_DecrRefCount(startPtr); + } + if (i > objc-4) { + Tcl_AppendResult(interp, "missing starting index", NULL); + return TCL_ERROR; + } + i++; + if (objv[i] == objv[objc - 2]) { + /* + * Take copy to prevent shimmering problems. Note + * that it does not matter if the index obj is also a + * component of the list being searched. We only need + * to copy where the list and the index are + * one-and-the-same. + */ + startPtr = Tcl_DuplicateObj(objv[i]); + } else { + startPtr = objv[i]; + Tcl_IncrRefCount(startPtr); + } + } } /* @@ -2444,48 +2897,328 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) result = Tcl_ListObjGetElements(interp, objv[objc - 2], &listc, &listv); if (result != TCL_OK) { + if (startPtr) { + Tcl_DecrRefCount(startPtr); + } return result; } + /* + * Get the user-specified start offset. + */ + if (startPtr) { + result = TclGetIntForIndex(interp, startPtr, listc-1, &offset); + Tcl_DecrRefCount(startPtr); + if (result != TCL_OK) { + return result; + } + if (offset < 0) { + offset = 0; + } else if (offset > listc-1) { + offset = listc-1; + } + } + patObj = objv[objc - 1]; - patternBytes = Tcl_GetStringFromObj(patObj, &length); + patternBytes = NULL; + if ((enum modes) mode == EXACT || (enum modes) mode == SORTED) { + switch ((enum datatypes) dataType) { + case ASCII: + case DICTIONARY: + patternBytes = Tcl_GetStringFromObj(patObj, &length); + break; + case INTEGER: + result = Tcl_GetIntFromObj(interp, patObj, &patInt); + if (result != TCL_OK) { + return result; + } + break; + case REAL: + result = Tcl_GetDoubleFromObj(interp, patObj, &patDouble); + if (result != TCL_OK) { + return result; + } + break; + } + } else { + patternBytes = Tcl_GetStringFromObj(patObj, &length); + } + /* + * Set default index value to -1, indicating failure; if we find the + * item in the course of our search, index will be set to the correct + * value. + */ index = -1; - for (i = 0; i < listc; i++) { - match = 0; - switch ((enum options) mode) { - case LSEARCH_EXACT: { - bytes = Tcl_GetStringFromObj(listv[i], &elemLen); - if (length == elemLen) { - match = (memcmp(bytes, patternBytes, - (size_t) length) == 0); + match = 0; + + if ((enum modes) mode == SORTED && !allMatches && !negatedMatch) { + /* + * If the data is sorted, we can do a more intelligent search. + * Note that there is no point in being smart when -all was + * specified; in that case, we have to look at all items anyway, + * and there is no sense in doing this when the match sense is + * inverted. + */ + lower = offset - 1; + upper = listc; + while (lower + 1 != upper) { + i = (lower + upper)/2; + switch ((enum datatypes) dataType) { + case ASCII: + bytes = Tcl_GetString(listv[i]); + match = strcmp(patternBytes, bytes); + break; + case DICTIONARY: + bytes = Tcl_GetString(listv[i]); + match = DictionaryCompare(patternBytes, bytes); + break; + case INTEGER: + result = Tcl_GetIntFromObj(interp, listv[i], &objInt); + if (result != TCL_OK) { + return result; + } + if (patInt == objInt) { + match = 0; + } else if (patInt < objInt) { + match = -1; + } else { + match = 1; } break; - } - case LSEARCH_GLOB: { - match = Tcl_StringMatch(Tcl_GetString(listv[i]), patternBytes); + case REAL: + result = Tcl_GetDoubleFromObj(interp, listv[i], &objDouble); + if (result != TCL_OK) { + return result; + } + if (patDouble == objDouble) { + match = 0; + } else if (patDouble < objDouble) { + match = -1; + } else { + match = 1; + } break; } - case LSEARCH_REGEXP: { + if (match == 0) { + /* + * Normally, binary search is written to stop when it + * finds a match. If there are duplicates of an element in + * the list, our first match might not be the first occurance. + * Consider: 0 0 0 1 1 1 2 2 2 + * To maintain consistancy with standard lsearch semantics, + * we must find the leftmost occurance of the pattern in the + * list. Thus we don't just stop searching here. This + * variation means that a search always makes log n + * comparisons (normal binary search might "get lucky" with + * an early comparison). + */ + index = i; + upper = i; + } else if (match > 0) { + if (isIncreasing) { + lower = i; + } else { + upper = i; + } + } else { + if (isIncreasing) { + upper = i; + } else { + lower = i; + } + } + } + + } else { + /* + * We need to do a linear search, because (at least one) of: + * - our matcher can only tell equal vs. not equal + * - our matching sense is negated + * - we're building a list of all matched items + */ + if (allMatches) { + listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + } + for (i = offset; i < listc; i++) { + match = 0; + switch ((enum modes) mode) { + case SORTED: + case EXACT: + switch ((enum datatypes) dataType) { + case ASCII: + bytes = Tcl_GetStringFromObj(listv[i], &elemLen); + if (length == elemLen) { + match = (memcmp(bytes, patternBytes, + (size_t) length) == 0); + } + break; + case DICTIONARY: + bytes = Tcl_GetString(listv[i]); + match = (DictionaryCompare(bytes, patternBytes) == 0); + break; + case INTEGER: + result = Tcl_GetIntFromObj(interp, listv[i], &objInt); + if (result != TCL_OK) { + if (listPtr) { + Tcl_DecrRefCount(listPtr); + } + return result; + } + match = (objInt == patInt); + break; + case REAL: + result = Tcl_GetDoubleFromObj(interp, listv[i], + &objDouble); + if (result != TCL_OK) { + if (listPtr) { + Tcl_DecrRefCount(listPtr); + } + return result; + } + match = (objDouble == patDouble); + break; + } + break; + case GLOB: + match = Tcl_StringMatch(Tcl_GetString(listv[i]), + patternBytes); + break; + case REGEXP: match = Tcl_RegExpMatchObj(interp, listv[i], patObj); if (match < 0) { + if (listPtr) { + Tcl_DecrRefCount(listPtr); + } return TCL_ERROR; } break; } + /* + * Invert match condition for -not + */ + if (negatedMatch) { + match = !match; + } + if (match != 0) { + if (!allMatches) { + index = i; + break; + } else if (inlineReturn) { + /* + * Note that these appends are not expected to fail. + */ + Tcl_ListObjAppendElement(interp, listPtr, listv[i]); + } else { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewIntObj(i)); + } + } } - if (match != 0) { - index = i; - break; - } } - Tcl_SetIntObj(Tcl_GetObjResult(interp), index); + + /* + * Return everything or a single value. + */ + if (allMatches) { + Tcl_SetObjResult(interp, listPtr); + } else if (!inlineReturn) { + Tcl_SetIntObj(Tcl_GetObjResult(interp), index); + } else if (index < 0) { + /* + * Is this superfluous? The result should be a blank object + * by default... + */ + Tcl_SetObjResult(interp, Tcl_NewObj()); + } else { + Tcl_SetObjResult(interp, listv[index]); + } return TCL_OK; } /* *---------------------------------------------------------------------- * + * Tcl_LsetObjCmd -- + * + * This procedure is invoked to process the "lset" 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_LsetObjCmd( clientData, interp, objc, objv ) + ClientData clientData; /* Not used. */ + 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 */ + + /* Check parameter count */ + + if ( objc < 3 ) { + Tcl_WrongNumArgs( interp, 1, objv, "listVar index ?index...? value" ); + return TCL_ERROR; + } + + /* Look up the list variable's value */ + + listPtr = Tcl_ObjGetVar2( interp, objv[ 1 ], (Tcl_Obj*) NULL, + TCL_LEAVE_ERR_MSG ); + if ( listPtr == NULL ) { + return TCL_ERROR; + } + + /* + * Substitute the value in the value. Return either the value or + * else an unshared copy of it. + */ + + if ( objc == 4 ) { + finalValuePtr = TclLsetList( interp, listPtr, + objv[ 2 ], objv[ 3 ] ); + } else { + finalValuePtr = TclLsetFlat( interp, listPtr, + objc-3, objv+2, objv[ objc-1 ] ); + } + + /* + * If substitution has failed, bail out. + */ + + if ( finalValuePtr == NULL ) { + return TCL_ERROR; + } + + /* Finally, update the variable so that traces fire. */ + + listPtr = Tcl_ObjSetVar2( interp, objv[1], NULL, finalValuePtr, + TCL_LEAVE_ERR_MSG ); + Tcl_DecrRefCount( finalValuePtr ); + if ( listPtr == NULL ) { + return TCL_ERROR; + } + + /* Return the new value of the variable as the interpreter result. */ + + Tcl_SetObjResult( interp, listPtr ); + return TCL_OK; + +} + +/* + *---------------------------------------------------------------------- + * * Tcl_LsortObjCmd -- * * This procedure is invoked to process the "lsort" Tcl command. @@ -2516,7 +3249,7 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv) SortInfo sortInfo; /* Information about this sort that * needs to be passed to the * comparison function */ - static char *switches[] = { + static CONST char *switches[] = { "-ascii", "-command", "-decreasing", "-dictionary", "-increasing", "-index", "-integer", "-real", "-unique", (char *) NULL }; @@ -2533,7 +3266,7 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv) sortInfo.isIncreasing = 1; sortInfo.sortMode = SORTMODE_ASCII; - sortInfo.index = -1; + sortInfo.index = SORTIDX_NONE; sortInfo.interp = interp; sortInfo.resultCode = TCL_OK; cmdPtr = NULL; @@ -2574,11 +3307,10 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv) -1); return TCL_ERROR; } - if (TclGetIntForIndex(interp, objv[i+1], -2, &sortInfo.index) - != TCL_OK) { + if (TclGetIntForIndex(interp, objv[i+1], SORTIDX_END, + &sortInfo.index) != TCL_OK) { return TCL_ERROR; } - cmdPtr = objv[i+1]; i++; break; case 6: /* -integer */ @@ -2616,12 +3348,9 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv) sortInfo.resultCode = Tcl_ListObjGetElements(interp, objv[objc-1], &length, &listObjPtrs); - if (sortInfo.resultCode != TCL_OK) { + if (sortInfo.resultCode != TCL_OK || length <= 0) { goto done; } - if (length <= 0) { - return TCL_OK; - } elementArray = (SortElement *) ckalloc(length * sizeof(SortElement)); for (i=0; i < length; i++){ elementArray[i].objPtr = listObjPtrs[i]; @@ -2832,20 +3561,20 @@ SortCompare(objPtr1, objPtr2, infoPtr) return order; } - if (infoPtr->index != -1) { + if (infoPtr->index != SORTIDX_NONE) { /* * The "-index" option was specified. Treat each object as a * list, extract the requested element from each list, and - * compare the elements, not the lists. The special index "end" - * is signaled here with a large negative index. + * compare the elements, not the lists. "end"-relative indices + * are signaled here with large negative values. */ if (Tcl_ListObjLength(infoPtr->interp, objPtr1, &listLen) != TCL_OK) { infoPtr->resultCode = TCL_ERROR; return order; } - if (infoPtr->index < -1) { - index = listLen - 1; + if (infoPtr->index < SORTIDX_NONE) { + index = listLen + infoPtr->index + 1; } else { index = infoPtr->index; } @@ -2871,8 +3600,8 @@ SortCompare(objPtr1, objPtr2, infoPtr) infoPtr->resultCode = TCL_ERROR; return order; } - if (infoPtr->index < -1) { - index = listLen - 1; + if (infoPtr->index < SORTIDX_NONE) { + index = listLen + infoPtr->index + 1; } else { index = infoPtr->index; } @@ -3097,4 +3826,3 @@ DictionaryCompare(left, right) } return diff; } - diff --git a/tcl/generic/tclCmdMZ.c b/tcl/generic/tclCmdMZ.c index abc7a30d822..d13bc8e5914 100644 --- a/tcl/generic/tclCmdMZ.c +++ b/tcl/generic/tclCmdMZ.c @@ -8,7 +8,8 @@ * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. - * Copyright (c) 1998-1999 by Scriptics Corporation. + * Copyright (c) 1998-2000 Scriptics Corporation. + * Copyright (c) 2002 ActiveState Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -18,50 +19,110 @@ #include "tclInt.h" #include "tclPort.h" -#include "tclCompile.h" #include "tclRegexp.h" /* - * Flag values used by Tcl_ScanObjCmd. + * Structure used to hold information about variable traces: */ -#define SCAN_NOSKIP 0x1 /* Don't skip blanks. */ -#define SCAN_SUPPRESS 0x2 /* Suppress assignment. */ -#define SCAN_UNSIGNED 0x4 /* Read an unsigned value. */ -#define SCAN_WIDTH 0x8 /* A width value was supplied. */ - -#define SCAN_SIGNOK 0x10 /* A +/- character is allowed. */ -#define SCAN_NODIGITS 0x20 /* No digits have been scanned. */ -#define SCAN_NOZERO 0x40 /* No zero digits have been scanned. */ -#define SCAN_XOK 0x80 /* An 'x' is allowed. */ -#define SCAN_PTOK 0x100 /* Decimal point is allowed. */ -#define SCAN_EXPOK 0x200 /* An exponent is allowed. */ +typedef struct { + int flags; /* Operations for which Tcl command is + * to be invoked. */ + size_t length; /* Number of non-NULL chars. in command. */ + char command[4]; /* Space for Tcl command to invoke. Actual + * size will be as large as necessary to + * hold command. This field must be the + * last in the structure, so that it can + * be larger than 4 bytes. */ +} TraceVarInfo; /* - * Structure used to hold information about variable traces: + * Structure used to hold information about command traces: */ typedef struct { int flags; /* Operations for which Tcl command is * to be invoked. */ - char *errMsg; /* Error message returned from Tcl command, - * or NULL. Malloc'ed. */ size_t length; /* Number of non-NULL chars. in command. */ + Tcl_Trace stepTrace; /* Used for execution traces, when tracing + * inside the given command */ + int startLevel; /* Used for bookkeeping with execution traces */ + int curFlags; /* Trace flags for the current command */ + int curCode; /* Return code for the current command */ char command[4]; /* Space for Tcl command to invoke. Actual * size will be as large as necessary to * hold command. This field must be the * last in the structure, so that it can * be larger than 4 bytes. */ -} TraceVarInfo; +} TraceCommandInfo; + +/* + * Used by command execution traces. Note that we assume in the code + * that the first two defines are exactly 4 times the + * 'TCL_TRACE_ENTER_EXEC' and 'TCL_TRACE_LEAVE_EXEC' constants. + * + * TCL_TRACE_ENTER_DURING_EXEC - Trace each command inside the command + * currently being traced, before execution. + * TCL_TRACE_LEAVE_DURING_EXEC - Trace each command inside the command + * currently being traced, after execution. + * TCL_TRACE_ANY_EXEC - OR'd combination of all EXEC flags. + * TCL_TRACE_EXEC_IN_PROGRESS - The callback procedure on this trace + * is currently executing. Therefore we + * don't let further traces execute. + * 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. + */ +#define TCL_TRACE_ENTER_DURING_EXEC 4 +#define TCL_TRACE_LEAVE_DURING_EXEC 8 +#define TCL_TRACE_ANY_EXEC 15 +#define TCL_TRACE_EXEC_IN_PROGRESS 0x10 +#define TCL_TRACE_EXEC_DIRECT 0x20 /* * Forward declarations for procedures defined in this file: */ +typedef int (Tcl_TraceTypeObjCmd) _ANSI_ARGS_((Tcl_Interp *interp, + int optionIndex, int objc, Tcl_Obj *CONST objv[])); + +Tcl_TraceTypeObjCmd TclTraceVariableObjCmd; +Tcl_TraceTypeObjCmd TclTraceCommandObjCmd; +Tcl_TraceTypeObjCmd TclTraceExecutionObjCmd; + +/* + * Each subcommand has a number of 'types' to which it can apply. + * Currently 'execution', 'command' and 'variable' are the only + * types supported. These three arrays MUST be kept in sync! + * In the future we may provide an API to add to the list of + * supported trace types. + */ +static CONST char *traceTypeOptions[] = { + "execution", "command", "variable", (char*) NULL +}; +static Tcl_TraceTypeObjCmd* traceSubCmds[] = { + TclTraceExecutionObjCmd, + TclTraceCommandObjCmd, + TclTraceVariableObjCmd, +}; + +/* + * Declarations for local procedures to this file: + */ +static int CallTraceProcedure _ANSI_ARGS_((Tcl_Interp *interp, + Trace *tracePtr, Command *cmdPtr, + CONST char *command, int numChars, + int objc, Tcl_Obj *CONST objv[])); static char * TraceVarProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, char *name1, char *name2, - int flags)); - + Tcl_Interp *interp, CONST char *name1, + CONST char *name2, int flags)); +static void TraceCommandProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, CONST char *oldName, + CONST char *newName, int flags)); +static Tcl_CmdObjTraceProc TraceExecutionProc; + /* *---------------------------------------------------------------------- * @@ -87,17 +148,19 @@ Tcl_PwdObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - Tcl_DString ds; + Tcl_Obj *retVal; if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } - if (Tcl_GetCwd(interp, &ds) == NULL) { + retVal = Tcl_FSGetCwd(interp); + if (retVal == NULL) { return TCL_ERROR; } - Tcl_DStringResult(interp, &ds); + Tcl_SetObjResult(interp, retVal); + Tcl_DecrRefCount(retVal); return TCL_OK; } @@ -131,7 +194,7 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) Tcl_RegExp regExpr; Tcl_Obj *objPtr, *resultPtr; Tcl_RegExpInfo info; - static char *options[] = { + static CONST char *options[] = { "-all", "-about", "-indices", "-inline", "-expanded", "-line", "-linestop", "-lineanchor", "-nocase", "-start", "--", (char *) NULL @@ -235,19 +298,30 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } - regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); - if (regExpr == NULL) { - return TCL_ERROR; - } - objPtr = objv[1]; - + /* + * Handle the odd about case separately. + */ if (about) { - if (TclRegAbout(interp, regExpr) < 0) { + regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); + if ((regExpr == NULL) || (TclRegAbout(interp, regExpr) < 0)) { return TCL_ERROR; } return TCL_OK; } + /* + * Get the length of the string that we are matching against so + * we can do the termination test for -all matches. Do this before + * getting the regexp to avoid shimmering problems. + */ + objPtr = objv[1]; + stringLength = Tcl_GetCharLength(objPtr); + + regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); + if (regExpr == NULL) { + return TCL_ERROR; + } + if (offset > 0) { /* * Add flag if using offset (string is part of a larger string), @@ -275,12 +349,6 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) } /* - * Get the length of the string that we are matching against so - * we can do the termination test for -all matches. - */ - stringLength = Tcl_GetCharLength(objPtr); - - /* * The following loop is to handle multiple matches within the * same source string; each iteration handles one match. If "-all" * hasn't been specified then the loop body only gets executed once. @@ -337,7 +405,11 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) int start, end; Tcl_Obj *objs[2]; - if (i <= info.nsubs) { + /* + * Only adjust the match area if there was a match for + * that area. (Scriptics Bug 4391/SF Bug #219232) + */ + if (i <= info.nsubs && info.matches[i].start >= 0) { start = offset + info.matches[i].start; end = offset + info.matches[i].end; @@ -402,6 +474,7 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) } offset += info.matches[0].end; all++; + eflags |= TCL_REG_NOTBOL; if (offset >= stringLength) { break; } @@ -411,9 +484,12 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) * Set the interpreter's object result to an integer object * with value 1 if -all wasn't specified, otherwise it's all-1 * (the number of times through the while - 1). + * Get the resultPtr again as the Tcl_ObjSetVar2 above may have + * cause the result to change. [Patch #558324] (watson). */ if (!doinline) { + resultPtr = Tcl_GetObjResult(interp); Tcl_SetIntObj(resultPtr, (all ? all-1 : 1)); } return TCL_OK; @@ -444,13 +520,14 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int i, result, cflags, all, wlen, numMatches, offset; + int idx, result, cflags, all, wlen, wsublen, numMatches, offset; + int start, end, subStart, subEnd, match; Tcl_RegExp regExpr; - Tcl_Obj *resultPtr, *varPtr, *objPtr; - Tcl_UniChar *wstring; - char *subspec; + Tcl_RegExpInfo info; + Tcl_Obj *resultPtr, *subPtr, *objPtr; + Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec, *wend; - static char *options[] = { + static CONST char *options[] = { "-all", "-nocase", "-expanded", "-line", "-linestop", "-lineanchor", "-start", "--", NULL @@ -464,17 +541,18 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) cflags = TCL_REG_ADVANCED; all = 0; offset = 0; + resultPtr = NULL; - for (i = 1; i < objc; i++) { + for (idx = 1; idx < objc; idx++) { char *name; int index; - name = Tcl_GetString(objv[i]); + name = Tcl_GetString(objv[idx]); if (name[0] != '-') { break; } - if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT, - &index) != TCL_OK) { + if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch", + TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum options) index) { @@ -503,10 +581,10 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) break; } case REGSUB_START: { - if (++i >= objc) { + if (++idx >= objc) { goto endOfForLoop; } - if (Tcl_GetIntFromObj(interp, objv[i], &offset) != TCL_OK) { + if (Tcl_GetIntFromObj(interp, objv[idx], &offset) != TCL_OK) { return TCL_ERROR; } if (offset < 0) { @@ -515,34 +593,117 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) break; } case REGSUB_LAST: { - i++; + idx++; goto endOfForLoop; } } } endOfForLoop: - if (objc - i != 4) { + if (objc-idx < 3 || objc-idx > 4) { Tcl_WrongNumArgs(interp, 1, objv, - "?switches? exp string subSpec varName"); + "?switches? exp string subSpec ?varName?"); return TCL_ERROR; } - objv += i; + objc -= idx; + objv += idx; + + if (all && (offset == 0) + && (strpbrk(Tcl_GetString(objv[2]), "&\\") == NULL) + && (strpbrk(Tcl_GetString(objv[0]), "*+?{}()[].\\|^$") == NULL)) { + /* + * This is a simple one pair string map situation. We make use of + * a slightly modified version of the one pair STR_MAP code. + */ + int slen, nocase; + int (*strCmpFn)_ANSI_ARGS_((CONST Tcl_UniChar *, CONST Tcl_UniChar *, + unsigned long)); + Tcl_UniChar *p, wsrclc; + + numMatches = 0; + nocase = (cflags & TCL_REG_NOCASE); + strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp; + + wsrc = Tcl_GetUnicodeFromObj(objv[0], &slen); + wstring = Tcl_GetUnicodeFromObj(objv[1], &wlen); + wsubspec = Tcl_GetUnicodeFromObj(objv[2], &wsublen); + wend = wstring + wlen - (slen ? slen - 1 : 0); + result = TCL_OK; + + if (slen == 0) { + /* + * regsub behavior for "" matches between each character. + * 'string map' skips the "" case. + */ + if (wstring < wend) { + resultPtr = Tcl_NewUnicodeObj(wstring, 0); + Tcl_IncrRefCount(resultPtr); + for (; wstring < wend; wstring++) { + Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen); + Tcl_AppendUnicodeToObj(resultPtr, wstring, 1); + numMatches++; + } + wlen = 0; + } + } else { + wsrclc = Tcl_UniCharToLower(*wsrc); + for (p = wfirstChar = wstring; wstring < wend; wstring++) { + if (((*wstring == *wsrc) || + (nocase && (Tcl_UniCharToLower(*wstring) == + wsrclc))) && + ((slen == 1) || (strCmpFn(wstring, wsrc, + (unsigned long) slen) == 0))) { + if (numMatches == 0) { + resultPtr = Tcl_NewUnicodeObj(wstring, 0); + Tcl_IncrRefCount(resultPtr); + } + if (p != wstring) { + Tcl_AppendUnicodeToObj(resultPtr, p, wstring - p); + p = wstring + slen; + } else { + p += slen; + } + wstring = p - 1; + + Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen); + numMatches++; + } + } + if (numMatches) { + wlen = wfirstChar + wlen - p; + wstring = p; + } + } + objPtr = NULL; + subPtr = NULL; + goto regsubDone; + } regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); if (regExpr == NULL) { return TCL_ERROR; } - result = TCL_OK; - resultPtr = Tcl_NewObj(); - Tcl_IncrRefCount(resultPtr); + /* + * Make sure to avoid problems where the objects are shared. This + * can cause RegExpObj <> UnicodeObj shimmering that causes data + * corruption. [Bug #461322] + */ - objPtr = objv[1]; - wlen = Tcl_GetCharLength(objPtr); - wstring = Tcl_GetUnicode(objPtr); - subspec = Tcl_GetString(objv[2]); - varPtr = objv[3]; + if (objv[1] == objv[0]) { + objPtr = Tcl_DuplicateObj(objv[1]); + } else { + objPtr = objv[1]; + } + wstring = Tcl_GetUnicodeFromObj(objPtr, &wlen); + if (objv[2] == objv[0]) { + subPtr = Tcl_DuplicateObj(objv[2]); + } else { + subPtr = objv[2]; + } + wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen); + + result = TCL_OK; /* * The following loop is to handle multiple matches within the @@ -553,10 +714,6 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) numMatches = 0; for ( ; offset < wlen; ) { - int start, end, subStart, subEnd, match; - char *src, *firstChar; - char c; - Tcl_RegExpInfo info; /* * The flags argument is set if string is part of a larger string, @@ -573,11 +730,16 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) if (match == 0) { break; } - if ((numMatches == 0) && (offset > 0)) { - /* Copy the initial portion of the string in if an offset - * was specified. - */ - Tcl_AppendUnicodeToObj(resultPtr, wstring, offset); + if (numMatches == 0) { + resultPtr = Tcl_NewUnicodeObj(wstring, 0); + Tcl_IncrRefCount(resultPtr); + if (offset > 0) { + /* + * Copy the initial portion of the string in if an offset + * was specified. + */ + Tcl_AppendUnicodeToObj(resultPtr, wstring, offset); + } } numMatches++; @@ -598,22 +760,22 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) * subSpec to reduce the number of calls to Tcl_SetVar. */ - src = subspec; - firstChar = subspec; - for (c = *src; c != '\0'; src++, c = *src) { - int index; - - if (c == '&') { - index = 0; - } else if (c == '\\') { - c = src[1]; - if ((c >= '0') && (c <= '9')) { - index = c - '0'; - } else if ((c == '\\') || (c == '&')) { - Tcl_AppendToObj(resultPtr, firstChar, src - firstChar); - Tcl_AppendToObj(resultPtr, &c, 1); - firstChar = src + 2; - src++; + wsrc = wfirstChar = wsubspec; + wend = wsubspec + wsublen; + for (ch = *wsrc; wsrc != wend; wsrc++, ch = *wsrc) { + if (ch == '&') { + idx = 0; + } else if (ch == '\\') { + ch = wsrc[1]; + if ((ch >= '0') && (ch <= '9')) { + idx = ch - '0'; + } else if ((ch == '\\') || (ch == '&')) { + *wsrc = ch; + Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, + wsrc - wfirstChar + 1); + *wsrc = '\\'; + wfirstChar = wsrc + 2; + wsrc++; continue; } else { continue; @@ -621,24 +783,25 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) } else { continue; } - if (firstChar != src) { - Tcl_AppendToObj(resultPtr, firstChar, src - firstChar); + if (wfirstChar != wsrc) { + Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, + wsrc - wfirstChar); } - if (index <= info.nsubs) { - subStart = info.matches[index].start; - subEnd = info.matches[index].end; + if (idx <= info.nsubs) { + subStart = info.matches[idx].start; + subEnd = info.matches[idx].end; if ((subStart >= 0) && (subEnd >= 0)) { Tcl_AppendUnicodeToObj(resultPtr, wstring + offset + subStart, subEnd - subStart); } } - if (*src == '\\') { - src++; + if (*wsrc == '\\') { + wsrc++; } - firstChar = src + 1; + wfirstChar = wsrc + 1; } - if (firstChar != src) { - Tcl_AppendToObj(resultPtr, firstChar, src - firstChar); + if (wfirstChar != wsrc) { + Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); } if (end == 0) { /* @@ -648,8 +811,9 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); offset++; + } else { + offset += end; } - offset += end; if (!all) { break; } @@ -659,31 +823,41 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) * Copy the portion of the source string after the last match to the * result variable. */ - + regsubDone: if (numMatches == 0) { /* * On zero matches, just ignore the offset, since it shouldn't * matter to us in this case, and the user may have skewed it. */ - Tcl_AppendUnicodeToObj(resultPtr, wstring, wlen); + resultPtr = objv[1]; + Tcl_IncrRefCount(resultPtr); } else if (offset < wlen) { Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset); } - if (Tcl_ObjSetVar2(interp, varPtr, NULL, resultPtr, 0) == NULL) { - Tcl_AppendResult(interp, "couldn't set variable \"", - Tcl_GetString(varPtr), "\"", (char *) NULL); - result = TCL_ERROR; + if (objc == 4) { + if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr, 0) == NULL) { + Tcl_AppendResult(interp, "couldn't set variable \"", + Tcl_GetString(objv[3]), "\"", (char *) NULL); + result = TCL_ERROR; + } else { + /* + * Set the interpreter's object result to an integer object + * holding the number of matches. + */ + + Tcl_SetIntObj(Tcl_GetObjResult(interp), numMatches); + } } else { /* - * Set the interpreter's object result to an integer object holding the - * number of matches. + * No varname supplied, so just return the modified string. */ - - Tcl_SetIntObj(Tcl_GetObjResult(interp), numMatches); + Tcl_SetObjResult(interp, resultPtr); } done: - Tcl_DecrRefCount(resultPtr); + if (objPtr && (objv[1] == objv[0])) { Tcl_DecrRefCount(objPtr); } + if (subPtr && (objv[2] == objv[0])) { Tcl_DecrRefCount(subPtr); } + if (resultPtr) { Tcl_DecrRefCount(resultPtr); } return result; } @@ -845,17 +1019,12 @@ Tcl_SourceObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - char *bytes; - int result; - if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "fileName"); return TCL_ERROR; } - bytes = Tcl_GetString(objv[1]); - result = Tcl_EvalFile(interp, bytes); - return result; + return Tcl_FSEvalFile(interp, objv[1]); } /* @@ -908,15 +1077,34 @@ Tcl_SplitObjCmd(dummy, interp, objc, objv) * Do nothing. */ } else if (splitCharLen == 0) { + Tcl_HashTable charReuseTable; + Tcl_HashEntry *hPtr; + int isNew; + /* * Handle the special case of splitting on every character. + * + * Uses a hash table to ensure that each kind of character has + * only one Tcl_Obj instance (multiply-referenced) in the + * final list. This is a *major* win when splitting on a long + * string (especially in the megabyte range!) - DKF */ + Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS); for ( ; string < end; string += len) { len = Tcl_UtfToUniChar(string, &ch); - objPtr = Tcl_NewStringObj(string, len); + /* Assume Tcl_UniChar is an integral type... */ + hPtr = Tcl_CreateHashEntry(&charReuseTable, (char*)0 + ch, &isNew); + if (isNew) { + objPtr = Tcl_NewStringObj(string, len); + /* Don't need to fiddle with refcount... */ + Tcl_SetHashValue(hPtr, (ClientData) objPtr); + } else { + objPtr = (Tcl_Obj*) Tcl_GetHashValue(hPtr); + } Tcl_ListObjAppendElement(NULL, listPtr, objPtr); } + Tcl_DeleteHashTable(&charReuseTable); } else { char *element, *p, *splitEnd; int splitLen; @@ -957,6 +1145,11 @@ Tcl_SplitObjCmd(dummy, interp, objc, objv) * that this command only functions correctly on properly formed * Tcl UTF strings. * + * Note that the primary methods here (equal, compare, match, ...) + * have bytecode equivalents. You will find the code for those in + * tclExecute.c. The code here will only be used in the non-bc + * case (like in an 'eval'). + * * Results: * A standard Tcl result. * @@ -978,7 +1171,7 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) Tcl_Obj *resultPtr; char *string1, *string2; int length1, length2; - static char *options[] = { + static CONST char *options[] = { "bytelength", "compare", "equal", "first", "index", "is", "last", "length", "map", "match", "range", "repeat", @@ -1009,7 +1202,14 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) switch ((enum options) index) { case STR_EQUAL: case STR_COMPARE: { + /* + * Remember to keep code here in some sync with the + * byte-compiled versions in tclExecute.c (INST_STR_EQ, + * INST_STR_NEQ and INST_STR_CMP as well as the expr string + * comparison in INST_EQ/INST_NEQ/INST_LT/...). + */ int i, match, length, nocase = 0, reqlength = -1; + int (*strCmpFn)(); if (objc < 4 || objc > 7) { str_cmp_args: @@ -1021,10 +1221,10 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) for (i = 2; i < objc-2; i++) { string2 = Tcl_GetStringFromObj(objv[i], &length2); if ((length2 > 1) - && strncmp(string2, "-nocase", (size_t) length2) == 0) { + && strncmp(string2, "-nocase", (size_t)length2) == 0) { nocase = 1; } else if ((length2 > 1) - && strncmp(string2, "-length", (size_t) length2) == 0) { + && strncmp(string2, "-length", (size_t)length2) == 0) { if (i+1 >= objc-2) { goto str_cmp_args; } @@ -1040,58 +1240,80 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) } } - string1 = Tcl_GetStringFromObj(objv[objc-2], &length1); - string2 = Tcl_GetStringFromObj(objv[objc-1], &length2); /* - * This is the min length IN BYTES of the two strings + * From now on, we only access the two objects at the end + * of the argument array. */ - length = (length1 < length2) ? length1 : length2; + objv += objc-2; - if (reqlength == 0) { + if ((reqlength == 0) || (objv[0] == objv[1])) { /* - * Anything matches at 0 chars, right? + * Alway match at 0 chars of if it is the same obj. */ - match = 0; - } else if (nocase || ((reqlength > 0) && (reqlength <= length))) { + Tcl_SetBooleanObj(resultPtr, + ((enum options) index == STR_EQUAL)); + break; + } else if (!nocase && objv[0]->typePtr == &tclByteArrayType && + objv[1]->typePtr == &tclByteArrayType) { /* - * with -nocase or -length we have to check true char length - * as it could be smaller than expected + * 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... :^) */ - - length1 = Tcl_NumUtfChars(string1, length1); - length2 = Tcl_NumUtfChars(string2, length2); - length = (length1 < length2) ? length1 : length2; - + string1 = (char*) Tcl_GetByteArrayFromObj(objv[0], &length1); + string2 = (char*) Tcl_GetByteArrayFromObj(objv[1], &length2); + strCmpFn = memcmp; + } else if ((objv[0]->typePtr == &tclStringType) + && (objv[1]->typePtr == &tclStringType)) { /* - * Do the reqlength check again, against 0 as well for - * the benfit of nocase + * Do a unicode-specific comparison if both of the args + * are of String type. In benchmark testing this proved + * the most efficient check between the unicode and + * string comparison operations. */ + string1 = (char*) Tcl_GetUnicodeFromObj(objv[0], &length1); + string2 = (char*) Tcl_GetUnicodeFromObj(objv[1], &length2); + strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp; + } else { + /* + * As a catch-all we will work with UTF-8. We cannot use + * memcmp() as that is unsafe with any string containing + * NULL (\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. + */ + string1 = (char*) Tcl_GetStringFromObj(objv[0], &length1); + string2 = (char*) Tcl_GetStringFromObj(objv[1], &length2); + if ((reqlength < 0) && !nocase) { + strCmpFn = TclpUtfNcmp2; + } else { + length1 = Tcl_NumUtfChars(string1, length1); + length2 = Tcl_NumUtfChars(string2, length2); + strCmpFn = nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp; + } + } - if ((reqlength > 0) && (reqlength < length)) { + if (((enum options) index == STR_EQUAL) + && (reqlength < 0) && (length1 != length2)) { + match = 1; /* this will be reversed below */ + } else { + length = (length1 < length2) ? length1 : length2; + if (reqlength > 0 && reqlength < length) { length = reqlength; } else if (reqlength < 0) { /* * The requested length is negative, so we ignore it by - * setting it to the longer of the two lengths. + * setting it to length + 1 so we correct the match var. */ - - reqlength = (length1 > length2) ? length1 : length2; - } - if (nocase) { - match = Tcl_UtfNcasecmp(string1, string2, - (unsigned) length); - } else { - match = Tcl_UtfNcmp(string1, string2, (unsigned) length); + reqlength = length + 1; } + match = strCmpFn(string1, string2, (unsigned) length); if ((match == 0) && (reqlength > length)) { match = length1 - length2; } - } else { - match = memcmp(string1, string2, (unsigned) length); - if (match == 0) { - match = length1 - length2; - } } if ((enum options) index == STR_EQUAL) { @@ -1103,91 +1325,79 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) break; } case STR_FIRST: { - register char *p, *end; - int match, utflen, start; + Tcl_UniChar *ustring1, *ustring2; + int match, start; if (objc < 4 || objc > 5) { Tcl_WrongNumArgs(interp, 2, objv, - "string1 string2 ?startIndex?"); + "subString string ?startIndex?"); return TCL_ERROR; } /* - * This algorithm fails on improperly formed UTF strings. * We are searching string2 for the sequence string1. */ match = -1; start = 0; - utflen = -1; - string1 = Tcl_GetStringFromObj(objv[2], &length1); - string2 = Tcl_GetStringFromObj(objv[3], &length2); + length2 = -1; + + ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1); + ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2); if (objc == 5) { /* - * If a startIndex is specified, we will need to fast forward - * to that point in the string before we think about a match + * If a startIndex is specified, we will need to fast + * forward to that point in the string before we think + * about a match */ - utflen = Tcl_NumUtfChars(string2, length2); - if (TclGetIntForIndex(interp, objv[4], utflen-1, - &start) != TCL_OK) { + if (TclGetIntForIndex(interp, objv[4], length2 - 1, + &start) != TCL_OK) { return TCL_ERROR; } - if (start >= utflen) { + if (start >= length2) { goto str_first_done; } else if (start > 0) { - if (length2 == utflen) { - /* no unicode chars */ - string2 += start; - length2 -= start; - } else { - char *s = Tcl_UtfAtIndex(string2, start); - length2 -= s - string2; - string2 = s; - } + ustring2 += start; + length2 -= start; + } else if (start < 0) { + /* + * Invalid start index mapped to string start; + * Bug #423581 + */ + start = 0; } } if (length1 > 0) { - end = string2 + length2 - length1 + 1; - for (p = string2; p < end; p++) { + register Tcl_UniChar *p, *end; + + end = ustring2 + length2 - length1 + 1; + for (p = ustring2; p < end; p++) { /* * Scan forward to find the first character. */ - - p = memchr(p, *string1, (unsigned) (end - p)); - if (p == NULL) { - break; - } - if (memcmp(string1, p, (unsigned) length1) == 0) { - match = p - string2; + if ((*p == *ustring1) && + (TclUniCharNcmp(ustring1, p, + (unsigned long) length1) == 0)) { + match = p - ustring2; break; } } } - /* * Compute the character index of the matching string by * counting the number of characters before the match. */ - str_first_done: - if (match != -1) { - if (objc == 4) { - match = Tcl_NumUtfChars(string2, match); - } else if (length2 == utflen) { - /* no unicode chars */ - match += start; - } else { - match = start + Tcl_NumUtfChars(string2, match); - } + if ((match != -1) && (objc == 5)) { + match += start; } + + str_first_done: Tcl_SetIntObj(resultPtr, match); break; } case STR_INDEX: { - char buf[TCL_UTF_MAX]; - Tcl_UniChar unichar; - if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "string charIndex"); return TCL_ERROR; @@ -1201,33 +1411,33 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) */ if (objv[2]->typePtr == &tclByteArrayType) { - - string1 = (char *)Tcl_GetByteArrayFromObj(objv[2], &length1); + string1 = (char *) Tcl_GetByteArrayFromObj(objv[2], &length1); if (TclGetIntForIndex(interp, objv[3], length1 - 1, &index) != TCL_OK) { return TCL_ERROR; } - Tcl_SetByteArrayObj(resultPtr, - (unsigned char *)(&string1[index]), 1); + if ((index >= 0) && (index < length1)) { + Tcl_SetByteArrayObj(resultPtr, + (unsigned char *)(&string1[index]), 1); + } } else { - string1 = Tcl_GetStringFromObj(objv[2], &length1); - /* - * convert to Unicode internal rep to calulate what - * 'end' really means. + * Get Unicode char length to calulate what 'end' means. */ + length1 = Tcl_GetCharLength(objv[2]); - length2 = Tcl_GetCharLength(objv[2]); - - if (TclGetIntForIndex(interp, objv[3], length2 - 1, + if (TclGetIntForIndex(interp, objv[3], length1 - 1, &index) != TCL_OK) { return TCL_ERROR; } - if ((index >= 0) && (index < length2)) { - unichar = Tcl_GetUniChar(objv[2], index); - length2 = Tcl_UniCharToUtf((int)unichar, buf); - Tcl_SetStringObj(resultPtr, buf, length2); + if ((index >= 0) && (index < length1)) { + char buf[TCL_UTF_MAX]; + Tcl_UniChar ch; + + ch = Tcl_GetUniChar(objv[2], index); + length1 = Tcl_UniCharToUtf(ch, buf); + Tcl_SetStringObj(resultPtr, buf, length1); } } break; @@ -1244,7 +1454,7 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) int i, failat = 0, result = 1, strict = 0; Tcl_Obj *objPtr, *failVarObj = NULL; - static char *isOptions[] = { + static CONST char *isOptions[] = { "alnum", "alpha", "ascii", "control", "boolean", "digit", "double", "false", "graph", "integer", "lower", "print", @@ -1275,7 +1485,8 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) strncmp(string2, "-strict", (size_t) length2) == 0) { strict = 1; } else if ((length2 > 1) && - strncmp(string2, "-failindex", (size_t) length2) == 0) { + strncmp(string2, "-failindex", + (size_t) length2) == 0) { if (i+1 >= objc-1) { Tcl_WrongNumArgs(interp, 3, objv, "?-strict? ?-failindex var? str"); @@ -1375,7 +1586,11 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) */ if (TclLooksLikeInt(string1, length1)) { errno = 0; - strtoul(string1, &stop, 0); +#ifdef TCL_WIDE_INT_IS_LONG + strtoul(string1, &stop, 0); /* INTL: Tcl source. */ +#else + strtoull(string1, &stop, 0); /* INTL: Tcl source. */ +#endif if (stop == end) { if (errno == ERANGE) { result = 0; @@ -1429,7 +1644,11 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) */ result = 0; errno = 0; +#ifdef TCL_WIDE_INT_IS_LONG strtoul(string1, &stop, 0); /* INTL: Tcl source. */ +#else + strtoull(string1, &stop, 0); /* INTL: Tcl source. */ +#endif if (errno == ERANGE) { /* * if (errno == ERANGE), then it was an over/underflow @@ -1508,78 +1727,61 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) break; } case STR_LAST: { - register char *p; - int match, utflen, start; + Tcl_UniChar *ustring1, *ustring2, *p; + int match, start; if (objc < 4 || objc > 5) { Tcl_WrongNumArgs(interp, 2, objv, - "string1 string2 ?startIndex?"); + "subString string ?startIndex?"); return TCL_ERROR; } /* - * This algorithm fails on improperly formed UTF strings. + * We are searching string2 for the sequence string1. */ match = -1; start = 0; - utflen = -1; - string1 = Tcl_GetStringFromObj(objv[2], &length1); - string2 = Tcl_GetStringFromObj(objv[3], &length2); + length2 = -1; + + ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1); + ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2); if (objc == 5) { /* * If a startIndex is specified, we will need to restrict * the string range to that char index in the string */ - utflen = Tcl_NumUtfChars(string2, length2); - if (TclGetIntForIndex(interp, objv[4], utflen-1, - &start) != TCL_OK) { + if (TclGetIntForIndex(interp, objv[4], length2 - 1, + &start) != TCL_OK) { return TCL_ERROR; } if (start < 0) { goto str_last_done; - } else if (start < utflen) { - if (length2 == utflen) { - /* no unicode chars */ - p = string2 + start + 1 - length1; - } else { - p = Tcl_UtfAtIndex(string2, start+1) - length1; - } + } else if (start < length2) { + p = ustring2 + start + 1 - length1; } else { - p = string2 + length2 - length1; + p = ustring2 + length2 - length1; } } else { - p = string2 + length2 - length1; + p = ustring2 + length2 - length1; } if (length1 > 0) { - for (; p >= string2; p--) { + for (; p >= ustring2; p--) { /* * Scan backwards to find the first character. */ - - while ((p != string2) && (*p != *string1)) { - p--; - } - if (memcmp(string1, p, (unsigned) length1) == 0) { - match = p - string2; + if ((*p == *ustring1) && + (memcmp((char *) ustring1, (char *) p, (size_t) + (length1 * sizeof(Tcl_UniChar))) == 0)) { + match = p - ustring2; break; } } } - /* - * Compute the character index of the matching string by counting - * the number of characters before the match. - */ - str_last_done: - if (match != -1) { - if ((objc == 4) || (length2 != utflen)) { - /* only check when we've got unicode chars */ - match = Tcl_NumUtfChars(string2, match); - } - } + str_last_done: Tcl_SetIntObj(resultPtr, match); break; } @@ -1592,7 +1794,6 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) if ((enum options) index == STR_BYTELENGTH) { (void) Tcl_GetStringFromObj(objv[2], &length1); - Tcl_SetIntObj(resultPtr, length1); } else { /* * If we have a ByteArray object, avoid recomputing the @@ -1603,20 +1804,19 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) if (objv[2]->typePtr == &tclByteArrayType) { (void) Tcl_GetByteArrayFromObj(objv[2], &length1); - Tcl_SetIntObj(resultPtr, length1); } else { - Tcl_SetIntObj(resultPtr, - Tcl_GetCharLength(objv[2])); + length1 = Tcl_GetCharLength(objv[2]); } } + Tcl_SetIntObj(resultPtr, length1); break; } case STR_MAP: { - int uselen, mapElemc, len, nocase = 0; + int mapElemc, nocase = 0; Tcl_Obj **mapElemv; - char *end; - Tcl_UniChar ch; - int (*str_comp_fn)(); + Tcl_UniChar *ustring1, *ustring2, *p, *end; + int (*strCmpFn)_ANSI_ARGS_((CONST Tcl_UniChar*, + CONST Tcl_UniChar*, unsigned long)); if (objc < 4 || objc > 5) { Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? charMap string"); @@ -1645,6 +1845,7 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) * empty charMap, just return whatever string was given */ Tcl_SetObjResult(interp, objv[objc-1]); + return TCL_OK; } else if (mapElemc & 1) { /* * The charMap must be an even number of key/value items @@ -1652,63 +1853,131 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) Tcl_SetStringObj(resultPtr, "char map list unbalanced", -1); return TCL_ERROR; } - string1 = Tcl_GetStringFromObj(objv[objc-1], &length1); + objc--; + + ustring1 = Tcl_GetUnicodeFromObj(objv[objc], &length1); if (length1 == 0) { + /* + * Empty input string, just stop now + */ break; } - end = string1 + length1; + end = ustring1 + length1; - if (nocase) { - length1 = Tcl_NumUtfChars(string1, length1); - str_comp_fn = Tcl_UtfNcasecmp; - } else { - str_comp_fn = memcmp; - } + strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp; - for ( ; string1 < end; string1 += len) { - len = Tcl_UtfToUniChar(string1, &ch); - for (index = 0; index < mapElemc; index +=2) { - /* - * Get the key string to match on - */ - string2 = Tcl_GetStringFromObj(mapElemv[index], - &length2); - if (nocase) { - uselen = Tcl_NumUtfChars(string2, length2); - } else { - uselen = length2; + /* + * Force result to be Unicode + */ + Tcl_SetUnicodeObj(resultPtr, ustring1, 0); + + if (mapElemc == 2) { + /* + * Special case for one map pair which avoids the extra + * for loop and extra calls to get Unicode data. The + * algorithm is otherwise identical to the multi-pair case. + * This will be >30% faster on larger strings. + */ + int mapLen; + Tcl_UniChar *mapString, u2lc; + + ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2); + p = ustring1; + if (length2 == 0) { + ustring1 = end; + } else { + mapString = Tcl_GetUnicodeFromObj(mapElemv[1], &mapLen); + u2lc = (nocase ? Tcl_UniCharToLower(*ustring2) : 0); + for (; ustring1 < end; ustring1++) { + if (((*ustring1 == *ustring2) || + (nocase && (Tcl_UniCharToLower(*ustring1) == + u2lc))) && + ((length2 == 1) || strCmpFn(ustring1, ustring2, + (unsigned long) length2) == 0)) { + if (p != ustring1) { + Tcl_AppendUnicodeToObj(resultPtr, p, + ustring1 - p); + p = ustring1 + length2; + } else { + p += length2; + } + ustring1 = p - 1; + + Tcl_AppendUnicodeToObj(resultPtr, mapString, + mapLen); + } } - if ((uselen > 0) && (uselen <= length1) && - (str_comp_fn(string2, string1, uselen) == 0)) { - /* - * Adjust len to be full length of matched string - * it has to be the BYTE length - */ - len = length2; + } + } else { + Tcl_UniChar **mapStrings, *u2lc = NULL; + int *mapLens; + /* + * Precompute pointers to the unicode string and length. + * This saves us repeated function calls later, + * significantly speeding up the algorithm. We only need + * the lowercase first char in the nocase case. + */ + mapStrings = (Tcl_UniChar **) ckalloc((mapElemc * 2) + * sizeof(Tcl_UniChar *)); + mapLens = (int *) ckalloc((mapElemc * 2) * sizeof(int)); + if (nocase) { + u2lc = (Tcl_UniChar *) + ckalloc((mapElemc) * sizeof(Tcl_UniChar)); + } + for (index = 0; index < mapElemc; index++) { + mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index], + &(mapLens[index])); + if (nocase && ((index % 2) == 0)) { + u2lc[index/2] = Tcl_UniCharToLower(*mapStrings[index]); + } + } + for (p = ustring1; ustring1 < end; ustring1++) { + for (index = 0; index < mapElemc; index += 2) { /* - * Change string2 and length2 to the map value + * Get the key string to match on. */ - string2 = Tcl_GetStringFromObj(mapElemv[index+1], - &length2); - Tcl_AppendToObj(resultPtr, string2, length2); - break; + ustring2 = mapStrings[index]; + length2 = mapLens[index]; + if ((length2 > 0) && ((*ustring1 == *ustring2) || + (nocase && (Tcl_UniCharToLower(*ustring1) == + u2lc[index/2]))) && + ((length2 == 1) || strCmpFn(ustring2, ustring1, + (unsigned long) length2) == 0)) { + if (p != ustring1) { + /* + * Put the skipped chars onto the result first + */ + Tcl_AppendUnicodeToObj(resultPtr, p, + ustring1 - p); + p = ustring1 + length2; + } else { + p += length2; + } + /* + * Adjust len to be full length of matched string + */ + ustring1 = p - 1; + + /* + * Append the map value to the unicode string + */ + Tcl_AppendUnicodeToObj(resultPtr, + mapStrings[index+1], mapLens[index+1]); + break; + } } } - if (index == mapElemc) { - /* - * No match was found, put the char onto result - */ - Tcl_AppendToObj(resultPtr, string1, len); + ckfree((char *) mapStrings); + ckfree((char *) mapLens); + if (nocase) { + ckfree((char *) u2lc); } + } + if (p != ustring1) { /* - * in nocase, length1 is in chars - * otherwise it is in bytes + * Put the rest of the unmapped chars onto result */ - if (nocase) { - length1--; - } else { - length1 -= len; - } + Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p); } break; } @@ -1734,9 +2003,8 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) } Tcl_SetBooleanObj(resultPtr, - Tcl_StringCaseMatch(Tcl_GetString(objv[objc-1]), - Tcl_GetString(objv[objc-2]), - nocase)); + Tcl_UniCharCaseMatch(Tcl_GetUnicode(objv[objc-1]), + Tcl_GetUnicode(objv[objc-2]), nocase)); break; } case STR_RANGE: { @@ -1748,64 +2016,24 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) } /* - * If we have a ByteArray object, avoid indexing in the - * Utf string since the byte array contains one byte per - * character. Otherwise, use the Unicode string rep to - * get the range. + * Get the length in actual characters. */ + length1 = Tcl_GetCharLength(objv[2]) - 1; - if (objv[2]->typePtr == &tclByteArrayType) { - - string1 = (char *)Tcl_GetByteArrayFromObj(objv[2], &length1); - - if (TclGetIntForIndex(interp, objv[3], length1 - 1, - &first) != TCL_OK) { - return TCL_ERROR; - } - if (TclGetIntForIndex(interp, objv[4], length1 - 1, - &last) != TCL_OK) { - return TCL_ERROR; - } - if (first < 0) { - first = 0; - } - if (last >= length1 - 1) { - last = length1 - 1; - } - if (last >= first) { - int numBytes = last - first + 1; - resultPtr = Tcl_NewByteArrayObj( - (unsigned char *) &string1[first], numBytes); - Tcl_SetObjResult(interp, resultPtr); - } - } else { - string1 = Tcl_GetStringFromObj(objv[2], &length1); - - /* - * Convert to Unicode internal rep to calulate length and - * create a result object. - */ + if ((TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK) + || (TclGetIntForIndex(interp, objv[4], length1, + &last) != TCL_OK)) { + return TCL_ERROR; + } - length2 = Tcl_GetCharLength(objv[2]) - 1; - - if (TclGetIntForIndex(interp, objv[3], length2, - &first) != TCL_OK) { - return TCL_ERROR; - } - if (TclGetIntForIndex(interp, objv[4], length2, - &last) != TCL_OK) { - return TCL_ERROR; - } - if (first < 0) { - first = 0; - } - if (last >= length2) { - last = length2; - } - if (last >= first) { - resultPtr = Tcl_GetRange(objv[2], first, last); - Tcl_SetObjResult(interp, resultPtr); - } + if (first < 0) { + first = 0; + } + if (last >= length1) { + last = length1; + } + if (last >= first) { + Tcl_SetObjResult(interp, Tcl_GetRange(objv[2], first, last)); } break; } @@ -1821,15 +2049,41 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } - string1 = Tcl_GetStringFromObj(objv[2], &length1); - if (length1 > 0) { - for (index = 0; index < count; index++) { - Tcl_AppendToObj(resultPtr, string1, length1); + if (count == 1) { + Tcl_SetObjResult(interp, objv[2]); + } else if (count > 1) { + string1 = Tcl_GetStringFromObj(objv[2], &length1); + if (length1 > 0) { + /* + * 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. + */ + length2 = length1 * count; + /* + * Include space for the NULL + */ + string2 = (char *) ckalloc((size_t) length2+1); + for (index = 0; index < count; index++) { + memcpy(string2 + (length1 * index), string1, + (size_t) length1); + } + 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. + */ + resultPtr = Tcl_NewObj(); + resultPtr->bytes = string2; + resultPtr->length = length2; + Tcl_SetObjResult(interp, resultPtr); } } break; } case STR_REPLACE: { + Tcl_UniChar *ustring1; int first, last; if (objc < 5 || objc > 6) { @@ -1838,33 +2092,29 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } - string1 = Tcl_GetStringFromObj(objv[2], &length1); - length1 = Tcl_NumUtfChars(string1, length1) - 1; - if (TclGetIntForIndex(interp, objv[3], length1, - &first) != TCL_OK) { - return TCL_ERROR; - } - if (TclGetIntForIndex(interp, objv[4], length1, - &last) != TCL_OK) { + ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1); + length1--; + + if ((TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK) + || (TclGetIntForIndex(interp, objv[4], length1, + &last) != TCL_OK)) { return TCL_ERROR; } - if ((last < first) || (first > length1) || (last < 0)) { + + if ((last < first) || (last < 0) || (first > length1)) { Tcl_SetObjResult(interp, objv[2]); } else { - char *start, *end; - if (first < 0) { first = 0; } - start = Tcl_UtfAtIndex(string1, first); - end = Tcl_UtfAtIndex(start, ((last > length1) ? length1 : last) - - first + 1); - Tcl_SetStringObj(resultPtr, string1, start - string1); + + Tcl_SetUnicodeObj(resultPtr, ustring1, first); if (objc == 6) { Tcl_AppendObjToObj(resultPtr, objv[5]); } if (last < length1) { - Tcl_AppendToObj(resultPtr, end, -1); + Tcl_AppendUnicodeToObj(resultPtr, ustring1 + last + 1, + length1 - last); } } break; @@ -1898,7 +2148,7 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) Tcl_SetObjLength(resultPtr, length1); } else { int first, last; - char *start, *end; + CONST char *start, *end; length1 = Tcl_NumUtfChars(string1, length1) - 1; if (TclGetIntForIndex(interp, objv[3], length1, @@ -1942,7 +2192,7 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) case STR_TRIM: { Tcl_UniChar ch, trim; - register char *p, *end; + register CONST char *p, *end; char *check, *checkEnd; int offset; @@ -2031,7 +2281,7 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) case STR_WORDEND: { int cur; Tcl_UniChar ch; - char *p, *end; + CONST char *p, *end; int numChars; if (objc != 4) { @@ -2069,7 +2319,7 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) case STR_WORDSTART: { int cur; Tcl_UniChar ch; - char *p; + CONST char *p; int numChars; if (objc != 4) { @@ -2114,8 +2364,7 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) * * This procedure is invoked to process the "subst" Tcl command. * See the user documentation for details on what it does. This - * command is an almost direct copy of an implementation by - * Andrew Payne. + * command relies on Tcl_SubstObj() for its implementation. * * Results: * A standard Tcl result. @@ -2134,27 +2383,21 @@ Tcl_SubstObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - static char *substOptions[] = { + static CONST char *substOptions[] = { "-nobackslashes", "-nocommands", "-novariables", (char *) NULL }; enum substOptions { SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS }; - Interp *iPtr = (Interp *) interp; - Tcl_DString result; - char *p, *old, *value; - int optionIndex, code, count, doVars, doCmds, doBackslashes, i; + Tcl_Obj *resultPtr; + int optionIndex, flags, i; /* * Parse command-line options. */ - doVars = doCmds = doBackslashes = 1; + flags = TCL_SUBST_ALL; for (i = 1; i < (objc-1); i++) { - p = Tcl_GetString(objv[i]); - if (*p != '-') { - break; - } if (Tcl_GetIndexFromObj(interp, objv[i], substOptions, "switch", 0, &optionIndex) != TCL_OK) { @@ -2162,15 +2405,15 @@ Tcl_SubstObjCmd(dummy, interp, objc, objv) } switch (optionIndex) { case SUBST_NOBACKSLASHES: { - doBackslashes = 0; + flags &= ~TCL_SUBST_BACKSLASHES; break; } case SUBST_NOCOMMANDS: { - doCmds = 0; + flags &= ~TCL_SUBST_COMMANDS; break; } case SUBST_NOVARS: { - doVars = 0; + flags &= ~TCL_SUBST_VARIABLES; break; } default: { @@ -2185,76 +2428,168 @@ Tcl_SubstObjCmd(dummy, interp, objc, objv) } /* - * Scan through the string one character at a time, performing - * command, variable, and backslash substitutions. + * Perform the substitution. */ + resultPtr = Tcl_SubstObj(interp, objv[i], flags); - Tcl_DStringInit(&result); - old = p = Tcl_GetString(objv[i]); - while (*p != 0) { + if (resultPtr == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SubstObj -- + * + * This function performs the substitutions specified on the + * given string as described in the user documentation for the + * "subst" Tcl command. This code is heavily based on an + * implementation by Andrew Payne. Note that if a command + * substitution returns TCL_CONTINUE or TCL_RETURN from its + * evaluation and is not completely well-formed, the results are + * not defined (or at least hard to characterise.) This fault + * will be fixed at some point, but the cost of the only sane + * fix (well-formedness check first) is such that you need to + * "precompile and cache" to stop everyone from being hit with + * the consequences every time through. Note that the current + * behaviour is not a security hole; it just restarts parsing + * the string following the substitution in a mildly surprising + * place, and it is a very bad idea to count on this remaining + * the same in future... + * + * Results: + * A Tcl_Obj* containing the substituted string, or NULL to + * indicate that an error occurred. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +Tcl_SubstObj(interp, objPtr, flags) + Tcl_Interp *interp; + Tcl_Obj *objPtr; + int flags; +{ + Tcl_Obj *resultObj; + char *p, *old; + + old = p = Tcl_GetString(objPtr); + resultObj = Tcl_NewStringObj("", 0); + while (1) { switch (*p) { - case '\\': - if (doBackslashes) { - char buf[TCL_UTF_MAX]; + case 0: + if (p != old) { + Tcl_AppendToObj(resultObj, old, p-old); + } + return resultObj; - if (p != old) { - Tcl_DStringAppend(&result, old, p-old); - } - Tcl_DStringAppend(&result, buf, - Tcl_UtfBackslash(p, &count, buf)); - p += count; - old = p; - } else { - p++; + case '\\': + if (flags & TCL_SUBST_BACKSLASHES) { + char buf[TCL_UTF_MAX]; + int count; + + if (p != old) { + Tcl_AppendToObj(resultObj, old, p-old); } - break; + Tcl_AppendToObj(resultObj, buf, + Tcl_UtfBackslash(p, &count, buf)); + p += count; + old = p; + } else { + p++; + } + break; - case '$': - if (doVars) { - if (p != old) { - Tcl_DStringAppend(&result, old, p-old); - } - value = Tcl_ParseVar(interp, p, &p); - if (value == NULL) { - Tcl_DStringFree(&result); - return TCL_ERROR; - } - Tcl_DStringAppend(&result, value, -1); - old = p; - } else { + case '$': + if (flags & TCL_SUBST_VARIABLES) { + Tcl_Parse parse; + int code; + + /* + * Code is simpler overall if we (effectively) inline + * Tcl_ParseVar, particularly as that allows us to use + * a non-string interface when we come to appending + * the variable contents to the result object. There + * are a few other optimisations that doing this + * enables (like being able to continue the run of + * unsubstituted characters straight through if a '$' + * does not precede a variable name.) + */ + if (Tcl_ParseVarName(interp, p, -1, &parse, 0) != TCL_OK) { + goto errorResult; + } + if (parse.numTokens == 1) { + /* + * There isn't a variable name after all: the $ is + * just a $. + */ p++; + break; } - break; - - case '[': - if (doCmds) { - if (p != old) { - Tcl_DStringAppend(&result, old, p-old); - } - iPtr->evalFlags = TCL_BRACKET_TERM; - code = Tcl_Eval(interp, p+1); - if (code == TCL_ERROR) { - Tcl_DStringFree(&result); - return code; - } - old = p = (p+1 + iPtr->termOffset+1); - Tcl_DStringAppend(&result, iPtr->result, -1); + if (p != old) { + Tcl_AppendToObj(resultObj, old, p-old); + } + p += parse.tokenPtr->size; + code = Tcl_EvalTokensStandard(interp, parse.tokenPtr, + parse.numTokens); + if (code == TCL_ERROR) { + goto errorResult; + } + if (code == TCL_BREAK) { Tcl_ResetResult(interp); - } else { - p++; + return resultObj; } - break; + if (code != TCL_CONTINUE) { + Tcl_AppendObjToObj(resultObj, Tcl_GetObjResult(interp)); + } + Tcl_ResetResult(interp); + old = p; + } else { + p++; + } + break; + + case '[': + if (flags & TCL_SUBST_COMMANDS) { + Interp *iPtr = (Interp *) interp; + int code; - default: + if (p != old) { + Tcl_AppendToObj(resultObj, old, p-old); + } + iPtr->evalFlags = TCL_BRACKET_TERM; + code = Tcl_EvalEx(interp, p+1, -1, 0); + switch (code) { + case TCL_ERROR: + goto errorResult; + case TCL_BREAK: + Tcl_ResetResult(interp); + return resultObj; + default: + Tcl_AppendObjToObj(resultObj, Tcl_GetObjResult(interp)); + case TCL_CONTINUE: + Tcl_ResetResult(interp); + old = p = (p+1 + iPtr->termOffset + 1); + } + } else { p++; - break; + } + break; + default: + p++; + break; } } - if (p != old) { - Tcl_DStringAppend(&result, old, p-old); - } - Tcl_DStringResult(interp, &result); - return TCL_OK; + + errorResult: + Tcl_DecrRefCount(resultObj); + return NULL; } /* @@ -2282,10 +2617,11 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int i, j, index, mode, matched, result, splitObjs, seenComment; + int i, j, index, mode, matched, result, splitObjs; char *string, *pattern; Tcl_Obj *stringObj; - static char *options[] = { + Tcl_Obj *CONST *savedObjv = objv; + static CONST char *options[] = { "-exact", "-glob", "-regexp", "--", NULL }; @@ -2332,46 +2668,72 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) if (Tcl_ListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) { return TCL_ERROR; } - objv = listv; - splitObjs = 1; - } - seenComment = 0; - for (i = 0; i < objc; i += 2) { - if (i == objc - 1) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "extra switch pattern with no body", -1); - - /* - * Check if this can be due to a badly placed comment - * in the switch block - */ - - if (splitObjs && seenComment) { - Tcl_AppendToObj(Tcl_GetObjResult(interp), - ", this may be due to a comment incorrectly placed outside of a switch body - see the \"switch\" documentation", -1); - } + /* + * Ensure that the list is non-empty. + */ + if (objc < 1) { + Tcl_WrongNumArgs(interp, 1, savedObjv, + "?switches? string {pattern body ... ?default body?}"); return TCL_ERROR; } + objv = listv; + splitObjs = 1; + } - /* - * See if the pattern matches the string. - */ + /* + * Complain if there is an odd number of words in the list of + * patterns and bodies. + */ - pattern = Tcl_GetString(objv[i]); + if (objc % 2) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "extra switch pattern with no body", NULL); /* + * Check if this can be due to a badly placed comment + * in the switch block. + * * The following is an heuristic to detect the infamous * "comment in switch" error: just check if a pattern * begins with '#'. */ - if (splitObjs && *pattern == '#') { - seenComment = 1; + if (splitObjs) { + for (i=0 ; i<objc ; i+=2) { + if (Tcl_GetString(objv[i])[0] == '#') { + Tcl_AppendResult(interp, ", this may be due to a ", + "comment incorrectly placed outside of a ", + "switch body - see the \"switch\" ", + "documentation", NULL); + break; + } + } } + return TCL_ERROR; + } + + /* + * Complain if the last body is a continuation. Note that this + * check assumes that the list is non-empty! + */ + + if (strcmp(Tcl_GetString(objv[objc-1]), "-") == 0) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "no body specified for pattern \"", + Tcl_GetString(objv[objc-2]), "\"", NULL); + return TCL_ERROR; + } + + for (i = 0; i < objc; i += 2) { + /* + * See if the pattern matches the string. + */ + + pattern = Tcl_GetString(objv[i]); + matched = 0; if ((i == objc - 2) && (*pattern == 'd') @@ -2405,10 +2767,11 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) for (j = i + 1; ; j += 2) { if (j >= objc) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "no body specified for pattern \"", pattern, - "\"", (char *) NULL); - return TCL_ERROR; + /* + * This shouldn't happen since we've checked that the + * last body is not a continuation... + */ + panic("fall-out when searching for body to match pattern"); } if (strcmp(Tcl_GetString(objv[j]), "-") != 0) { break; @@ -2473,17 +2836,17 @@ Tcl_TimeObjCmd(dummy, interp, objc, objv) objPtr = objv[1]; i = count; - TclpGetTime(&start); + Tcl_GetTime(&start); while (i-- > 0) { result = Tcl_EvalObjEx(interp, objPtr, 0); if (result != TCL_OK) { return result; } } - TclpGetTime(&stop); + Tcl_GetTime(&stop); - totalMicroSec = - (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); + totalMicroSec = ( ( (double) ( stop.sec - start.sec ) ) * 1.0e6 + + ( stop.usec - start.usec ) ); sprintf(buf, "%.0f microseconds per iteration", ((count <= 0) ? 0 : totalMicroSec/count)); Tcl_ResetResult(interp); @@ -2498,13 +2861,17 @@ Tcl_TimeObjCmd(dummy, interp, objc, objv) * * This procedure is invoked to process the "trace" Tcl command. * See the user documentation for details on what it does. + * + * Standard syntax as of Tcl 8.4 is + * + * trace {add|info|remove} {command|variable} name ops cmd + * * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. - * *---------------------------------------------------------------------- */ @@ -2517,17 +2884,26 @@ Tcl_TraceObjCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { int optionIndex, commandLength; - char *name, *rwuOps, *command, *p; + char *name, *flagOps, *command, *p; size_t length; - static char *traceOptions[] = { - "variable", "vdelete", "vinfo", (char *) NULL + /* Main sub commands to 'trace' */ + static CONST char *traceOptions[] = { + "add", "info", "remove", +#ifndef TCL_REMOVE_OBSOLETE_TRACES + "variable", "vdelete", "vinfo", +#endif + (char *) NULL }; + /* 'OLD' options are pre-Tcl-8.4 style */ enum traceOptions { - TRACE_VARIABLE, TRACE_VDELETE, TRACE_VINFO + TRACE_ADD, TRACE_INFO, TRACE_REMOVE, +#ifndef TCL_REMOVE_OBSOLETE_TRACES + TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO +#endif }; if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option [arg arg ...]"); + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); return TCL_ERROR; } @@ -2536,162 +2912,1497 @@ Tcl_TraceObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } switch ((enum traceOptions) optionIndex) { - case TRACE_VARIABLE: { - int flags; - TraceVarInfo *tvarPtr; - if (objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "name ops command"); + case TRACE_ADD: + case TRACE_REMOVE: + case TRACE_INFO: { + /* + * All sub commands of trace add/remove must take at least + * one more argument. Beyond that we let the subcommand itself + * control the argument structure. + */ + int typeIndex; + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "type ?arg arg ...?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[2], traceTypeOptions, + "option", 0, &typeIndex) != TCL_OK) { + return TCL_ERROR; + } + return (traceSubCmds[typeIndex])(interp, optionIndex, objc, objv); + break; + } +#ifndef TCL_REMOVE_OBSOLETE_TRACES + case TRACE_OLD_VARIABLE: { + int flags; + TraceVarInfo *tvarPtr; + if (objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, "name ops command"); + return TCL_ERROR; + } + + flags = 0; + flagOps = Tcl_GetString(objv[3]); + for (p = flagOps; *p != 0; p++) { + if (*p == 'r') { + flags |= TCL_TRACE_READS; + } else if (*p == 'w') { + flags |= TCL_TRACE_WRITES; + } else if (*p == 'u') { + flags |= TCL_TRACE_UNSETS; + } else if (*p == 'a') { + flags |= TCL_TRACE_ARRAY; + } else { + goto badVarOps; + } + } + if (flags == 0) { + goto badVarOps; + } + flags |= TCL_TRACE_OLD_STYLE; + + command = Tcl_GetStringFromObj(objv[4], &commandLength); + length = (size_t) commandLength; + tvarPtr = (TraceVarInfo *) ckalloc((unsigned) + (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + + length + 1)); + tvarPtr->flags = flags; + tvarPtr->length = length; + flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT; + strcpy(tvarPtr->command, command); + name = Tcl_GetString(objv[2]); + if (Tcl_TraceVar(interp, name, flags, TraceVarProc, + (ClientData) tvarPtr) != TCL_OK) { + ckfree((char *) tvarPtr); + return TCL_ERROR; + } + break; + } + case TRACE_OLD_VDELETE: { + int flags; + TraceVarInfo *tvarPtr; + ClientData clientData; + + if (objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, "name ops command"); + return TCL_ERROR; + } + + flags = 0; + flagOps = Tcl_GetString(objv[3]); + for (p = flagOps; *p != 0; p++) { + if (*p == 'r') { + flags |= TCL_TRACE_READS; + } else if (*p == 'w') { + flags |= TCL_TRACE_WRITES; + } else if (*p == 'u') { + flags |= TCL_TRACE_UNSETS; + } else if (*p == 'a') { + flags |= TCL_TRACE_ARRAY; + } else { + goto badVarOps; + } + } + if (flags == 0) { + goto badVarOps; + } + flags |= TCL_TRACE_OLD_STYLE; + + /* + * Search through all of our traces on this variable to + * see if there's one with the given command. If so, then + * delete the first one that matches. + */ + + command = Tcl_GetStringFromObj(objv[4], &commandLength); + length = (size_t) commandLength; + clientData = 0; + name = Tcl_GetString(objv[2]); + while ((clientData = Tcl_VarTraceInfo(interp, name, 0, + TraceVarProc, clientData)) != 0) { + tvarPtr = (TraceVarInfo *) clientData; + if ((tvarPtr->length == length) && (tvarPtr->flags == flags) + && (strncmp(command, tvarPtr->command, + (size_t) length) == 0)) { + Tcl_UntraceVar2(interp, name, NULL, + flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT, + TraceVarProc, clientData); + Tcl_EventuallyFree((ClientData) tvarPtr, TCL_DYNAMIC); + break; + } + } + break; + } + case TRACE_OLD_VINFO: { + ClientData clientData; + char ops[5]; + Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "name"); + return TCL_ERROR; + } + resultListPtr = Tcl_GetObjResult(interp); + clientData = 0; + name = Tcl_GetString(objv[2]); + while ((clientData = Tcl_VarTraceInfo(interp, name, 0, + TraceVarProc, clientData)) != 0) { + + TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; + + pairObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + p = ops; + if (tvarPtr->flags & TCL_TRACE_READS) { + *p = 'r'; + p++; + } + if (tvarPtr->flags & TCL_TRACE_WRITES) { + *p = 'w'; + p++; + } + if (tvarPtr->flags & TCL_TRACE_UNSETS) { + *p = 'u'; + p++; + } + if (tvarPtr->flags & TCL_TRACE_ARRAY) { + *p = 'a'; + p++; + } + *p = '\0'; + + /* + * Build a pair (2-item list) with the ops string as + * the first obj element and the tvarPtr->command string + * as the second obj element. Append the pair (as an + * element) to the end of the result object list. + */ + + elemObjPtr = Tcl_NewStringObj(ops, -1); + Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr); + elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1); + Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr); + Tcl_ListObjAppendElement(interp, resultListPtr, pairObjPtr); + } + Tcl_SetObjResult(interp, resultListPtr); + break; + } +#endif /* TCL_REMOVE_OBSOLETE_TRACES */ + } + return TCL_OK; + + badVarOps: + Tcl_AppendResult(interp, "bad operations \"", flagOps, + "\": should be one or more of rwua", (char *) NULL); + return TCL_ERROR; +} + + +/* + *---------------------------------------------------------------------- + * + * TclTraceExecutionObjCmd -- + * + * Helper function for Tcl_TraceObjCmd; implements the + * [trace {add|remove|info} execution ...] subcommands. + * See the user documentation for details on what these do. + * + * Results: + * Standard Tcl result. + * + * Side effects: + * Depends on the operation (add, remove, or info) being performed; + * may add or remove command traces on a command. + * + *---------------------------------------------------------------------- + */ + +int +TclTraceExecutionObjCmd(interp, optionIndex, objc, objv) + Tcl_Interp *interp; /* Current interpreter. */ + int optionIndex; /* Add, info or remove */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + int commandLength, index; + char *name, *command; + size_t length; + enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE }; + static CONST char *opStrings[] = { "enter", "leave", + "enterstep", "leavestep", (char *) NULL }; + enum operations { TRACE_EXEC_ENTER, TRACE_EXEC_LEAVE, + TRACE_EXEC_ENTER_STEP, TRACE_EXEC_LEAVE_STEP }; + + switch ((enum traceOptions) optionIndex) { + case TRACE_ADD: + case TRACE_REMOVE: { + int flags = 0; + int i, listLen, result; + Tcl_Obj **elemPtrs; + if (objc != 6) { + Tcl_WrongNumArgs(interp, 3, objv, "name opList execution"); + return TCL_ERROR; + } + /* + * Make sure the ops argument is a list object; get its length and + * a pointer to its array of element pointers. + */ + + result = Tcl_ListObjGetElements(interp, objv[4], &listLen, + &elemPtrs); + if (result != TCL_OK) { + return result; + } + if (listLen == 0) { + Tcl_SetResult(interp, "bad operation list \"\": must be " + "one or more of enter, leave, enterstep, or leavestep", TCL_STATIC); + return TCL_ERROR; + } + for (i = 0; i < listLen; i++) { + if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings, + "operation", TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } + switch ((enum operations) index) { + case TRACE_EXEC_ENTER: + flags |= TCL_TRACE_ENTER_EXEC; + break; + case TRACE_EXEC_LEAVE: + flags |= TCL_TRACE_LEAVE_EXEC; + break; + case TRACE_EXEC_ENTER_STEP: + flags |= TCL_TRACE_ENTER_DURING_EXEC; + break; + case TRACE_EXEC_LEAVE_STEP: + flags |= TCL_TRACE_LEAVE_DURING_EXEC; + break; + } + } + command = Tcl_GetStringFromObj(objv[5], &commandLength); + length = (size_t) commandLength; + if ((enum traceOptions) optionIndex == TRACE_ADD) { + TraceCommandInfo *tcmdPtr; + tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned) + (sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command) + + length + 1)); + tcmdPtr->flags = flags; + tcmdPtr->stepTrace = NULL; + tcmdPtr->startLevel = 0; + tcmdPtr->length = length; + flags |= TCL_TRACE_DELETE; + if (flags & (TRACE_EXEC_ENTER_STEP | TRACE_EXEC_LEAVE_STEP)) { + flags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); + } + strcpy(tcmdPtr->command, command); + name = Tcl_GetString(objv[3]); + if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, + (ClientData) tcmdPtr) != TCL_OK) { + ckfree((char *) tcmdPtr); + return TCL_ERROR; + } + } else { + /* + * Search through all of our traces on this command to + * see if there's one with the given command. If so, then + * delete the first one that matches. + */ + + TraceCommandInfo *tcmdPtr; + ClientData clientData; + clientData = 0; + name = Tcl_GetString(objv[3]); + while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, + TraceCommandProc, clientData)) != 0) { + tcmdPtr = (TraceCommandInfo *) clientData; + /* + * In checking the 'flags' field we must remove any extraneous + * flags which may have been temporarily added by various pieces + * of the trace mechanism. + */ + if ((tcmdPtr->length == length) + && ((tcmdPtr->flags & (TCL_TRACE_ANY_EXEC | TCL_TRACE_RENAME | + TCL_TRACE_DELETE)) == flags) + && (strncmp(command, tcmdPtr->command, + (size_t) length) == 0)) { + flags |= TCL_TRACE_DELETE; + if (flags & (TRACE_EXEC_ENTER_STEP | TRACE_EXEC_LEAVE_STEP)) { + flags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); + } + Tcl_UntraceCommand(interp, name, + flags, TraceCommandProc, clientData); + if (tcmdPtr->stepTrace != NULL) { + /* + * We need to remove the interpreter-wide trace + * which we created to allow 'step' traces. + */ + Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); + tcmdPtr->stepTrace = NULL; + } + /* Postpone deletion */ + if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { + tcmdPtr->flags = 0; + } else { + Tcl_EventuallyFree((ClientData) tcmdPtr, TCL_DYNAMIC); + } + break; + } + } + } + break; + } + case TRACE_INFO: { + ClientData clientData; + Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; + if (objc != 4) { + Tcl_WrongNumArgs(interp, 3, objv, "name"); + return TCL_ERROR; + } - flags = 0; - rwuOps = Tcl_GetString(objv[3]); - for (p = rwuOps; *p != 0; p++) { - if (*p == 'r') { - flags |= TCL_TRACE_READS; - } else if (*p == 'w') { - flags |= TCL_TRACE_WRITES; - } else if (*p == 'u') { - flags |= TCL_TRACE_UNSETS; - } else { - goto badOps; + resultListPtr = Tcl_GetObjResult(interp); + clientData = 0; + name = Tcl_GetString(objv[3]); + while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, + TraceCommandProc, clientData)) != 0) { + + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; + + eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + + /* + * Build a list with the ops list as the first obj + * element and the tcmdPtr->command string as the + * second obj element. Append this list (as an + * element) to the end of the result object list. + */ + + elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + if (tcmdPtr->flags & TCL_TRACE_ENTER_EXEC) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("enter",6)); + } + if (tcmdPtr->flags & TCL_TRACE_LEAVE_EXEC) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("leave",5)); + } + if (tcmdPtr->flags & TCL_TRACE_ENTER_DURING_EXEC) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("enterstep",9)); + } + if (tcmdPtr->flags & TCL_TRACE_LEAVE_DURING_EXEC) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("leavestep",10)); + } + Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); + + elemObjPtr = Tcl_NewStringObj(tcmdPtr->command, -1); + Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); + Tcl_ListObjAppendElement(interp, resultListPtr, + eachTraceObjPtr); + } + Tcl_SetObjResult(interp, resultListPtr); + break; + } + } + return TCL_OK; +} + + +/* + *---------------------------------------------------------------------- + * + * TclTraceCommandObjCmd -- + * + * Helper function for Tcl_TraceObjCmd; implements the + * [trace {add|info|remove} command ...] subcommands. + * See the user documentation for details on what these do. + * + * Results: + * Standard Tcl result. + * + * Side effects: + * Depends on the operation (add, remove, or info) being performed; + * may add or remove command traces on a command. + * + *---------------------------------------------------------------------- + */ + +int +TclTraceCommandObjCmd(interp, optionIndex, objc, objv) + Tcl_Interp *interp; /* Current interpreter. */ + int optionIndex; /* Add, info or remove */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + int commandLength, index; + char *name, *command; + size_t length; + enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE }; + static CONST char *opStrings[] = { "delete", "rename", (char *) NULL }; + enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME }; + + switch ((enum traceOptions) optionIndex) { + case TRACE_ADD: + case TRACE_REMOVE: { + int flags = 0; + int i, listLen, result; + Tcl_Obj **elemPtrs; + if (objc != 6) { + Tcl_WrongNumArgs(interp, 3, objv, "name opList command"); + return TCL_ERROR; + } + /* + * Make sure the ops argument is a list object; get its length and + * a pointer to its array of element pointers. + */ + + result = Tcl_ListObjGetElements(interp, objv[4], &listLen, + &elemPtrs); + if (result != TCL_OK) { + return result; + } + if (listLen == 0) { + Tcl_SetResult(interp, "bad operation list \"\": must be " + "one or more of delete or rename", TCL_STATIC); + return TCL_ERROR; + } + for (i = 0; i < listLen; i++) { + if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings, + "operation", TCL_EXACT, &index) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum operations) index) { + case TRACE_CMD_RENAME: + flags |= TCL_TRACE_RENAME; + break; + case TRACE_CMD_DELETE: + flags |= TCL_TRACE_DELETE; + break; + } + } + command = Tcl_GetStringFromObj(objv[5], &commandLength); + length = (size_t) commandLength; + if ((enum traceOptions) optionIndex == TRACE_ADD) { + TraceCommandInfo *tcmdPtr; + tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned) + (sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command) + + length + 1)); + tcmdPtr->flags = flags; + tcmdPtr->stepTrace = NULL; + tcmdPtr->startLevel = 0; + tcmdPtr->length = length; + flags |= TCL_TRACE_DELETE; + strcpy(tcmdPtr->command, command); + name = Tcl_GetString(objv[3]); + if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, + (ClientData) tcmdPtr) != TCL_OK) { + ckfree((char *) tcmdPtr); + return TCL_ERROR; + } + } else { + /* + * Search through all of our traces on this command to + * see if there's one with the given command. If so, then + * delete the first one that matches. + */ + + TraceCommandInfo *tcmdPtr; + ClientData clientData; + clientData = 0; + name = Tcl_GetString(objv[3]); + while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, + TraceCommandProc, clientData)) != 0) { + tcmdPtr = (TraceCommandInfo *) clientData; + if ((tcmdPtr->length == length) + && (tcmdPtr->flags == flags) + && (strncmp(command, tcmdPtr->command, + (size_t) length) == 0)) { + Tcl_UntraceCommand(interp, name, + flags | TCL_TRACE_DELETE, + TraceCommandProc, clientData); + ckfree((char *) tcmdPtr); + break; } } - if (flags == 0) { - goto badOps; + } + break; + } + case TRACE_INFO: { + ClientData clientData; + Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; + if (objc != 4) { + Tcl_WrongNumArgs(interp, 3, objv, "name"); + return TCL_ERROR; + } + + resultListPtr = Tcl_GetObjResult(interp); + clientData = 0; + name = Tcl_GetString(objv[3]); + while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, + TraceCommandProc, clientData)) != 0) { + + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; + + eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + + /* + * Build a list with the ops list as + * the first obj element and the tcmdPtr->command string + * as the second obj element. Append this list (as an + * element) to the end of the result object list. + */ + + elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + if (tcmdPtr->flags & TCL_TRACE_RENAME) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("rename",6)); + } + if (tcmdPtr->flags & TCL_TRACE_DELETE) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("delete",6)); } + Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); + + elemObjPtr = Tcl_NewStringObj(tcmdPtr->command, -1); + Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); + Tcl_ListObjAppendElement(interp, resultListPtr, + eachTraceObjPtr); + } + Tcl_SetObjResult(interp, resultListPtr); + break; + } + } + return TCL_OK; +} - command = Tcl_GetStringFromObj(objv[4], &commandLength); - length = (size_t) commandLength; + +/* + *---------------------------------------------------------------------- + * + * TclTraceVariableObjCmd -- + * + * Helper function for Tcl_TraceObjCmd; implements the + * [trace {add|info|remove} variable ...] subcommands. + * See the user documentation for details on what these do. + * + * Results: + * Standard Tcl result. + * + * Side effects: + * Depends on the operation (add, remove, or info) being performed; + * may add or remove variable traces on a variable. + * + *---------------------------------------------------------------------- + */ + +int +TclTraceVariableObjCmd(interp, optionIndex, objc, objv) + Tcl_Interp *interp; /* Current interpreter. */ + int optionIndex; /* Add, info or remove */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + int commandLength, index; + char *name, *command; + size_t length; + enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE }; + static CONST char *opStrings[] = { "array", "read", "unset", "write", + (char *) NULL }; + enum operations { TRACE_VAR_ARRAY, TRACE_VAR_READ, TRACE_VAR_UNSET, + TRACE_VAR_WRITE }; + + switch ((enum traceOptions) optionIndex) { + case TRACE_ADD: + case TRACE_REMOVE: { + int flags = 0; + int i, listLen, result; + Tcl_Obj **elemPtrs; + if (objc != 6) { + Tcl_WrongNumArgs(interp, 3, objv, "name opList command"); + return TCL_ERROR; + } + /* + * Make sure the ops argument is a list object; get its length and + * a pointer to its array of element pointers. + */ + + result = Tcl_ListObjGetElements(interp, objv[4], &listLen, + &elemPtrs); + if (result != TCL_OK) { + return result; + } + if (listLen == 0) { + Tcl_SetResult(interp, "bad operation list \"\": must be " + "one or more of array, read, unset, or write", + TCL_STATIC); + return TCL_ERROR; + } + for (i = 0; i < listLen ; i++) { + if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings, + "operation", TCL_EXACT, &index) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum operations) index) { + case TRACE_VAR_ARRAY: + flags |= TCL_TRACE_ARRAY; + break; + case TRACE_VAR_READ: + flags |= TCL_TRACE_READS; + break; + case TRACE_VAR_UNSET: + flags |= TCL_TRACE_UNSETS; + break; + case TRACE_VAR_WRITE: + flags |= TCL_TRACE_WRITES; + break; + } + } + command = Tcl_GetStringFromObj(objv[5], &commandLength); + length = (size_t) commandLength; + if ((enum traceOptions) optionIndex == TRACE_ADD) { + TraceVarInfo *tvarPtr; tvarPtr = (TraceVarInfo *) ckalloc((unsigned) (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + length + 1)); tvarPtr->flags = flags; - tvarPtr->errMsg = NULL; tvarPtr->length = length; - flags |= TCL_TRACE_UNSETS; + flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT; strcpy(tvarPtr->command, command); - name = Tcl_GetString(objv[2]); + name = Tcl_GetString(objv[3]); if (Tcl_TraceVar(interp, name, flags, TraceVarProc, (ClientData) tvarPtr) != TCL_OK) { ckfree((char *) tvarPtr); return TCL_ERROR; } - break; - } - case TRACE_VDELETE: { - int flags; - TraceVarInfo *tvarPtr; - ClientData clientData; - - if (objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "name ops command"); - return TCL_ERROR; - } - - flags = 0; - rwuOps = Tcl_GetString(objv[3]); - for (p = rwuOps; *p != 0; p++) { - if (*p == 'r') { - flags |= TCL_TRACE_READS; - } else if (*p == 'w') { - flags |= TCL_TRACE_WRITES; - } else if (*p == 'u') { - flags |= TCL_TRACE_UNSETS; - } else { - goto badOps; - } - } - if (flags == 0) { - goto badOps; - } - + } else { /* * Search through all of our traces on this variable to * see if there's one with the given command. If so, then * delete the first one that matches. */ - command = Tcl_GetStringFromObj(objv[4], &commandLength); - length = (size_t) commandLength; - clientData = 0; - name = Tcl_GetString(objv[2]); + TraceVarInfo *tvarPtr; + ClientData clientData = 0; + name = Tcl_GetString(objv[3]); while ((clientData = Tcl_VarTraceInfo(interp, name, 0, TraceVarProc, clientData)) != 0) { tvarPtr = (TraceVarInfo *) clientData; - if ((tvarPtr->length == length) && (tvarPtr->flags == flags) + if ((tvarPtr->length == length) + && (tvarPtr->flags == flags) && (strncmp(command, tvarPtr->command, (size_t) length) == 0)) { - Tcl_UntraceVar(interp, name, flags | TCL_TRACE_UNSETS, + Tcl_UntraceVar2(interp, name, NULL, + flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT, TraceVarProc, clientData); - if (tvarPtr->errMsg != NULL) { - ckfree(tvarPtr->errMsg); - } - ckfree((char *) tvarPtr); + Tcl_EventuallyFree((ClientData) tvarPtr, TCL_DYNAMIC); break; } } - break; } - case TRACE_VINFO: { - ClientData clientData; - char ops[4]; - Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr; + break; + } + case TRACE_INFO: { + ClientData clientData; + Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr; + if (objc != 4) { + Tcl_WrongNumArgs(interp, 3, objv, "name"); + return TCL_ERROR; + } - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "name"); - return TCL_ERROR; + resultListPtr = Tcl_GetObjResult(interp); + clientData = 0; + name = Tcl_GetString(objv[3]); + while ((clientData = Tcl_VarTraceInfo(interp, name, 0, + TraceVarProc, clientData)) != 0) { + + TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; + + eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + /* + * Build a list with the ops list as + * the first obj element and the tcmdPtr->command string + * as the second obj element. Append this list (as an + * element) to the end of the result object list. + */ + + elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + if (tvarPtr->flags & TCL_TRACE_ARRAY) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("array", 5)); } - resultListPtr = Tcl_GetObjResult(interp); - clientData = 0; - name = Tcl_GetString(objv[2]); - while ((clientData = Tcl_VarTraceInfo(interp, name, 0, - TraceVarProc, clientData)) != 0) { + if (tvarPtr->flags & TCL_TRACE_READS) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("read", 4)); + } + if (tvarPtr->flags & TCL_TRACE_WRITES) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("write", 5)); + } + if (tvarPtr->flags & TCL_TRACE_UNSETS) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("unset", 5)); + } + Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); + + elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1); + Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); + Tcl_ListObjAppendElement(interp, resultListPtr, + eachTraceObjPtr); + } + Tcl_SetObjResult(interp, resultListPtr); + break; + } + } + return TCL_OK; +} - TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; + +/* + *---------------------------------------------------------------------- + * + * Tcl_CommandTraceInfo -- + * + * Return the clientData value associated with a trace on a + * command. This procedure can also be used to step through + * all of the traces on a particular command that have the + * same trace procedure. + * + * Results: + * The return value is the clientData value associated with + * a trace on the given command. Information will only be + * returned for a trace with proc as trace procedure. If + * the clientData argument is NULL then the first such trace is + * returned; otherwise, the next relevant one after the one + * given by clientData will be returned. If the command + * doesn't exist, or if there are no (more) traces for it, + * then NULL is returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - pairObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - p = ops; - if (tvarPtr->flags & TCL_TRACE_READS) { - *p = 'r'; - p++; - } - if (tvarPtr->flags & TCL_TRACE_WRITES) { - *p = 'w'; - p++; - } - if (tvarPtr->flags & TCL_TRACE_UNSETS) { - *p = 'u'; - p++; - } - *p = '\0'; +ClientData +Tcl_CommandTraceInfo(interp, cmdName, flags, proc, prevClientData) + 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_CommandTraceProc *proc; /* Procedure assocated with trace. */ + ClientData prevClientData; /* If non-NULL, gives last value returned + * by this procedure, so this call will + * return the next trace after that one. + * If NULL, this call will return the + * first trace. */ +{ + Command *cmdPtr; + register CommandTrace *tracePtr; - /* - * Build a pair (2-item list) with the ops string as - * the first obj element and the tvarPtr->command string - * as the second obj element. Append the pair (as an - * element) to the end of the result object list. - */ + cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, + NULL, TCL_LEAVE_ERR_MSG); + if (cmdPtr == NULL) { + return NULL; + } - elemObjPtr = Tcl_NewStringObj(ops, -1); - Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr); - elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1); - Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr); - Tcl_ListObjAppendElement(interp, resultListPtr, pairObjPtr); - } - Tcl_SetObjResult(interp, resultListPtr); + /* + * Find the relevant trace, if any, and return its clientData. + */ + + tracePtr = cmdPtr->tracePtr; + if (prevClientData != NULL) { + for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { + if ((tracePtr->clientData == prevClientData) + && (tracePtr->traceProc == proc)) { + tracePtr = tracePtr->nextPtr; break; } - default: { - panic("Tcl_TraceObjCmd: bad option index to TraceOptions"); - } + } + } + for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { + if (tracePtr->traceProc == proc) { + return tracePtr->clientData; + } + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_TraceCommand -- + * + * Arrange for rename/deletes to a command to cause a + * procedure to be invoked, which can monitor the operations. + * + * Also optionally arrange for execution of that command + * to cause a procedure to be invoked. + * + * Results: + * A standard Tcl return value. + * + * Side effects: + * A trace is set up on the command given by cmdName, such that + * future changes to the command will be intermediated by + * proc. See the manual entry for complete details on the calling + * sequence for proc. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_TraceCommand(interp, cmdName, flags, proc, clientData) + Tcl_Interp *interp; /* Interpreter in which command is + * to be traced. */ + CONST char *cmdName; /* Name of command. */ + int flags; /* OR-ed collection of bits, including any + * of TCL_TRACE_RENAME, TCL_TRACE_DELETE, + * and any of the TRACE_*_EXEC flags */ + Tcl_CommandTraceProc *proc; /* Procedure to call when specified ops are + * invoked upon varName. */ + ClientData clientData; /* Arbitrary argument to pass to proc. */ +{ + Command *cmdPtr; + register CommandTrace *tracePtr; + + cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, + NULL, TCL_LEAVE_ERR_MSG); + if (cmdPtr == NULL) { + return TCL_ERROR; + } + + /* + * Set up trace information. + */ + + tracePtr = (CommandTrace *) ckalloc(sizeof(CommandTrace)); + tracePtr->traceProc = proc; + tracePtr->clientData = clientData; + tracePtr->flags = flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE + | TCL_TRACE_ANY_EXEC); + tracePtr->nextPtr = cmdPtr->tracePtr; + cmdPtr->tracePtr = tracePtr; + if (tracePtr->flags & TCL_TRACE_ANY_EXEC) { + cmdPtr->flags |= CMD_HAS_EXEC_TRACES; } return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UntraceCommand -- + * + * Remove a previously-created trace for a command. + * + * Results: + * None. + * + * Side effects: + * If there exists a trace for the command given by cmdName + * with the given flags, proc, and clientData, then that trace + * is removed. + * + *---------------------------------------------------------------------- + */ - badOps: - Tcl_AppendResult(interp, "bad operations \"", rwuOps, - "\": should be one or more of rwu", (char *) NULL); - return TCL_ERROR; +void +Tcl_UntraceCommand(interp, cmdName, flags, proc, clientData) + Tcl_Interp *interp; /* Interpreter containing command. */ + CONST char *cmdName; /* Name of command. */ + int flags; /* OR-ed collection of bits, including any + * of TCL_TRACE_RENAME, TCL_TRACE_DELETE, + * and any of the TRACE_*_EXEC flags */ + Tcl_CommandTraceProc *proc; /* Procedure assocated with trace. */ + ClientData clientData; /* Arbitrary argument to pass to proc. */ +{ + register CommandTrace *tracePtr; + CommandTrace *prevPtr; + Command *cmdPtr; + Interp *iPtr = (Interp *) interp; + ActiveCommandTrace *activePtr; + int hasExecTraces = 0; + + cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, + NULL, TCL_LEAVE_ERR_MSG); + if (cmdPtr == NULL) { + return; + } + + flags &= (TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC); + + for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; ; + prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { + if (tracePtr == NULL) { + return; + } + if ((tracePtr->traceProc == proc) && ((tracePtr->flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC)) == flags) + && (tracePtr->clientData == clientData)) { + if (tracePtr->flags & TCL_TRACE_ANY_EXEC) { + hasExecTraces = 1; + } + break; + } + } + + /* + * The code below makes it possible to delete traces while traces + * are active: it makes sure that the deleted trace won't be + * processed by CallCommandTraces. + */ + + for (activePtr = iPtr->activeCmdTracePtr; activePtr != NULL; + activePtr = activePtr->nextPtr) { + if (activePtr->nextTracePtr == tracePtr) { + activePtr->nextTracePtr = tracePtr->nextPtr; + } + } + if (prevPtr == NULL) { + cmdPtr->tracePtr = tracePtr->nextPtr; + } else { + prevPtr->nextPtr = tracePtr->nextPtr; + } + tracePtr->flags = 0; + Tcl_EventuallyFree((int*)tracePtr, TCL_DYNAMIC); + + if (hasExecTraces) { + for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; tracePtr != NULL ; + prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { + if (tracePtr->flags & TCL_TRACE_ANY_EXEC) { + return; + } + } + /* + * None of the remaining traces on this command are execution + * traces. We therefore remove this flag: + */ + cmdPtr->flags &= ~CMD_HAS_EXEC_TRACES; + } +} + +/* + *---------------------------------------------------------------------- + * + * TraceCommandProc -- + * + * This procedure is called to handle command changes that have + * been traced using the "trace" command, when using the + * 'rename' or 'delete' options. + * + * Results: + * None. + * + * Side effects: + * Depends on the command associated with the trace. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +TraceCommandProc(clientData, interp, oldName, newName, flags) + ClientData 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 means command is being deleted + * (renamed to ""). */ + int flags; /* OR-ed bits giving operation and other + * information. */ +{ + Tcl_SavedResult state; + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; + int code; + Tcl_DString cmd; + + Tcl_Preserve((ClientData) tcmdPtr); + + if ((tcmdPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) { + /* + * Generate a command to execute by appending list elements + * for the old and new command name and the operation. + */ + + Tcl_DStringInit(&cmd); + Tcl_DStringAppend(&cmd, tcmdPtr->command, (int) tcmdPtr->length); + Tcl_DStringAppendElement(&cmd, oldName); + Tcl_DStringAppendElement(&cmd, (newName ? newName : "")); + if (flags & TCL_TRACE_RENAME) { + Tcl_DStringAppend(&cmd, " rename", 7); + } else if (flags & TCL_TRACE_DELETE) { + Tcl_DStringAppend(&cmd, " delete", 7); + } + + /* + * Execute the command. Save the interp's result used for + * the command. We discard any object result the command returns. + * + * Add the TCL_TRACE_DESTROYED flag to tcmdPtr to indicate to + * other areas that this will be destroyed by us, otherwise a + * double-free might occur depending on what the eval does. + */ + + Tcl_SaveResult(interp, &state); + if (flags & TCL_TRACE_DESTROYED) { + tcmdPtr->flags |= TCL_TRACE_DESTROYED; + } + + code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd), + Tcl_DStringLength(&cmd), 0); + if (code != TCL_OK) { + /* We ignore errors in these traced commands */ + } + + Tcl_RestoreResult(interp, &state); + + Tcl_DStringFree(&cmd); + } + /* + * We delete when the trace was destroyed or if this is a delete trace, + * because command deletes are unconditional, so the trace must go away. + */ + if (flags & (TCL_TRACE_DESTROYED | TCL_TRACE_DELETE)) { + if (tcmdPtr->stepTrace != NULL) { + Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); + tcmdPtr->stepTrace = NULL; + } + /* Postpone deletion, until exec trace returns */ + if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { + tcmdPtr->flags = 0; + } else { + Tcl_EventuallyFree((ClientData) tcmdPtr, TCL_DYNAMIC); + } + } + Tcl_Release((ClientData) tcmdPtr); + return; +} + +/* + *---------------------------------------------------------------------- + * + * TclCheckExecutionTraces -- + * + * Checks on all current command execution traces, and invokes + * procedures which have been registered. This procedure can be + * used by other code which performs execution to unify the + * tracing system, so that execution traces will function for that + * other code. + * + * For instance extensions like [incr Tcl] which use their + * own execution technique can make use of Tcl's tracing. + * + * This procedure is called by 'TclEvalObjvInternal' + * + * Results: + * The return value is a standard Tcl completion code such as + * TCL_OK or TCL_ERROR, etc. + * + * Side effects: + * Those side effects made by any trace procedures called. + * + *---------------------------------------------------------------------- + */ +int +TclCheckExecutionTraces(interp, command, numChars, cmdPtr, code, traceFlags, objc, objv) + 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. */ + 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_Obj *CONST objv[]; /* Pointers to Tcl_Obj of each argument. */ +{ + Interp *iPtr = (Interp *) interp; + CommandTrace *tracePtr, *lastTracePtr; + ActiveCommandTrace active; + int curLevel; + int traceCode = TCL_OK; + TraceCommandInfo* tcmdPtr; + + if (command == NULL || cmdPtr->tracePtr == NULL) { + return(traceCode); + } + + curLevel = ((iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level); + + active.nextPtr = iPtr->activeCmdTracePtr; + iPtr->activeCmdTracePtr = &active; + + active.cmdPtr = cmdPtr; + lastTracePtr = NULL; + for ( tracePtr = cmdPtr->tracePtr; + (traceCode == TCL_OK) && (tracePtr != NULL); + tracePtr = active.nextTracePtr) { + if (traceFlags & TCL_TRACE_LEAVE_EXEC) { + /* execute the trace command in order of creation for "leave" */ + active.nextTracePtr = NULL; + tracePtr = cmdPtr->tracePtr; + while (tracePtr->nextPtr != lastTracePtr) { + active.nextTracePtr = tracePtr; + tracePtr = tracePtr->nextPtr; + } + } else { + active.nextTracePtr = tracePtr->nextPtr; + } + tcmdPtr = (TraceCommandInfo*)tracePtr->clientData; + if (tcmdPtr->flags != 0) { + tcmdPtr->curFlags = traceFlags | TCL_TRACE_EXEC_DIRECT; + tcmdPtr->curCode = code; + traceCode = TraceExecutionProc((ClientData)tcmdPtr, interp, + curLevel, command, (Tcl_Command)cmdPtr, objc, objv); + } + lastTracePtr = tracePtr; + } + iPtr->activeCmdTracePtr = active.nextPtr; + return(traceCode); +} + +/* + *---------------------------------------------------------------------- + * + * TclCheckInterpTraces -- + * + * Checks on all current traces, and invokes procedures which + * have been registered. This procedure can be used by other + * code which performs execution to unify the tracing system. + * For instance extensions like [incr Tcl] which use their + * own execution technique can make use of Tcl's tracing. + * + * This procedure is called by 'TclEvalObjvInternal' + * + * Results: + * The return value is a standard Tcl completion code such as + * TCL_OK or TCL_ERROR, etc. + * + * Side effects: + * Those side effects made by any trace procedures called. + * + *---------------------------------------------------------------------- + */ +int +TclCheckInterpTraces(interp, command, numChars, cmdPtr, code, traceFlags, objc, objv) + 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. */ + 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_Obj *CONST objv[]; /* Pointers to Tcl_Obj of each argument. */ +{ + Interp *iPtr = (Interp *) interp; + Trace *tracePtr, *lastTracePtr; + ActiveInterpTrace active; + int curLevel; + int traceCode = TCL_OK; + TraceCommandInfo* tcmdPtr; + + if (command == NULL || iPtr->tracePtr == NULL || + (iPtr->flags & INTERP_TRACE_IN_PROGRESS)) { + return(traceCode); + } + + curLevel = ((iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level); + + active.nextPtr = iPtr->activeInterpTracePtr; + iPtr->activeInterpTracePtr = &active; + + lastTracePtr = NULL; + for ( tracePtr = iPtr->tracePtr; + (traceCode == TCL_OK) && (tracePtr != NULL); + tracePtr = active.nextTracePtr) { + if (traceFlags & TCL_TRACE_ENTER_EXEC) { + /* execute the trace command in reverse order of creation + * for "enterstep" operation. The order is changed for + * ""enterstep" instead of for "leavestep as was done in + * TclCheckExecutionTraces because for step traces, + * Tcl_CreateObjTrace creates one more linked list of traces + * which results in one more reversal of trace invocation. + */ + active.nextTracePtr = NULL; + tracePtr = iPtr->tracePtr; + while (tracePtr->nextPtr != lastTracePtr) { + active.nextTracePtr = tracePtr; + tracePtr = tracePtr->nextPtr; + } + } else { + active.nextTracePtr = tracePtr->nextPtr; + } + if (tracePtr->level > 0 && curLevel > tracePtr->level) { + continue; + } + if (!(tracePtr->flags & TCL_TRACE_EXEC_IN_PROGRESS)) { + /* + * The proc invoked might delete the traced command which + * which might try to free tracePtr. We want to use tracePtr + * until the end of this if section, so we use + * Tcl_Preserve() and Tcl_Release() to be sureit is not + * freed while we still need it. + */ + Tcl_Preserve((ClientData) tracePtr); + tracePtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS; + if ((tracePtr->flags != TCL_TRACE_EXEC_IN_PROGRESS) && + ((tracePtr->flags & traceFlags) != 0)) { + tcmdPtr = (TraceCommandInfo*)tracePtr->clientData; + tcmdPtr->curFlags = traceFlags; + tcmdPtr->curCode = code; + traceCode = (tracePtr->proc)((ClientData)tcmdPtr, + (Tcl_Interp*)interp, + curLevel, command, + (Tcl_Command)cmdPtr, + objc, objv); + } else { + if (traceFlags & TCL_TRACE_ENTER_EXEC) { + /* + * Old-style interpreter-wide traces only trigger + * before the command is executed. + */ + traceCode = CallTraceProcedure(interp, tracePtr, cmdPtr, + command, numChars, objc, objv); + } + } + tracePtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS; + Tcl_Release((ClientData) tracePtr); + } + lastTracePtr = tracePtr; + } + iPtr->activeInterpTracePtr = active.nextPtr; + return(traceCode); +} + +/* + *---------------------------------------------------------------------- + * + * CallTraceProcedure -- + * + * Invokes a trace procedure registered with an interpreter. These + * procedures trace command execution. Currently this trace procedure + * is called with the address of the string-based Tcl_CmdProc for the + * command, not the Tcl_ObjCmdProc. + * + * Results: + * None. + * + * Side effects: + * Those side effects made by the trace procedure. + * + *---------------------------------------------------------------------- + */ + +static int +CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv) + Tcl_Interp *interp; /* The current interpreter. */ + register Trace *tracePtr; /* Describes the trace procedure to call. */ + 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 source. */ + register int objc; /* Number of arguments for the command. */ + Tcl_Obj *CONST objv[]; /* Pointers to Tcl_Obj of each argument. */ +{ + Interp *iPtr = (Interp *) interp; + char *commandCopy; + int traceCode; + + /* + * Copy the command characters into a new string. + */ + + commandCopy = (char *) ckalloc((unsigned) (numChars + 1)); + memcpy((VOID *) commandCopy, (VOID *) command, (size_t) numChars); + commandCopy[numChars] = '\0'; + + /* + * Call the trace procedure then free allocated storage. + */ + + traceCode = (tracePtr->proc)( tracePtr->clientData, (Tcl_Interp*) iPtr, + iPtr->numLevels, commandCopy, + (Tcl_Command) cmdPtr, objc, objv ); + + ckfree((char *) commandCopy); + return(traceCode); +} + +/* + *---------------------------------------------------------------------- + * + * TraceExecutionProc -- + * + * This procedure is invoked whenever code relevant to a + * 'trace execution' command is executed. It is called in one + * of two ways in Tcl's core: + * + * (i) by the TclCheckExecutionTraces, when an execution trace has been + * triggered. + * (ii) by TclCheckInterpTraces, when a prior execution trace has + * created a trace of the internals of a procedure, passing in + * this procedure as the one to be called. + * + * Results: + * The return value is a standard Tcl completion code such as + * TCL_OK or TCL_ERROR, etc. + * + * Side effects: + * May invoke an arbitrary Tcl procedure, and may create or + * delete an interpreter-wide trace. + * + *---------------------------------------------------------------------- + */ +int +TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, + int level, CONST char* command, Tcl_Command cmdInfo, + int objc, struct Tcl_Obj *CONST objv[]) { + int call = 0; + Interp *iPtr = (Interp *) interp; + TraceCommandInfo* tcmdPtr = (TraceCommandInfo*)clientData; + int flags = tcmdPtr->curFlags; + int code = tcmdPtr->curCode; + int traceCode = TCL_OK; + + if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { + /* + * Inside any kind of execution trace callback, we do + * not allow any further execution trace callbacks to + * be called for the same trace. + */ + return(traceCode); + } + + if (!(flags & TCL_INTERP_DESTROYED)) { + /* + * Check whether the current call is going to eval arbitrary + * Tcl code with a generated trace, or whether we are only + * going to setup interpreter-wide traces to implement the + * 'step' traces. This latter situation can happen if + * we create a command trace without either before or after + * operations, but with either of the step operations. + */ + if (flags & TCL_TRACE_EXEC_DIRECT) { + call = flags & tcmdPtr->flags & (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); + } else { + call = 1; + } + /* + * First, if we have returned back to the level at which we + * created an interpreter trace, we remove it + */ + if (flags & TCL_TRACE_LEAVE_EXEC) { + if ((tcmdPtr->stepTrace != NULL) && (level == tcmdPtr->startLevel)) { + Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); + tcmdPtr->stepTrace = NULL; + } + + } + + /* + * Second, create the tcl callback, if required. + */ + if (call) { + Tcl_SavedResult state; + Tcl_DString cmd; + Tcl_DString sub; + int i; + + Tcl_DStringInit(&cmd); + Tcl_DStringAppend(&cmd, tcmdPtr->command, (int)tcmdPtr->length); + /* Append command with arguments */ + Tcl_DStringInit(&sub); + for (i = 0; i < objc; i++) { + char* str; + int len; + str = Tcl_GetStringFromObj(objv[i],&len); + Tcl_DStringAppendElement(&sub, str); + } + Tcl_DStringAppendElement(&cmd, Tcl_DStringValue(&sub)); + Tcl_DStringFree(&sub); + + if (flags & TCL_TRACE_ENTER_EXEC) { + /* Append trace operation */ + if (flags & TCL_TRACE_EXEC_DIRECT) { + Tcl_DStringAppendElement(&cmd, "enter"); + } else { + Tcl_DStringAppendElement(&cmd, "enterstep"); + } + } else if (flags & TCL_TRACE_LEAVE_EXEC) { + Tcl_Obj* resultCode; + char* resultCodeStr; + + /* Append result code */ + resultCode = Tcl_NewIntObj(code); + resultCodeStr = Tcl_GetString(resultCode); + Tcl_DStringAppendElement(&cmd, resultCodeStr); + Tcl_DecrRefCount(resultCode); + + /* Append result string */ + Tcl_DStringAppendElement(&cmd, Tcl_GetStringResult(interp)); + /* Append trace operation */ + if (flags & TCL_TRACE_EXEC_DIRECT) { + Tcl_DStringAppendElement(&cmd, "leave"); + } else { + Tcl_DStringAppendElement(&cmd, "leavestep"); + } + } else { + panic("TraceExecutionProc: bad flag combination"); + } + + /* + * Execute the command. Save the interp's result used for + * the command. We discard any object result the command returns. + */ + + Tcl_SaveResult(interp, &state); + + tcmdPtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS; + iPtr->flags |= INTERP_TRACE_IN_PROGRESS; + Tcl_Preserve((ClientData)tcmdPtr); + /* + * This line can have quite arbitrary side-effects, + * including deleting the trace, the command being + * traced, or even the interpreter. + */ + traceCode = Tcl_Eval(interp, Tcl_DStringValue(&cmd)); + tcmdPtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS; + iPtr->flags &= ~INTERP_TRACE_IN_PROGRESS; + if (tcmdPtr->flags == 0) { + flags |= TCL_TRACE_DESTROYED; + } + + if (traceCode == TCL_OK) { + /* Restore result if trace execution was successful */ + Tcl_RestoreResult(interp, &state); + } + + Tcl_DStringFree(&cmd); + } + + /* + * Third, create an interpreter trace, if we need one for + * subsequent internal execution traces. + */ + if ((flags & TCL_TRACE_ENTER_EXEC) && (tcmdPtr->stepTrace == NULL) + && (tcmdPtr->flags & (TCL_TRACE_ENTER_DURING_EXEC | TCL_TRACE_LEAVE_DURING_EXEC))) { + tcmdPtr->startLevel = level; + tcmdPtr->stepTrace = Tcl_CreateObjTrace(interp, 0, + (tcmdPtr->flags & TCL_TRACE_ANY_EXEC) >> 2, + TraceExecutionProc, (ClientData)tcmdPtr, NULL); + } + } + if (flags & TCL_TRACE_DESTROYED) { + if (tcmdPtr->stepTrace != NULL) { + Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); + tcmdPtr->stepTrace = NULL; + } + Tcl_EventuallyFree((ClientData)tcmdPtr, TCL_DYNAMIC); + } + if (call) { + Tcl_Release((ClientData)tcmdPtr); + } + return(traceCode); } /* @@ -2717,8 +4428,8 @@ static char * TraceVarProc(clientData, interp, name1, name2, flags) ClientData clientData; /* Information about the variable trace. */ Tcl_Interp *interp; /* Interpreter containing variable. */ - char *name1; /* Name of variable or array. */ - char *name2; /* Name of element within array; NULL means + CONST char *name1; /* Name of variable or array. */ + CONST char *name2; /* Name of element within array; NULL means * scalar variable is being referenced. */ int flags; /* OR-ed bits giving operation and other * information. */ @@ -2729,64 +4440,91 @@ TraceVarProc(clientData, interp, name1, name2, flags) int code; Tcl_DString cmd; + /* + * We might call Tcl_Eval() 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. + */ + + Tcl_Preserve((ClientData) tvarPtr); + result = NULL; - if (tvarPtr->errMsg != NULL) { - ckfree(tvarPtr->errMsg); - tvarPtr->errMsg = NULL; - } if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) { + if (tvarPtr->length != (size_t) 0) { + /* + * Generate a command to execute by appending list elements + * for the two variable names and the operation. + */ - /* - * Generate a command to execute by appending list elements - * for the two variable names and the operation. The five - * extra characters are for three space, the opcode character, - * and the terminating null. - */ + Tcl_DStringInit(&cmd); + Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length); + Tcl_DStringAppendElement(&cmd, name1); + Tcl_DStringAppendElement(&cmd, (name2 ? name2 : "")); +#ifndef TCL_REMOVE_OBSOLETE_TRACES + if (tvarPtr->flags & TCL_TRACE_OLD_STYLE) { + if (flags & TCL_TRACE_ARRAY) { + Tcl_DStringAppend(&cmd, " a", 2); + } else if (flags & TCL_TRACE_READS) { + Tcl_DStringAppend(&cmd, " r", 2); + } else if (flags & TCL_TRACE_WRITES) { + Tcl_DStringAppend(&cmd, " w", 2); + } else if (flags & TCL_TRACE_UNSETS) { + Tcl_DStringAppend(&cmd, " u", 2); + } + } else { +#endif + if (flags & TCL_TRACE_ARRAY) { + Tcl_DStringAppend(&cmd, " array", 6); + } else if (flags & TCL_TRACE_READS) { + Tcl_DStringAppend(&cmd, " read", 5); + } else if (flags & TCL_TRACE_WRITES) { + Tcl_DStringAppend(&cmd, " write", 6); + } else if (flags & TCL_TRACE_UNSETS) { + Tcl_DStringAppend(&cmd, " unset", 6); + } +#ifndef TCL_REMOVE_OBSOLETE_TRACES + } +#endif + + /* + * Execute the command. Save the interp's result used for + * the command. We discard any object result the command returns. + * + * Add the TCL_TRACE_DESTROYED flag to tvarPtr to indicate to + * other areas that this will be destroyed by us, otherwise a + * double-free might occur depending on what the eval does. + */ - if (name2 == NULL) { - name2 = ""; - } - Tcl_DStringInit(&cmd); - Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length); - Tcl_DStringAppendElement(&cmd, name1); - Tcl_DStringAppendElement(&cmd, name2); - if (flags & TCL_TRACE_READS) { - Tcl_DStringAppend(&cmd, " r", 2); - } else if (flags & TCL_TRACE_WRITES) { - Tcl_DStringAppend(&cmd, " w", 2); - } else if (flags & TCL_TRACE_UNSETS) { - Tcl_DStringAppend(&cmd, " u", 2); - } + Tcl_SaveResult(interp, &state); + if (flags & TCL_TRACE_DESTROYED) { + tvarPtr->flags |= TCL_TRACE_DESTROYED; + } - /* - * Execute the command. Save the interp's result used for - * the command. We discard any object result the command returns. - */ + code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd), + Tcl_DStringLength(&cmd), 0); + if (code != TCL_OK) { /* copy error msg to result */ + register Tcl_Obj *errMsgObj = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(errMsgObj); + result = (char *) errMsgObj; + } - Tcl_SaveResult(interp, &state); + Tcl_RestoreResult(interp, &state); - code = Tcl_Eval(interp, Tcl_DStringValue(&cmd)); - if (code != TCL_OK) { /* copy error msg to result */ - char *string; - int length; - - string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length); - tvarPtr->errMsg = (char *) ckalloc((unsigned) (length + 1)); - memcpy(tvarPtr->errMsg, string, (size_t) (length + 1)); - result = tvarPtr->errMsg; + Tcl_DStringFree(&cmd); } - - Tcl_RestoreResult(interp, &state); - - Tcl_DStringFree(&cmd); } if (flags & TCL_TRACE_DESTROYED) { - result = NULL; - if (tvarPtr->errMsg != NULL) { - ckfree(tvarPtr->errMsg); + if (result != NULL) { + register Tcl_Obj *errMsgObj = (Tcl_Obj *) result; + + Tcl_DecrRefCount(errMsgObj); + result = NULL; } - ckfree((char *) tvarPtr); + Tcl_EventuallyFree((ClientData) tvarPtr, TCL_DYNAMIC); } + Tcl_Release((ClientData) tvarPtr); return result; } @@ -2855,4 +4593,3 @@ Tcl_WhileObjCmd(dummy, interp, objc, objv) return result; } - diff --git a/tcl/generic/tclCompCmds.c b/tcl/generic/tclCompCmds.c index f15b5aa5378..43a24e08557 100644 --- a/tcl/generic/tclCompCmds.c +++ b/tcl/generic/tclCompCmds.c @@ -5,6 +5,8 @@ * 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. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -20,8 +22,17 @@ */ static ClientData DupForeachInfo _ANSI_ARGS_((ClientData clientData)); -static void FreeForeachInfo _ANSI_ARGS_(( - ClientData clientData)); +static void FreeForeachInfo _ANSI_ARGS_((ClientData clientData)); +static int TclPushVarName _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags, + int *localIndexPtr, int *simpleVarNamePtr, int *isScalarPtr)); + +/* + * Flags bits used by TclPushVarName. + */ + +#define TCL_CREATE_VAR 1 /* Create a compiled local if none is found */ +#define TCL_NO_LARGE_INDEX 2 /* Do not return localIndex value > 255 */ /* * The structures below define the AuxData types defined in this file. @@ -36,6 +47,130 @@ AuxDataType tclForeachInfoType = { /* *---------------------------------------------------------------------- * + * TclCompileAppendCmd -- + * + * Procedure called to compile the "append" command. + * + * Results: + * The return value is a standard Tcl result, which is normally TCL_OK + * unless there was an error while parsing string. If an error occurs + * then the interpreter's result contains a standard error message. If + * complation fails because the command requires a second level of + * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the + * command should be compiled "out of line" by emitting code to + * invoke its command procedure (Tcl_AppendObjCmd) at runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "append" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileAppendCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Tcl_Token *varTokenPtr, *valueTokenPtr; + int simpleVarName, isScalar, localIndex, numWords; + int code = TCL_OK; + + numWords = parsePtr->numWords; + if (numWords == 1) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"append varName ?value value ...?\"", + -1); + return TCL_ERROR; + } else if (numWords == 2) { + /* + * append varName === set varName + */ + return TclCompileSetCmd(interp, parsePtr, envPtr); + } else if (numWords > 3) { + /* + * APPEND instructions currently only handle one value + */ + return TCL_OUT_LINE_COMPILE; + } + + /* + * Decide if we can use a frame slot for the var/array name or if we + * need to emit code to compute and push the name at runtime. We use a + * frame slot (entry in the array of local vars) if we are compiling a + * procedure body and if the name is simple text that does not include + * namespace qualifiers. + */ + + varTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + + code = TclPushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, + &localIndex, &simpleVarName, &isScalar); + if (code != TCL_OK) { + goto done; + } + + /* + * We are doing an assignment, otherwise TclCompileSetCmd was called, + * so push the new value. This will need to be extended to push a + * value for each argument. + */ + + if (numWords > 2) { + valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + TclEmitPush(TclRegisterNewLiteral(envPtr, + valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr); + } else { + code = TclCompileTokens(interp, valueTokenPtr+1, + valueTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + goto done; + } + } + } + + /* + * Emit instructions to set/get the variable. + */ + + if (simpleVarName) { + if (isScalar) { + if (localIndex >= 0) { + if (localIndex <= 255) { + TclEmitInstInt1(INST_APPEND_SCALAR1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_APPEND_SCALAR4, localIndex, envPtr); + } + } else { + TclEmitOpcode(INST_APPEND_STK, envPtr); + } + } else { + if (localIndex >= 0) { + if (localIndex <= 255) { + TclEmitInstInt1(INST_APPEND_ARRAY1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_APPEND_ARRAY4, localIndex, envPtr); + } + } else { + TclEmitOpcode(INST_APPEND_ARRAY_STK, envPtr); + } + } + } else { + TclEmitOpcode(INST_APPEND_STK, envPtr); + } + + done: + return code; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileBreakCmd -- * * Procedure called to compile the "break" command. @@ -45,9 +180,6 @@ AuxDataType tclForeachInfoType = { * there was an error during compilation. If an error occurs then * the interpreter's result contains a standard error message. * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the command. - * * Side effects: * Instructions are added to envPtr to execute the "break" command * at runtime. @@ -66,7 +198,6 @@ TclCompileBreakCmd(interp, parsePtr, envPtr) Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), "wrong # args: should be \"break\"", -1); - envPtr->maxStackDepth = 0; return TCL_ERROR; } @@ -75,7 +206,6 @@ TclCompileBreakCmd(interp, parsePtr, envPtr) */ TclEmitOpcode(INST_BREAK, envPtr); - envPtr->maxStackDepth = 0; return TCL_OK; } @@ -95,9 +225,6 @@ TclCompileBreakCmd(interp, parsePtr, envPtr) * should be compiled "out of line" by emitting code to invoke its * command procedure at runtime. * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the command. - * * Side effects: * Instructions are added to envPtr to execute the "catch" command * at runtime. @@ -114,12 +241,11 @@ TclCompileCatchCmd(interp, parsePtr, envPtr) { JumpFixup jumpFixup; Tcl_Token *cmdTokenPtr, *nameTokenPtr; - char *name; - int localIndex, nameChars, range, maxDepth, startOffset, jumpDist; + CONST char *name; + int localIndex, nameChars, range, startOffset, jumpDist; int code; - char buffer[32 + TCL_INTEGER_SPACE]; + int savedStackDepth = envPtr->currStackDepth; - envPtr->maxStackDepth = 0; if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) { Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), @@ -165,8 +291,6 @@ TclCompileCatchCmd(interp, parsePtr, envPtr) * We will compile the catch command. Emit a beginCatch instruction at * the start of the catch body: the subcommand it controls. */ - - maxDepth = 0; envPtr->exceptDepth++; envPtr->maxExceptDepth = @@ -174,19 +298,31 @@ TclCompileCatchCmd(interp, parsePtr, envPtr) range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr); - startOffset = (envPtr->codeNext - envPtr->codeStart); + /* + * If the body is a simple word, compile the instructions to + * eval it. Otherwise, compile instructions to substitute its + * text without catching, a catch instruction that resets the + * stack to what it was before substituting the body, and then + * an instruction to eval the body. Care has to be taken to + * register the correct startOffset for the catch range so that + * errors in the substitution are not catched [Bug 219184] + */ + + if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + startOffset = (envPtr->codeNext - envPtr->codeStart); + code = TclCompileCmdWord(interp, cmdTokenPtr+1, 1, envPtr); + } else { + code = TclCompileTokens(interp, cmdTokenPtr+1, + cmdTokenPtr->numComponents, envPtr); + startOffset = (envPtr->codeNext - envPtr->codeStart); + TclEmitOpcode(INST_EVAL_STK, envPtr); + } envPtr->exceptArrayPtr[range].codeOffset = startOffset; - code = TclCompileCmdWord(interp, cmdTokenPtr+1, - cmdTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { - if (code == TCL_ERROR) { - sprintf(buffer, "\n (\"catch\" body line %d)", - interp->errorLine); - Tcl_AddObjErrorInfo(interp, buffer, -1); - } + code = TCL_OUT_LINE_COMPILE; goto done; } - maxDepth = envPtr->maxStackDepth; envPtr->exceptArrayPtr[range].numCodeBytes = (envPtr->codeNext - envPtr->codeStart) - startOffset; @@ -204,11 +340,7 @@ TclCompileCatchCmd(interp, parsePtr, envPtr) } } TclEmitOpcode(INST_POP, envPtr); - TclEmitPush(TclRegisterLiteral(envPtr, "0", 1, /*onHeap*/ 0), - envPtr); - if (maxDepth == 0) { - maxDepth = 1; - } + TclEmitPush(TclRegisterNewLiteral(envPtr, "0", 1), envPtr); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); /* @@ -217,6 +349,7 @@ TclCompileCatchCmd(interp, parsePtr, envPtr) * the catch's error target. */ + envPtr->currStackDepth = savedStackDepth; envPtr->exceptArrayPtr[range].catchOffset = (envPtr->codeNext - envPtr->codeStart); if (localIndex != -1) { @@ -230,6 +363,7 @@ TclCompileCatchCmd(interp, parsePtr, envPtr) } TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr); + /* * Update the target of the jump after the "no errors" code, then emit * an endCatch instruction at the end of the catch command. @@ -243,8 +377,8 @@ TclCompileCatchCmd(interp, parsePtr, envPtr) TclEmitOpcode(INST_END_CATCH, envPtr); done: + envPtr->currStackDepth = savedStackDepth + 1; envPtr->exceptDepth--; - envPtr->maxStackDepth = maxDepth; return code; } @@ -260,9 +394,6 @@ TclCompileCatchCmd(interp, parsePtr, envPtr) * there was an error while parsing string. If an error occurs then * the interpreter's result contains a standard error message. * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the command. - * * Side effects: * Instructions are added to envPtr to execute the "continue" command * at runtime. @@ -285,7 +416,6 @@ TclCompileContinueCmd(interp, parsePtr, envPtr) Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), "wrong # args: should be \"continue\"", -1); - envPtr->maxStackDepth = 0; return TCL_ERROR; } @@ -294,7 +424,6 @@ TclCompileContinueCmd(interp, parsePtr, envPtr) */ TclEmitOpcode(INST_CONTINUE, envPtr); - envPtr->maxStackDepth = 0; return TCL_OK; } @@ -310,9 +439,6 @@ TclCompileContinueCmd(interp, parsePtr, envPtr) * unless there was an error while parsing string. If an error occurs * then the interpreter's result contains a standard error message. * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the "expr" command. - * * Side effects: * Instructions are added to envPtr to execute the "expr" command * at runtime. @@ -329,7 +455,6 @@ TclCompileExprCmd(interp, parsePtr, envPtr) { Tcl_Token *firstWordPtr; - envPtr->maxStackDepth = 0; if (parsePtr->numWords == 1) { Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), @@ -355,16 +480,12 @@ TclCompileExprCmd(interp, parsePtr, envPtr) * there was an error while parsing string. If an error occurs then * the interpreter's result contains a standard error message. * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the command. - * * Side effects: * Instructions are added to envPtr to execute the "for" command * at runtime. * *---------------------------------------------------------------------- */ - int TclCompileForCmd(interp, parsePtr, envPtr) Tcl_Interp *interp; /* Used for error reporting. */ @@ -373,13 +494,12 @@ TclCompileForCmd(interp, parsePtr, envPtr) CompileEnv *envPtr; /* Holds resulting instructions. */ { Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr; - JumpFixup jumpFalseFixup; - int maxDepth, jumpBackDist, jumpBackOffset, testCodeOffset, jumpDist; + JumpFixup jumpEvalCondFixup; + int testCodeOffset, bodyCodeOffset, nextCodeOffset, jumpDist; int bodyRange, nextRange, code; - unsigned char *jumpPc; char buffer[32 + TCL_INTEGER_SPACE]; + int savedStackDepth = envPtr->currStackDepth; - envPtr->maxStackDepth = 0; if (parsePtr->numWords != 5) { Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), @@ -401,6 +521,18 @@ TclCompileForCmd(interp, parsePtr, envPtr) } /* + * Bail out also if the body or the next expression require substitutions + * in order to insure correct behaviour [Bug 219166] + */ + + nextTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1); + bodyTokenPtr = nextTokenPtr + (nextTokenPtr->numComponents + 1); + if ((nextTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) + || (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) { + return TCL_OUT_LINE_COMPILE; + } + + /* * Create ExceptionRange records for the body and the "next" command. * The "next" command's ExceptionRange supports break but not continue * (and has a -1 continueOffset). @@ -416,7 +548,6 @@ TclCompileForCmd(interp, parsePtr, envPtr) * Inline compile the initial command. */ - maxDepth = 0; code = TclCompileCmdWord(interp, startTokenPtr+1, startTokenPtr->numComponents, envPtr); if (code != TCL_OK) { @@ -426,35 +557,31 @@ TclCompileForCmd(interp, parsePtr, envPtr) } goto done; } - maxDepth = envPtr->maxStackDepth; TclEmitOpcode(INST_POP, envPtr); - + /* - * Compile the test then emit the conditional jump that exits the for. + * Jump to the evaluation of the condition. This code uses the "loop + * rotation" optimisation (which eliminates one branch from the loop). + * "for start cond next body" produces then: + * start + * goto A + * B: body : bodyCodeOffset + * next : nextCodeOffset, continueOffset + * A: cond -> result : testCodeOffset + * if (result) goto B */ - testCodeOffset = (envPtr->codeNext - envPtr->codeStart); - code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr); - if (code != TCL_OK) { - if (code == TCL_ERROR) { - Tcl_AddObjErrorInfo(interp, - "\n (\"for\" test expression)", -1); - } - goto done; - } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup); + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup); /* * Compile the loop body. */ - nextTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1); - bodyTokenPtr = nextTokenPtr + (nextTokenPtr->numComponents + 1); - envPtr->exceptArrayPtr[bodyRange].codeOffset = - (envPtr->codeNext - envPtr->codeStart); + bodyCodeOffset = (envPtr->codeNext - envPtr->codeStart); + code = TclCompileCmdWord(interp, bodyTokenPtr+1, bodyTokenPtr->numComponents, envPtr); + envPtr->currStackDepth = savedStackDepth + 1; if (code != TCL_OK) { if (code == TCL_ERROR) { sprintf(buffer, "\n (\"for\" body line %d)", @@ -463,22 +590,21 @@ TclCompileForCmd(interp, parsePtr, envPtr) } goto done; } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); envPtr->exceptArrayPtr[bodyRange].numCodeBytes = - (envPtr->codeNext - envPtr->codeStart) - - envPtr->exceptArrayPtr[bodyRange].codeOffset; + (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset; TclEmitOpcode(INST_POP, envPtr); + /* * Compile the "next" subcommand. */ - envPtr->exceptArrayPtr[bodyRange].continueOffset = - (envPtr->codeNext - envPtr->codeStart); - envPtr->exceptArrayPtr[nextRange].codeOffset = - (envPtr->codeNext - envPtr->codeStart); + nextCodeOffset = (envPtr->codeNext - envPtr->codeStart); + + envPtr->currStackDepth = savedStackDepth; code = TclCompileCmdWord(interp, nextTokenPtr+1, nextTokenPtr->numComponents, envPtr); + envPtr->currStackDepth = savedStackDepth + 1; if (code != TCL_OK) { if (code == TCL_ERROR) { Tcl_AddObjErrorInfo(interp, @@ -486,62 +612,53 @@ TclCompileForCmd(interp, parsePtr, envPtr) } goto done; } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); envPtr->exceptArrayPtr[nextRange].numCodeBytes = (envPtr->codeNext - envPtr->codeStart) - - envPtr->exceptArrayPtr[nextRange].codeOffset; + - nextCodeOffset; TclEmitOpcode(INST_POP, envPtr); - - /* - * Jump back to the test at the top of the loop. Generate a 4 byte jump - * if the distance to the test is > 120 bytes. This is conservative and - * ensures that we won't have to replace this jump if we later need to - * replace the ifFalse jump with a 4 byte jump. - */ - - jumpBackOffset = (envPtr->codeNext - envPtr->codeStart); - jumpBackDist = (jumpBackOffset - testCodeOffset); - if (jumpBackDist > 120) { - TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr); - } else { - TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr); - } + envPtr->currStackDepth = savedStackDepth; /* - * Fix the target of the jumpFalse after the test. + * Compile the test expression then emit the conditional jump that + * terminates the for. */ - jumpDist = (envPtr->codeNext - envPtr->codeStart) - - jumpFalseFixup.codeOffset; - if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) { - /* - * Update the loop body and "next" command ExceptionRanges since - * they moved down. - */ - - envPtr->exceptArrayPtr[bodyRange].codeOffset += 3; - envPtr->exceptArrayPtr[bodyRange].continueOffset += 3; - envPtr->exceptArrayPtr[nextRange].codeOffset += 3; - - /* - * Update the jump back to the test at the top of the loop since it - * also moved down 3 bytes. - */ + testCodeOffset = (envPtr->codeNext - envPtr->codeStart); - jumpBackOffset += 3; - jumpPc = (envPtr->codeStart + jumpBackOffset); - jumpBackDist += 3; - if (jumpBackDist > 120) { - TclUpdateInstInt4AtPc(INST_JUMP4, -jumpBackDist, jumpPc); - } else { - TclUpdateInstInt1AtPc(INST_JUMP1, -jumpBackDist, jumpPc); + jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset; + if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) { + bodyCodeOffset += 3; + nextCodeOffset += 3; + testCodeOffset += 3; + } + + envPtr->currStackDepth = savedStackDepth; + code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + Tcl_AddObjErrorInfo(interp, + "\n (\"for\" test expression)", -1); } + goto done; + } + envPtr->currStackDepth = savedStackDepth + 1; + + jumpDist = (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset; + if (jumpDist > 127) { + TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr); + } else { + TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr); } /* - * Set the loop's break target. + * Set the loop's offsets and break target. */ + envPtr->exceptArrayPtr[bodyRange].codeOffset = bodyCodeOffset; + envPtr->exceptArrayPtr[bodyRange].continueOffset = nextCodeOffset; + + envPtr->exceptArrayPtr[nextRange].codeOffset = nextCodeOffset; + envPtr->exceptArrayPtr[bodyRange].breakOffset = envPtr->exceptArrayPtr[nextRange].breakOffset = (envPtr->codeNext - envPtr->codeStart); @@ -550,14 +667,11 @@ TclCompileForCmd(interp, parsePtr, envPtr) * The for command's result is an empty string. */ - TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr); - if (maxDepth == 0) { - maxDepth = 1; - } + envPtr->currStackDepth = savedStackDepth; + TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); code = TCL_OK; done: - envPtr->maxStackDepth = maxDepth; envPtr->exceptDepth--; return code; } @@ -578,14 +692,11 @@ TclCompileForCmd(interp, parsePtr, envPtr) * should be compiled "out of line" by emitting code to invoke its * command procedure at runtime. * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the "while" command. - * * Side effects: * Instructions are added to envPtr to execute the "foreach" command * at runtime. * - *---------------------------------------------------------------------- +n*---------------------------------------------------------------------- */ int @@ -604,13 +715,12 @@ TclCompileForeachCmd(interp, parsePtr, envPtr) int loopCtTemp; /* Index of temp var holding the loop's * iteration count. */ Tcl_Token *tokenPtr, *bodyTokenPtr; - char *varList; unsigned char *jumpPc; JumpFixup jumpFalseFixup; - int jumpDist, jumpBackDist, jumpBackOffset, maxDepth, infoIndex, range; + int jumpDist, jumpBackDist, jumpBackOffset, infoIndex, range; int numWords, numLists, numVars, loopIndex, tempVar, i, j, code; - char savedChar; char buffer[32 + TCL_INTEGER_SPACE]; + int savedStackDepth = envPtr->currStackDepth; /* * We parse the variable list argument words and create two arrays: @@ -620,22 +730,19 @@ TclCompileForeachCmd(interp, parsePtr, envPtr) #define STATIC_VAR_LIST_SIZE 5 int varcListStaticSpace[STATIC_VAR_LIST_SIZE]; - char **varvListStaticSpace[STATIC_VAR_LIST_SIZE]; + CONST char **varvListStaticSpace[STATIC_VAR_LIST_SIZE]; int *varcList = varcListStaticSpace; - char ***varvList = varvListStaticSpace; + CONST char ***varvList = varvListStaticSpace; /* * If the foreach command isn't in a procedure, don't compile it inline: * the payoff is too small. */ - envPtr->maxStackDepth = 0; if (procPtr == NULL) { return TCL_OUT_LINE_COMPILE; } - maxDepth = 0; - numWords = parsePtr->numWords; if ((numWords < 4) || (numWords%2 != 0)) { Tcl_ResetResult(interp); @@ -645,17 +752,30 @@ TclCompileForeachCmd(interp, parsePtr, envPtr) } /* + * Bail out if the body requires substitutions + * in order to insure correct behaviour [Bug 219166] + */ + for (i = 0, tokenPtr = parsePtr->tokenPtr; + i < numWords-1; + i++, tokenPtr += (tokenPtr->numComponents + 1)) { + } + bodyTokenPtr = tokenPtr; + if (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_OUT_LINE_COMPILE; + } + + /* * Allocate storage for the varcList and varvList arrays if necessary. */ numLists = (numWords - 2)/2; if (numLists > STATIC_VAR_LIST_SIZE) { varcList = (int *) ckalloc(numLists * sizeof(int)); - varvList = (char ***) ckalloc(numLists * sizeof(char **)); + varvList = (CONST char ***) ckalloc(numLists * sizeof(CONST char **)); } for (loopIndex = 0; loopIndex < numLists; loopIndex++) { varcList[loopIndex] = 0; - varvList[loopIndex] = (char **) NULL; + varvList[loopIndex] = NULL; } /* @@ -680,32 +800,29 @@ TclCompileForeachCmd(interp, parsePtr, envPtr) if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { code = TCL_OUT_LINE_COMPILE; goto done; - } - varList = tokenPtr[1].start; - savedChar = varList[tokenPtr[1].size]; - - /* - * Note there is a danger that modifying the string could have - * undesirable side effects. In this case, Tcl_SplitList does - * not have any dependencies on shared strings so we should be - * safe. - */ + } else { + /* Lots of copying going on here. Need a ListObj wizard + * to show a better way. */ - varList[tokenPtr[1].size] = '\0'; - code = Tcl_SplitList(interp, varList, - &varcList[loopIndex], &varvList[loopIndex]); - varList[tokenPtr[1].size] = savedChar; - if (code != TCL_OK) { - goto done; - } + Tcl_DString varList; - numVars = varcList[loopIndex]; - for (j = 0; j < numVars; j++) { - char *varName = varvList[loopIndex][j]; - if (!TclIsLocalScalar(varName, (int) strlen(varName))) { - code = TCL_OUT_LINE_COMPILE; + Tcl_DStringInit(&varList); + Tcl_DStringAppend(&varList, tokenPtr[1].start, + tokenPtr[1].size); + code = Tcl_SplitList(interp, Tcl_DStringValue(&varList), + &varcList[loopIndex], &varvList[loopIndex]); + Tcl_DStringFree(&varList); + if (code != TCL_OK) { goto done; } + numVars = varcList[loopIndex]; + for (j = 0; j < numVars; j++) { + CONST char *varName = varvList[loopIndex][j]; + if (!TclIsLocalScalar(varName, (int) strlen(varName))) { + code = TCL_OUT_LINE_COMPILE; + goto done; + } + } } loopIndex++; } @@ -749,7 +866,7 @@ TclCompileForeachCmd(interp, parsePtr, envPtr) sizeof(ForeachVarList) + (numVars * sizeof(int))); varListPtr->numVars = numVars; for (j = 0; j < numVars; j++) { - char *varName = varvList[loopIndex][j]; + CONST char *varName = varvList[loopIndex][j]; int nameChars = strlen(varName); varListPtr->varIndexes[j] = TclFindCompiledLocal(varName, nameChars, /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr); @@ -774,7 +891,6 @@ TclCompileForeachCmd(interp, parsePtr, envPtr) if (code != TCL_OK) { goto done; } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); tempVar = (firstValueTemp + loopIndex); if (tempVar <= 255) { @@ -786,7 +902,6 @@ TclCompileForeachCmd(interp, parsePtr, envPtr) loopIndex++; } } - bodyTokenPtr = tokenPtr; /* * Initialize the temporary var that holds the count of loop iterations. @@ -812,6 +927,7 @@ TclCompileForeachCmd(interp, parsePtr, envPtr) (envPtr->codeNext - envPtr->codeStart); code = TclCompileCmdWord(interp, bodyTokenPtr+1, bodyTokenPtr->numComponents, envPtr); + envPtr->currStackDepth = savedStackDepth + 1; if (code != TCL_OK) { if (code == TCL_ERROR) { sprintf(buffer, "\n (\"foreach\" body line %d)", @@ -820,7 +936,6 @@ TclCompileForeachCmd(interp, parsePtr, envPtr) } goto done; } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); envPtr->exceptArrayPtr[range].numCodeBytes = (envPtr->codeNext - envPtr->codeStart) - envPtr->exceptArrayPtr[range].codeOffset; @@ -881,22 +996,20 @@ TclCompileForeachCmd(interp, parsePtr, envPtr) * The foreach command's result is an empty string. */ - TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr); - if (maxDepth == 0) { - maxDepth = 1; - } + envPtr->currStackDepth = savedStackDepth; + TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); + envPtr->currStackDepth = savedStackDepth + 1; done: for (loopIndex = 0; loopIndex < numLists; loopIndex++) { - if (varvList[loopIndex] != (char **) NULL) { - ckfree((char *) varvList[loopIndex]); - } + if (varvList[loopIndex] != (CONST char **) NULL) { + ckfree((char *) varvList[loopIndex]); + } } if (varcList != varcListStaticSpace) { ckfree((char *) varcList); ckfree((char *) varvList); } - envPtr->maxStackDepth = maxDepth; envPtr->exceptDepth--; return code; } @@ -1005,16 +1118,12 @@ FreeForeachInfo(clientData) * should be compiled "out of line" by emitting code to invoke its * command procedure at runtime. * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the command. - * * Side effects: * Instructions are added to envPtr to execute the "if" command * at runtime. * *---------------------------------------------------------------------- */ - int TclCompileIfCmd(interp, parsePtr, envPtr) Tcl_Interp *interp; /* Used for error reporting. */ @@ -1030,14 +1139,38 @@ TclCompileIfCmd(interp, parsePtr, envPtr) * body to the end of the "if" when that PC * is determined. */ Tcl_Token *tokenPtr, *testTokenPtr; - int jumpDist, jumpFalseDist, jumpIndex; - int numWords, wordIdx, numBytes, maxDepth, j, code; - char *word; + int jumpDist, jumpFalseDist; + int jumpIndex = 0; /* avoid compiler warning. */ + int numWords, wordIdx, numBytes, j, code; + CONST char *word; char buffer[100]; + int savedStackDepth = envPtr->currStackDepth; + /* Saved stack depth at the start of the first + * test; the envPtr current depth is restored + * to this value at the start of each test. */ + int realCond = 1; /* set to 0 for static conditions: "if 0 {..}" */ + int boolVal; /* value of static condition */ + int compileScripts = 1; + + /* + * Only compile the "if" command if all arguments are simple + * words, in order to insure correct substitution [Bug 219166] + */ + + tokenPtr = parsePtr->tokenPtr; + wordIdx = 0; + numWords = parsePtr->numWords; + + for (wordIdx = 0; wordIdx < numWords; wordIdx++) { + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_OUT_LINE_COMPILE; + } + tokenPtr += 2; + } + TclInitJumpFixupArray(&jumpFalseFixupArray); TclInitJumpFixupArray(&jumpEndFixupArray); - maxDepth = 0; code = TCL_OK; /* @@ -1047,15 +1180,11 @@ TclCompileIfCmd(interp, parsePtr, envPtr) tokenPtr = parsePtr->tokenPtr; wordIdx = 0; - numWords = parsePtr->numWords; while (wordIdx < numWords) { /* * Stop looping if the token isn't "if" or "elseif". */ - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - break; - } word = tokenPtr[1].start; numBytes = tokenPtr[1].size; if ((tokenPtr == parsePtr->tokenPtr) @@ -1077,28 +1206,52 @@ TclCompileIfCmd(interp, parsePtr, envPtr) /* * Compile the test expression then emit the conditional jump - * around the "then" part. If the expression word isn't simple, - * we back off and compile the if command out-of-line. + * around the "then" part. */ + envPtr->currStackDepth = savedStackDepth; testTokenPtr = tokenPtr; - code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr); - if (code != TCL_OK) { - if (code == TCL_ERROR) { - Tcl_AddObjErrorInfo(interp, - "\n (\"if\" test expression)", -1); + + + if (realCond) { + /* + * Find out if the condition is a constant. + */ + + Tcl_Obj *boolObj = Tcl_NewStringObj(testTokenPtr[1].start, + testTokenPtr[1].size); + Tcl_IncrRefCount(boolObj); + code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal); + Tcl_DecrRefCount(boolObj); + if (code == TCL_OK) { + /* + * A static condition + */ + realCond = 0; + if (!boolVal) { + compileScripts = 0; + } + } else { + Tcl_ResetResult(interp); + code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + Tcl_AddObjErrorInfo(interp, + "\n (\"if\" test expression)", -1); + } + goto done; + } + if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { + TclExpandJumpFixupArray(&jumpFalseFixupArray); + } + jumpIndex = jumpFalseFixupArray.next; + jumpFalseFixupArray.next++; + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, + &(jumpFalseFixupArray.fixup[jumpIndex])); } - goto done; - } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { - TclExpandJumpFixupArray(&jumpFalseFixupArray); } - jumpIndex = jumpFalseFixupArray.next; - jumpFalseFixupArray.next++; - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, - &(jumpFalseFixupArray.fixup[jumpIndex])); - + + /* * Skip over the optional "then" before the then clause. */ @@ -1132,56 +1285,83 @@ TclCompileIfCmd(interp, parsePtr, envPtr) * Compile the "then" command body. */ - code = TclCompileCmdWord(interp, tokenPtr+1, - tokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - if (code == TCL_ERROR) { - sprintf(buffer, "\n (\"if\" then script line %d)", - interp->errorLine); - Tcl_AddObjErrorInfo(interp, buffer, -1); - } - goto done; + if (compileScripts) { + envPtr->currStackDepth = savedStackDepth; + code = TclCompileCmdWord(interp, tokenPtr+1, + tokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + sprintf(buffer, "\n (\"if\" then script line %d)", + interp->errorLine); + Tcl_AddObjErrorInfo(interp, buffer, -1); + } + goto done; + } } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - /* - * Jump to the end of the "if" command. Both jumpFalseFixupArray and - * jumpEndFixupArray are indexed by "jumpIndex". - */ - - if (jumpEndFixupArray.next >= jumpEndFixupArray.end) { - TclExpandJumpFixupArray(&jumpEndFixupArray); - } - jumpEndFixupArray.next++; - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &(jumpEndFixupArray.fixup[jumpIndex])); + if (realCond) { + /* + * Jump to the end of the "if" command. Both jumpFalseFixupArray and + * jumpEndFixupArray are indexed by "jumpIndex". + */ + + if (jumpEndFixupArray.next >= jumpEndFixupArray.end) { + TclExpandJumpFixupArray(&jumpEndFixupArray); + } + jumpEndFixupArray.next++; + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, + &(jumpEndFixupArray.fixup[jumpIndex])); + + /* + * Fix the target of the jumpFalse after the test. Generate a 4 byte + * jump if the distance is > 120 bytes. This is conservative, and + * ensures that we won't have to replace this jump if we later also + * need to replace the proceeding jump to the end of the "if" with a + * 4 byte jump. + */ - /* - * Fix the target of the jumpFalse after the test. Generate a 4 byte - * jump if the distance is > 120 bytes. This is conservative, and - * ensures that we won't have to replace this jump if we later also - * need to replace the proceeding jump to the end of the "if" with a - * 4 byte jump. - */ + jumpDist = (envPtr->codeNext - envPtr->codeStart) + - jumpFalseFixupArray.fixup[jumpIndex].codeOffset; + if (TclFixupForwardJump(envPtr, + &(jumpFalseFixupArray.fixup[jumpIndex]), jumpDist, 120)) { + /* + * Adjust the code offset for the proceeding jump to the end + * of the "if" command. + */ + + jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3; + } + } else if (boolVal) { + /* + *We were processing an "if 1 {...}"; stop compiling + * scripts + */ - jumpDist = (envPtr->codeNext - envPtr->codeStart) - - jumpFalseFixupArray.fixup[jumpIndex].codeOffset; - if (TclFixupForwardJump(envPtr, - &(jumpFalseFixupArray.fixup[jumpIndex]), jumpDist, 120)) { - /* - * Adjust the code offset for the proceeding jump to the end - * of the "if" command. + compileScripts = 0; + } else { + /* + *We were processing an "if 0 {...}"; reset so that + * the rest (elseif, else) is compiled correctly */ - jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3; - } + realCond = 1; + compileScripts = 1; + } tokenPtr += (tokenPtr->numComponents + 1); wordIdx++; } /* - * Check for the optional else clause. + * Restore the current stack depth in the environment; the + * "else" clause (or its default) will add 1 to this. + */ + + envPtr->currStackDepth = savedStackDepth; + + /* + * Check for the optional else clause. Do not compile + * anything if this was an "if 1 {...}" case. */ if ((wordIdx < numWords) @@ -1189,7 +1369,7 @@ TclCompileIfCmd(interp, parsePtr, envPtr) /* * There is an else clause. Skip over the optional "else" word. */ - + word = tokenPtr[1].start; numBytes = tokenPtr[1].size; if ((numBytes == 4) && (strncmp(word, "else", 4) == 0)) { @@ -1204,21 +1384,22 @@ TclCompileIfCmd(interp, parsePtr, envPtr) } } - /* - * Compile the else command body. - */ - - code = TclCompileCmdWord(interp, tokenPtr+1, - tokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - if (code == TCL_ERROR) { - sprintf(buffer, "\n (\"if\" else script line %d)", - interp->errorLine); - Tcl_AddObjErrorInfo(interp, buffer, -1); + if (compileScripts) { + /* + * Compile the else command body. + */ + + code = TclCompileCmdWord(interp, tokenPtr+1, + tokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + sprintf(buffer, "\n (\"if\" else script line %d)", + interp->errorLine); + Tcl_AddObjErrorInfo(interp, buffer, -1); + } + goto done; } - goto done; } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); /* * Make sure there are no words after the else clause. @@ -1237,8 +1418,9 @@ TclCompileIfCmd(interp, parsePtr, envPtr) * No else clause: the "if" command's result is an empty string. */ - TclEmitPush(TclRegisterLiteral(envPtr, "", 0,/*onHeap*/ 0), envPtr); - maxDepth = TclMax(1, maxDepth); + if (compileScripts) { + TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); + } } /* @@ -1272,15 +1454,15 @@ TclCompileIfCmd(interp, parsePtr, envPtr) } } } - + /* * Free the jumpFixupArray array if malloc'ed storage was used. */ done: + envPtr->currStackDepth = savedStackDepth + 1; TclFreeJumpFixupArray(&jumpFalseFixupArray); TclFreeJumpFixupArray(&jumpEndFixupArray); - envPtr->maxStackDepth = maxDepth; return code; } @@ -1300,9 +1482,6 @@ TclCompileIfCmd(interp, parsePtr, envPtr) * should be compiled "out of line" by emitting code to invoke its * command procedure at runtime. * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the "incr" command. - * * Side effects: * Instructions are added to envPtr to execute the "incr" command * at runtime. @@ -1318,119 +1497,26 @@ TclCompileIncrCmd(interp, parsePtr, envPtr) CompileEnv *envPtr; /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr, *incrTokenPtr; - Tcl_Parse elemParse; - int gotElemParse = 0; - char *name, *elName, *p; - int nameChars, elNameChars, haveImmValue, immValue, localIndex, i, code; - int maxDepth = 0; - char buffer[160]; - - envPtr->maxStackDepth = 0; + int simpleVarName, isScalar, localIndex, haveImmValue, immValue; + int code = TCL_OK; + if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) { Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), "wrong # args: should be \"incr varName ?increment?\"", -1); return TCL_ERROR; } - - name = NULL; - elName = NULL; - elNameChars = 0; - localIndex = -1; - code = TCL_OK; varTokenPtr = parsePtr->tokenPtr + (parsePtr->tokenPtr->numComponents + 1); - /* - * Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether - * curly braces surround the variable name. - * This really matters for array elements to handle things like - * set {x($foo)} 5 - * which raises an undefined var error if we are not careful here. - * This goes with the hack in TclCompileSetCmd. - */ - if ((varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) && - (varTokenPtr->start[0] != '{')) { - /* - * A simple variable name. Divide it up into "name" and "elName" - * strings. If it is not a local variable, look it up at runtime. - */ - - name = varTokenPtr[1].start; - nameChars = varTokenPtr[1].size; - for (i = 0, p = name; i < nameChars; i++, p++) { - if (*p == '(') { - char *openParen = p; - p = (name + nameChars-1); - if (*p == ')') { /* last char is ')' => array reference */ - nameChars = (openParen - name); - elName = openParen+1; - elNameChars = (p - elName); - } - break; - } - } - if (envPtr->procPtr != NULL) { - localIndex = TclFindCompiledLocal(name, nameChars, - /*create*/ 0, /*flags*/ 0, envPtr->procPtr); - if (localIndex > 255) { /* we'll push the name */ - localIndex = -1; - } - } - if (localIndex < 0) { - TclEmitPush(TclRegisterLiteral(envPtr, name, nameChars, - /*onHeap*/ 0), envPtr); - maxDepth = 1; - } - /* - * Compile the element script, if any. - */ - - if (elName != NULL) { - /* - * Temporarily replace the '(' and ')' by '"'s. - */ - - *(elName-1) = '"'; - *(elName+elNameChars) = '"'; - code = Tcl_ParseCommand(interp, elName-1, elNameChars+2, - /*nested*/ 0, &elemParse); - *(elName-1) = '('; - *(elName+elNameChars) = ')'; - gotElemParse = 1; - if ((code != TCL_OK) || (elemParse.numWords > 1)) { - sprintf(buffer, "\n (parsing index for array \"%.*s\")", - TclMin(nameChars, 100), name); - Tcl_AddObjErrorInfo(interp, buffer, -1); - code = TCL_ERROR; - goto done; - } else if (elemParse.numWords == 1) { - code = TclCompileTokens(interp, elemParse.tokenPtr+1, - elemParse.tokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - goto done; - } - maxDepth += envPtr->maxStackDepth; - } else { - TclEmitPush(TclRegisterLiteral(envPtr, "", 0, - /*alreadyAlloced*/ 0), envPtr); - maxDepth += 1; - } - } - } else { - /* - * Not a simple variable name. Look it up at runtime. - */ - - code = TclCompileTokens(interp, varTokenPtr+1, - varTokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; + code = TclPushVarName(interp, varTokenPtr, envPtr, + (TCL_NO_LARGE_INDEX | TCL_CREATE_VAR), + &localIndex, &simpleVarName, &isScalar); + if (code != TCL_OK) { + goto done; } - + /* * If an increment is given, push it, but see first if it's a small * integer. @@ -1441,11 +1527,11 @@ TclCompileIncrCmd(interp, parsePtr, envPtr) if (parsePtr->numWords == 3) { incrTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - char *word = incrTokenPtr[1].start; + CONST char *word = incrTokenPtr[1].start; int numBytes = incrTokenPtr[1].size; - char savedChar = word[numBytes]; + int validLength = TclParseInteger(word, numBytes); long n; - + /* * Note there is a danger that modifying the string could have * undesirable side effects. In this case, TclLooksLikeInt and @@ -1453,19 +1539,20 @@ TclCompileIncrCmd(interp, parsePtr, envPtr) * should be safe. */ - word[numBytes] = '\0'; - if (TclLooksLikeInt(word, numBytes) - && (TclGetLong((Tcl_Interp *) NULL, word, &n) == TCL_OK)) { - if ((-127 <= n) && (n <= 127)) { + if (validLength == numBytes) { + int code; + Tcl_Obj *longObj = Tcl_NewStringObj(word, numBytes); + Tcl_IncrRefCount(longObj); + code = Tcl_GetLongFromObj(NULL, longObj, &n); + Tcl_DecrRefCount(longObj); + if ((code == TCL_OK) && (-127 <= n) && (n <= 127)) { haveImmValue = 1; immValue = n; } } - word[numBytes] = savedChar; if (!haveImmValue) { - TclEmitPush(TclRegisterLiteral(envPtr, word, numBytes, - /*onHeap*/ 0), envPtr); - maxDepth += 1; + TclEmitPush( + TclRegisterNewLiteral(envPtr, word, numBytes), envPtr); } } else { code = TclCompileTokens(interp, incrTokenPtr+1, @@ -1477,7 +1564,6 @@ TclCompileIncrCmd(interp, parsePtr, envPtr) } goto done; } - maxDepth += envPtr->maxStackDepth; } } else { /* no incr amount given so use 1 */ haveImmValue = 1; @@ -1488,20 +1574,18 @@ TclCompileIncrCmd(interp, parsePtr, envPtr) * Emit the instruction to increment the variable. */ - if (name != NULL) { - if (elName == NULL) { + if (simpleVarName) { + if (isScalar) { if (localIndex >= 0) { if (haveImmValue) { - TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, - envPtr); + TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, envPtr); TclEmitInt1(immValue, envPtr); } else { TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr); } } else { if (haveImmValue) { - TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immValue, - envPtr); + TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immValue, envPtr); } else { TclEmitOpcode(INST_INCR_SCALAR_STK, envPtr); } @@ -1509,16 +1593,14 @@ TclCompileIncrCmd(interp, parsePtr, envPtr) } else { if (localIndex >= 0) { if (haveImmValue) { - TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex, - envPtr); + TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex, envPtr); TclEmitInt1(immValue, envPtr); } else { TclEmitInstInt1(INST_INCR_ARRAY1, localIndex, envPtr); } } else { if (haveImmValue) { - TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue, - envPtr); + TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue, envPtr); } else { TclEmitOpcode(INST_INCR_ARRAY_STK, envPtr); } @@ -1533,66 +1615,64 @@ TclCompileIncrCmd(interp, parsePtr, envPtr) } done: - if (gotElemParse) { - Tcl_FreeParse(&elemParse); - } - envPtr->maxStackDepth = maxDepth; return code; } /* *---------------------------------------------------------------------- * - * TclCompileSetCmd -- + * TclCompileLappendCmd -- * - * Procedure called to compile the "set" command. + * Procedure called to compile the "lappend" command. * * Results: * The return value is a standard Tcl result, which is normally TCL_OK * unless there was an error while parsing string. If an error occurs * then the interpreter's result contains a standard error message. If - * complation fails because the set command requires a second level of + * complation fails because the command requires a second level of * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the - * set command should be compiled "out of line" by emitting code to - * invoke its command procedure (Tcl_SetCmd) at runtime. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the incr command. + * command should be compiled "out of line" by emitting code to + * invoke its command procedure (Tcl_LappendObjCmd) at runtime. * * Side effects: - * Instructions are added to envPtr to execute the "set" command + * Instructions are added to envPtr to execute the "lappend" command * at runtime. * *---------------------------------------------------------------------- */ int -TclCompileSetCmd(interp, parsePtr, envPtr) +TclCompileLappendCmd(interp, parsePtr, envPtr) Tcl_Interp *interp; /* Used for error reporting. */ Tcl_Parse *parsePtr; /* Points to a parse structure for the * command created by Tcl_ParseCommand. */ CompileEnv *envPtr; /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr, *valueTokenPtr; - Tcl_Parse elemParse; - int gotElemParse = 0; - register char *p; - char *name, *elName; - int nameChars, elNameChars; - register int i, n; - int isAssignment, simpleVarName, localIndex, numWords; - int maxDepth = 0; + int numValues, simpleVarName, isScalar, localIndex, numWords; int code = TCL_OK; - envPtr->maxStackDepth = 0; + /* + * If we're not in a procedure, don't compile. + */ + if (envPtr->procPtr == NULL) { + return TCL_OUT_LINE_COMPILE; + } + numWords = parsePtr->numWords; - if ((numWords != 2) && (numWords != 3)) { + if (numWords == 1) { Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"set varName ?newValue?\"", -1); - return TCL_ERROR; + "wrong # args: should be \"lappend varName ?value value ...?\"", -1); + return TCL_ERROR; } - isAssignment = (numWords == 3); + if (numWords != 3) { + /* + * LAPPEND instructions currently only handle one value appends + */ + return TCL_OUT_LINE_COMPILE; + } + numValues = (numWords - 2); /* * Decide if we can use a frame slot for the var/array name or if we @@ -1602,196 +1682,852 @@ TclCompileSetCmd(interp, parsePtr, envPtr) * namespace qualifiers. */ - simpleVarName = 0; - name = elName = NULL; - nameChars = elNameChars = 0; - localIndex = -1; - varTokenPtr = parsePtr->tokenPtr + (parsePtr->tokenPtr->numComponents + 1); + + code = TclPushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, + &localIndex, &simpleVarName, &isScalar); + if (code != TCL_OK) { + goto done; + } + /* - * Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether - * curly braces surround the variable name. - * This really matters for array elements to handle things like - * set {x($foo)} 5 - * which raises an undefined var error if we are not careful here. - * This goes with the hack in TclCompileIncrCmd. + * If we are doing an assignment, push the new value. + * In the no values case, create an empty object. */ - if ((varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) && - (varTokenPtr->start[0] != '{')) { - simpleVarName = 1; - name = varTokenPtr[1].start; - nameChars = varTokenPtr[1].size; - /* last char is ')' => potential array reference */ - if ( *(name + nameChars - 1) == ')') { - for (i = 0, p = name; i < nameChars; i++, p++) { - if (*p == '(') { - elName = p + 1; - elNameChars = nameChars - i - 2; - nameChars = i ; - break; - } + if (numWords > 2) { + valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + TclEmitPush(TclRegisterNewLiteral(envPtr, + valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr); + } else { + code = TclCompileTokens(interp, valueTokenPtr+1, + valueTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + goto done; } } - +#if 0 + } else { /* - * If elName contains any double quotes ("), we can't inline - * compile the element script using the replace '()' by '"' - * technique below. + * We need to carefully handle the two arg case, as lappend + * always creates the variable. */ - for (i = 0, p = elName; i < elNameChars; i++, p++) { - if (*p == '"') { - simpleVarName = 0; - break; + TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); + numValues = 1; +#endif + } + + /* + * Emit instructions to set/get the variable. + */ + + /* + * The *_STK opcodes should be refactored to make better use of existing + * LOAD/STORE instructions. + */ + if (simpleVarName) { + if (isScalar) { + if (localIndex >= 0) { + if (localIndex <= 255) { + TclEmitInstInt1(INST_LAPPEND_SCALAR1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_LAPPEND_SCALAR4, localIndex, envPtr); + } + } else { + TclEmitOpcode(INST_LAPPEND_STK, envPtr); + } + } else { + if (localIndex >= 0) { + if (localIndex <= 255) { + TclEmitInstInt1(INST_LAPPEND_ARRAY1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_LAPPEND_ARRAY4, localIndex, envPtr); + } + } else { + TclEmitOpcode(INST_LAPPEND_ARRAY_STK, envPtr); } } - } else if (((n = varTokenPtr->numComponents) > 1) - && (varTokenPtr[1].type == TCL_TOKEN_TEXT) - && (varTokenPtr[n].type == TCL_TOKEN_TEXT) - && (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) { - simpleVarName = 0; + } else { + TclEmitOpcode(INST_LAPPEND_STK, envPtr); + } - /* - * Check for parentheses inside first token - */ - for (i = 0, p = varTokenPtr[1].start; - i < varTokenPtr[1].size; i++, p++) { - if (*p == '(') { - simpleVarName = 1; - break; - } - } - if (simpleVarName) { - name = varTokenPtr[1].start; - nameChars = p - varTokenPtr[1].start; - elName = p + 1; - elNameChars = (varTokenPtr[n].start - p) + varTokenPtr[n].size - 2; + done: + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileLindexCmd -- + * + * Procedure called to compile the "lindex" command. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK if the + * compilation was successful. If the command cannot be byte-compiled, + * TCL_OUT_LINE_COMPILE is returned. If an error occurs then the + * interpreter's result contains an error message, and TCL_ERROR is + * returned. + * + * Side effects: + * Instructions are added to envPtr to execute the "lindex" command + * at runtime. + * + *---------------------------------------------------------------------- + */ - /* - * If elName contains any double quotes ("), we can't inline - * compile the element script using the replace '()' by '"' - * technique below. - */ - - for (i = 0, p = elName; i < elNameChars; i++, p++) { - if (*p == '"') { - simpleVarName = 0; - break; - } - } - } +int +TclCompileLindexCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Tcl_Token *varTokenPtr; + int code, i; + + int numWords; + numWords = parsePtr->numWords; + + /* + * Quit if too few args + */ + + if ( numWords <= 1 ) { + return TCL_OUT_LINE_COMPILE; } - if (simpleVarName) { + varTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + + /* + * Push the operands onto the stack. + */ + + for ( i = 1 ; i < numWords ; i++ ) { + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + TclEmitPush( + TclRegisterNewLiteral( envPtr, varTokenPtr[1].start, + varTokenPtr[1].size), envPtr); + } else { + code = TclCompileTokens(interp, varTokenPtr+1, + varTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + return code; + } + } + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + } + + /* + * Emit INST_LIST_INDEX if objc==3, or INST_LIST_INDEX_MULTI + * if there are multiple index args. + */ + + if ( numWords == 3 ) { + TclEmitOpcode( INST_LIST_INDEX, envPtr ); + } else { + TclEmitInstInt4( INST_LIST_INDEX_MULTI, numWords-1, envPtr ); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileListCmd -- + * + * Procedure called to compile the "list" command. + * + * Results: + * The return value is a standard Tcl result, which is normally TCL_OK + * unless there was an error while parsing string. If an error occurs + * then the interpreter's result contains a standard error message. If + * complation fails because the command requires a second level of + * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the + * command should be compiled "out of line" by emitting code to + * invoke its command procedure (Tcl_ListObjCmd) at runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "list" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileListCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + /* + * If we're not in a procedure, don't compile. + */ + if (envPtr->procPtr == NULL) { + return TCL_OUT_LINE_COMPILE; + } + + if (parsePtr->numWords == 1) { /* - * See whether name has any namespace separators (::'s). + * Empty args case */ - int hasNsQualifiers = 0; - for (i = 0, p = name; i < nameChars; i++, p++) { - if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) { - hasNsQualifiers = 1; - break; + TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); + } else { + /* + * Push the all values onto the stack. + */ + Tcl_Token *valueTokenPtr; + int i, code, numWords; + + numWords = parsePtr->numWords; + + valueTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + for (i = 1; i < numWords; i++) { + if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + TclEmitPush(TclRegisterNewLiteral(envPtr, + valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr); + } else { + code = TclCompileTokens(interp, valueTokenPtr+1, + valueTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + return code; + } } + valueTokenPtr = valueTokenPtr + (valueTokenPtr->numComponents + 1); } - + TclEmitInstInt4(INST_LIST, numWords - 1, envPtr); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileLlengthCmd -- + * + * Procedure called to compile the "llength" command. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK if the + * compilation was successful. If the command cannot be byte-compiled, + * TCL_OUT_LINE_COMPILE is returned. If an error occurs then the + * interpreter's result contains an error message, and TCL_ERROR is + * returned. + * + * Side effects: + * Instructions are added to envPtr to execute the "llength" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLlengthCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Tcl_Token *varTokenPtr; + int code; + + if (parsePtr->numWords != 2) { + Tcl_SetResult(interp, "wrong # args: should be \"llength list\"", + TCL_STATIC); + return TCL_ERROR; + } + varTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { /* - * Look up the var name's index in the array of local vars in the - * proc frame. If retrieving the var's value and it doesn't already - * exist, push its name and look it up at runtime. + * We could simply count the number of elements here and push + * that value, but that is too rare a case to waste the code space. */ + TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start, + varTokenPtr[1].size), envPtr); + } else { + code = TclCompileTokens(interp, varTokenPtr+1, + varTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + return code; + } + } + TclEmitOpcode(INST_LIST_LENGTH, envPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileLsetCmd -- + * + * Procedure called to compile the "lset" command. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK if + * the compilation was successful. If the "lset" command is too + * complex for this function, then TCL_OUT_LINE_COMPILE is returned, + * indicating that the command should be compiled "out of line" + * (that is, not byte-compiled). If an error occurs, TCL_ERROR is + * returned, and the interpreter result contains an error message. + * + * Side effects: + * Instructions are added to envPtr to execute the "lset" command + * at runtime. + * + * The general template for execution of the "lset" command is: + * (1) Instructions to push the variable name, unless the + * variable is local to the stack frame. + * (2) If the variable is an array element, instructions + * to push the array element name. + * (3) Instructions to push each of zero or more "index" arguments + * to the stack, followed with the "newValue" element. + * (4) Instructions to duplicate the variable name and/or array + * element name onto the top of the stack, if either was + * pushed at steps (1) and (2). + * (5) The appropriate INST_LOAD_* instruction to place the + * original value of the list variable at top of stack. + * (6) At this point, the stack contains: + * varName? arrayElementName? index1 index2 ... newValue oldList + * The compiler emits one of INST_LSET_FLAT or INST_LSET_LIST + * according as whether there is exactly one index element (LIST) + * or either zero or else two or more (FLAT). This instruction + * removes everything from the stack except for the two names + * and pushes the new value of the variable. + * (7) Finally, INST_STORE_* stores the new value in the variable + * and cleans up the stack. + * + *---------------------------------------------------------------------- + */ - if ((envPtr->procPtr != NULL) && !hasNsQualifiers) { - localIndex = TclFindCompiledLocal(name, nameChars, - /*create*/ isAssignment, - /*flags*/ ((elName==NULL)? VAR_SCALAR : VAR_ARRAY), - envPtr->procPtr); +int +TclCompileLsetCmd( interp, parsePtr, envPtr ) + Tcl_Interp* interp; /* Tcl interpreter for error reporting */ + Tcl_Parse* parsePtr; /* Points to a parse structure for + * the command */ + CompileEnv* envPtr; /* Holds the resulting instructions */ +{ + + int tempDepth; /* Depth used for emitting one part + * of the code burst. */ + Tcl_Token* varTokenPtr; /* Pointer to the Tcl_Token representing + * the parse of the variable name */ + + int result; /* Status return from library calls */ + + int localIndex; /* Index of var in local var table */ + int simpleVarName; /* Flag == 1 if var name is simple */ + int isScalar; /* Flag == 1 if scalar, 0 if array */ + + int i; + + /* Check argument count */ + + if ( parsePtr->numWords < 3 ) { + /* Fail at run time, not in compilation */ + return TCL_OUT_LINE_COMPILE; + } + + /* + * Decide if we can use a frame slot for the var/array name or if we + * need to emit code to compute and push the name at runtime. We use a + * frame slot (entry in the array of local vars) if we are compiling a + * procedure body and if the name is simple text that does not include + * namespace qualifiers. + */ + + varTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + result = TclPushVarName( interp, varTokenPtr, envPtr, + TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar ); + if (result != TCL_OK) { + return result; + } + + /* Push the "index" args and the new element value. */ + + for ( i = 2; i < parsePtr->numWords; ++i ) { + + /* Advance to next arg */ + + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + + /* Push an arg */ + + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + TclEmitPush(TclRegisterNewLiteral( envPtr, varTokenPtr[1].start, + varTokenPtr[1].size), envPtr); + } else { + result = TclCompileTokens(interp, varTokenPtr+1, + varTokenPtr->numComponents, envPtr); + if ( result != TCL_OK ) { + return result; + } + } + } + + /* + * Duplicate the variable name if it's been pushed. + */ + + if ( !simpleVarName || localIndex < 0 ) { + if ( !simpleVarName || isScalar ) { + tempDepth = parsePtr->numWords - 2; + } else { + tempDepth = parsePtr->numWords - 1; + } + TclEmitInstInt4( INST_OVER, tempDepth, envPtr ); + } + + /* + * Duplicate an array index if one's been pushed + */ + + if ( simpleVarName && !isScalar ) { + if ( localIndex < 0 ) { + tempDepth = parsePtr->numWords - 1; + } else { + tempDepth = parsePtr->numWords - 2; + } + TclEmitInstInt4( INST_OVER, tempDepth, envPtr ); + } + + /* + * Emit code to load the variable's value. + */ + + if ( !simpleVarName ) { + TclEmitOpcode( INST_LOAD_STK, envPtr ); + } else if ( isScalar ) { + if ( localIndex < 0 ) { + TclEmitOpcode( INST_LOAD_SCALAR_STK, envPtr ); + } else if ( localIndex < 0x100 ) { + TclEmitInstInt1( INST_LOAD_SCALAR1, localIndex, envPtr ); + } else { + TclEmitInstInt4( INST_LOAD_SCALAR4, localIndex, envPtr ); + } + } else { + if ( localIndex < 0 ) { + TclEmitOpcode( INST_LOAD_ARRAY_STK, envPtr ); + } else if ( localIndex < 0x100 ) { + TclEmitInstInt1( INST_LOAD_ARRAY1, localIndex, envPtr ); + } else { + TclEmitInstInt4( INST_LOAD_ARRAY4, localIndex, envPtr ); + } + } + + /* + * Emit the correct variety of 'lset' instruction + */ + + if ( parsePtr->numWords == 4 ) { + TclEmitOpcode( INST_LSET_LIST, envPtr ); + } else { + TclEmitInstInt4( INST_LSET_FLAT, (parsePtr->numWords - 1), envPtr ); + } + + /* + * Emit code to put the value back in the variable + */ + + if ( !simpleVarName ) { + TclEmitOpcode( INST_STORE_STK, envPtr ); + } else if ( isScalar ) { + if ( localIndex < 0 ) { + TclEmitOpcode( INST_STORE_SCALAR_STK, envPtr ); + } else if ( localIndex < 0x100 ) { + TclEmitInstInt1( INST_STORE_SCALAR1, localIndex, envPtr ); + } else { + TclEmitInstInt4( INST_STORE_SCALAR4, localIndex, envPtr ); + } + } else { + if ( localIndex < 0 ) { + TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr ); + } else if ( localIndex < 0x100 ) { + TclEmitInstInt1( INST_STORE_ARRAY1, localIndex, envPtr ); + } else { + TclEmitInstInt4( INST_STORE_ARRAY4, localIndex, envPtr ); + } + } + + return TCL_OK; + +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileRegexpCmd -- + * + * Procedure called to compile the "regexp" command. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK if + * the compilation was successful. If the "regexp" command is too + * complex for this function, then TCL_OUT_LINE_COMPILE is returned, + * indicating that the command should be compiled "out of line" + * (that is, not byte-compiled). If an error occurs, TCL_ERROR is + * returned, and the interpreter result contains an error message. + * + * Side effects: + * Instructions are added to envPtr to execute the "regexp" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileRegexpCmd(interp, parsePtr, envPtr) + Tcl_Interp* interp; /* Tcl interpreter for error reporting */ + Tcl_Parse* parsePtr; /* Points to a parse structure for + * the command */ + CompileEnv* envPtr; /* Holds the resulting instructions */ +{ + Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing + * the parse of the RE or string */ + int i, len, code, exactMatch, nocase; + Tcl_Obj *patternObj; + CONST char *str; + + /* + * We are only interested in compiling simple regexp cases. + * Currently supported compile cases are: + * regexp ?-nocase? ?--? staticString $var + * regexp ?-nocase? ?--? {^staticString$} $var + */ + if (parsePtr->numWords < 3) { + return TCL_OUT_LINE_COMPILE; + } + + nocase = 0; + varTokenPtr = parsePtr->tokenPtr; + + /* + * We only look for -nocase and -- as options. Everything else + * gets pushed to runtime execution. This is different than regexp's + * runtime option handling, but satisfies our stricter needs. + */ + for (i = 1; i < parsePtr->numWords - 2; i++) { + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + /* Not a simple string - punt to runtime. */ + return TCL_OUT_LINE_COMPILE; } - if (localIndex >= 0) { - maxDepth = 0; + str = varTokenPtr[1].start; + len = varTokenPtr[1].size; + if ((len == 2) && (str[0] == '-') && (str[1] == '-')) { + i++; + break; + } else if ((len > 1) + && (strncmp(str, "-nocase", (unsigned) len) == 0)) { + nocase = 1; } else { - TclEmitPush(TclRegisterLiteral(envPtr, name, nameChars, - /*onHeap*/ 0), envPtr); - maxDepth = 1; + /* Not an option we recognize. */ + return TCL_OUT_LINE_COMPILE; } + } + + if ((parsePtr->numWords - i) != 2) { + /* We don't support capturing to variables */ + return TCL_OUT_LINE_COMPILE; + } + + /* + * Get the regexp string. If it is not a simple string, punt to runtime. + * If it has a '-', it could be an incorrectly formed regexp command. + */ + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + str = varTokenPtr[1].start; + len = varTokenPtr[1].size; + if ((varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) || (*str == '-')) { + return TCL_OUT_LINE_COMPILE; + } + if (len == 0) { /* - * Compile the element script, if any. + * The semantics of regexp are always match on re == "". */ - - if (elName != NULL) { - /* - * Temporarily replace the '(' and ')' by '"'s. - */ + TclEmitPush(TclRegisterNewLiteral(envPtr, "1", 1), envPtr); + return TCL_OK; + } - *(elName-1) = '"'; - *(elName+elNameChars) = '"'; - code = Tcl_ParseCommand(interp, elName-1, elNameChars+2, - /*nested*/ 0, &elemParse); - *(elName-1) = '('; - *(elName+elNameChars) = ')'; - gotElemParse = 1; - if ((code != TCL_OK) || (elemParse.numWords > 1)) { - char buffer[160]; - sprintf(buffer, "\n (parsing index for array \"%.*s\")", - TclMin(nameChars, 100), name); - Tcl_AddObjErrorInfo(interp, buffer, -1); - code = TCL_ERROR; - goto done; - } else if (elemParse.numWords == 1) { - code = TclCompileTokens(interp, elemParse.tokenPtr+1, - elemParse.tokenPtr->numComponents, envPtr); - if (code != TCL_OK) { - goto done; - } - maxDepth += envPtr->maxStackDepth; - } else { - TclEmitPush(TclRegisterLiteral(envPtr, "", 0, - /*alreadyAlloced*/ 0), envPtr); - maxDepth += 1; - } - } + /* + * On the first (pattern) arg, check to see if any RE special characters + * are in the word. If not, this is the same as 'string equal'. + * We can use strchr here because the glob chars are all in the ascii-7 + * range. If -nocase was specified, we can't do this because INST_STR_EQ + * has no support for nocase. + */ + + if (Tcl_RegExpCompile(NULL, str) == NULL) { + /* + * This is a bad RE. Let it complain at runtime. + */ + return TCL_OUT_LINE_COMPILE; + } +#if 0 + if ((len > 2) && (*str == '.') && (str[1] == '*')) { + str += 2; len -= 2; + } + if ((len > 2) && (str[len-3] != '\\') + && (str[len-2] == '.') && (str[len-1] == '*')) { + len -= 2; + } +#endif + if ((len > 1) && (str[0] == '^') && (str[len-1] == '$') + && (str[len-2] != '\\')) { + /* + * It appears and exact search was requested (ie ^foo$), so strip + * off the special chars and signal exactMatch. + */ + str++; len -= 2; + exactMatch = 1; + } else { + exactMatch = 0; + } + + patternObj = Tcl_NewStringObj(str, len); + Tcl_IncrRefCount(patternObj); + code = (strpbrk(Tcl_GetString(patternObj), "*+?{}()[].\\|^$") != NULL); + Tcl_DecrRefCount(patternObj); + if (code) { + /* We don't do anything with REs with special chars yet. */ + return TCL_OUT_LINE_COMPILE; + } + if (exactMatch) { + TclEmitPush(TclRegisterNewLiteral(envPtr, str, len), envPtr); } else { /* - * The var name isn't simple: compile and push it. + * This needs to find the substring anywhere in the string, so + * use string match and *foo*. */ + char *newStr = ckalloc((unsigned) len + 3); + newStr[0] = '*'; + strncpy(newStr + 1, str, (size_t) len); + newStr[len+1] = '*'; + newStr[len+2] = '\0'; + TclEmitPush(TclRegisterNewLiteral(envPtr, newStr, len+2), envPtr); + ckfree((char *) newStr); + } + /* + * Push the string arg + */ + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + TclEmitPush(TclRegisterNewLiteral(envPtr, + varTokenPtr[1].start, varTokenPtr[1].size), envPtr); + } else { code = TclCompileTokens(interp, varTokenPtr+1, varTokenPtr->numComponents, envPtr); if (code != TCL_OK) { - goto done; + return code; } - maxDepth += envPtr->maxStackDepth; } - + + if (exactMatch && !nocase) { + TclEmitOpcode(INST_STR_EQ, envPtr); + } else { + TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileReturnCmd -- + * + * Procedure called to compile the "return" command. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK if the + * compilation was successful. If the particular return command is + * too complex for this function (ie, return with any flags like "-code" + * or "-errorinfo"), TCL_OUT_LINE_COMPILE is returned, indicating that + * the command should be compiled "out of line" (eg, not byte compiled). + * If an error occurs then the interpreter's result contains a standard + * error message. + * + * Side effects: + * Instructions are added to envPtr to execute the "return" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileReturnCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Tcl_Token *varTokenPtr; + int code; + + /* + * If we're not in a procedure, don't compile. + */ + + if (envPtr->procPtr == NULL) { + return TCL_OUT_LINE_COMPILE; + } + + switch (parsePtr->numWords) { + case 1: { + /* + * Simple case: [return] + * Just push the literal string "". + */ + TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); + break; + } + case 2: { + /* + * More complex cases: + * [return "foo"] + * [return $value] + * [return [otherCmd]] + */ + varTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + /* + * [return "foo"] case: the parse token is a simple word, + * so just push it. + */ + TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start, + varTokenPtr[1].size), envPtr); + } else { + /* + * Parse token is more complex, so compile it; this handles the + * variable reference and nested command cases. If the + * parse token can be byte-compiled, then this instance of + * "return" will be byte-compiled; otherwise it will be + * out line compiled. + */ + code = TclCompileTokens(interp, varTokenPtr+1, + varTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + return code; + } + } + break; + } + default: { + /* + * Most complex return cases: everything else, including + * [return -code error], etc. + */ + return TCL_OUT_LINE_COMPILE; + } + } + + /* + * The INST_DONE opcode actually causes the branching out of the + * subroutine, and takes the top stack item as the return result + * (which is why we pushed the value above). + */ + TclEmitOpcode(INST_DONE, envPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileSetCmd -- + * + * Procedure called to compile the "set" command. + * + * Results: + * The return value is a standard Tcl result, which is normally TCL_OK + * unless there was an error while parsing string. If an error occurs + * then the interpreter's result contains a standard error message. If + * complation fails because the set command requires a second level of + * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the + * set command should be compiled "out of line" by emitting code to + * invoke its command procedure (Tcl_SetCmd) at runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "set" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileSetCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Tcl_Token *varTokenPtr, *valueTokenPtr; + int isAssignment, isScalar, simpleVarName, localIndex, numWords; + int code = TCL_OK; + + numWords = parsePtr->numWords; + if ((numWords != 2) && (numWords != 3)) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"set varName ?newValue?\"", -1); + return TCL_ERROR; + } + isAssignment = (numWords == 3); + + /* + * Decide if we can use a frame slot for the var/array name or if we + * need to emit code to compute and push the name at runtime. We use a + * frame slot (entry in the array of local vars) if we are compiling a + * procedure body and if the name is simple text that does not include + * namespace qualifiers. + */ + + varTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + + code = TclPushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, + &localIndex, &simpleVarName, &isScalar); + if (code != TCL_OK) { + goto done; + } + /* * If we are doing an assignment, push the new value. */ - + if (isAssignment) { valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - TclEmitPush(TclRegisterLiteral(envPtr, valueTokenPtr[1].start, - valueTokenPtr[1].size, /*onHeap*/ 0), envPtr); - maxDepth += 1; + TclEmitPush(TclRegisterNewLiteral(envPtr, valueTokenPtr[1].start, + valueTokenPtr[1].size), envPtr); } else { code = TclCompileTokens(interp, valueTokenPtr+1, valueTokenPtr->numComponents, envPtr); if (code != TCL_OK) { goto done; } - maxDepth += envPtr->maxStackDepth; } } - + /* * Emit instructions to set/get the variable. */ if (simpleVarName) { - if (elName == NULL) { + if (isScalar) { if (localIndex >= 0) { if (localIndex <= 255) { TclEmitInstInt1((isAssignment? @@ -1804,8 +2540,7 @@ TclCompileSetCmd(interp, parsePtr, envPtr) } } else { TclEmitOpcode((isAssignment? - INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK), - envPtr); + INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK), envPtr); } } else { if (localIndex >= 0) { @@ -1820,26 +2555,323 @@ TclCompileSetCmd(interp, parsePtr, envPtr) } } else { TclEmitOpcode((isAssignment? - INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK), - envPtr); + INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK), envPtr); } } } else { - TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), - envPtr); + TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), envPtr); } done: - if (gotElemParse) { - Tcl_FreeParse(&elemParse); - } - envPtr->maxStackDepth = maxDepth; return code; } /* *---------------------------------------------------------------------- * + * TclCompileStringCmd -- + * + * Procedure called to compile the "string" command. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK if the + * compilation was successful. If the command cannot be byte-compiled, + * TCL_OUT_LINE_COMPILE is returned. If an error occurs then the + * interpreter's result contains an error message, and TCL_ERROR is + * returned. + * + * Side effects: + * Instructions are added to envPtr to execute the "string" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileStringCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Tcl_Token *opTokenPtr, *varTokenPtr; + Tcl_Obj *opObj; + int index; + int code; + + static CONST char *options[] = { + "bytelength", "compare", "equal", "first", + "index", "is", "last", "length", + "map", "match", "range", "repeat", + "replace", "tolower", "toupper", "totitle", + "trim", "trimleft", "trimright", + "wordend", "wordstart", (char *) NULL + }; + enum options { + STR_BYTELENGTH, STR_COMPARE, STR_EQUAL, STR_FIRST, + STR_INDEX, STR_IS, STR_LAST, STR_LENGTH, + STR_MAP, STR_MATCH, STR_RANGE, STR_REPEAT, + STR_REPLACE, STR_TOLOWER, STR_TOUPPER, STR_TOTITLE, + STR_TRIM, STR_TRIMLEFT, STR_TRIMRIGHT, + STR_WORDEND, STR_WORDSTART + }; + + if (parsePtr->numWords < 2) { + /* Fail at run time, not in compilation */ + return TCL_OUT_LINE_COMPILE; + } + opTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + + opObj = Tcl_NewStringObj(opTokenPtr->start, opTokenPtr->size); + if (Tcl_GetIndexFromObj(interp, opObj, options, "option", 0, + &index) != TCL_OK) { + Tcl_DecrRefCount(opObj); + Tcl_ResetResult(interp); + return TCL_OUT_LINE_COMPILE; + } + Tcl_DecrRefCount(opObj); + + varTokenPtr = opTokenPtr + (opTokenPtr->numComponents + 1); + + switch ((enum options) index) { + case STR_BYTELENGTH: + case STR_FIRST: + case STR_IS: + case STR_LAST: + case STR_MAP: + case STR_RANGE: + case STR_REPEAT: + case STR_REPLACE: + case STR_TOLOWER: + case STR_TOUPPER: + case STR_TOTITLE: + case STR_TRIM: + case STR_TRIMLEFT: + case STR_TRIMRIGHT: + case STR_WORDEND: + case STR_WORDSTART: + /* + * All other cases: compile out of line. + */ + return TCL_OUT_LINE_COMPILE; + + case STR_COMPARE: + case STR_EQUAL: { + int i; + /* + * If there are any flags to the command, we can't byte compile it + * because the INST_STR_EQ bytecode doesn't support flags. + */ + + if (parsePtr->numWords != 4) { + return TCL_OUT_LINE_COMPILE; + } + + /* + * Push the two operands onto the stack. + */ + + for (i = 0; i < 2; i++) { + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + TclEmitPush(TclRegisterNewLiteral(envPtr, + varTokenPtr[1].start, varTokenPtr[1].size), envPtr); + } else { + code = TclCompileTokens(interp, varTokenPtr+1, + varTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + return code; + } + } + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + } + + TclEmitOpcode(((((enum options) index) == STR_COMPARE) ? + INST_STR_CMP : INST_STR_EQ), envPtr); + return TCL_OK; + } + case STR_INDEX: { + int i; + + if (parsePtr->numWords != 4) { + /* Fail at run time, not in compilation */ + return TCL_OUT_LINE_COMPILE; + } + + /* + * Push the two operands onto the stack. + */ + + for (i = 0; i < 2; i++) { + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + TclEmitPush(TclRegisterNewLiteral(envPtr, + varTokenPtr[1].start, varTokenPtr[1].size), envPtr); + } else { + code = TclCompileTokens(interp, varTokenPtr+1, + varTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + return code; + } + } + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + } + + TclEmitOpcode(INST_STR_INDEX, envPtr); + return TCL_OK; + } + case STR_LENGTH: { + if (parsePtr->numWords != 3) { + /* Fail at run time, not in compilation */ + return TCL_OUT_LINE_COMPILE; + } + + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + /* + * Here someone is asking for the length of a static string. + * Just push the actual character (not byte) length. + */ + char buf[TCL_INTEGER_SPACE]; + int len = Tcl_NumUtfChars(varTokenPtr[1].start, + varTokenPtr[1].size); + len = sprintf(buf, "%d", len); + TclEmitPush(TclRegisterNewLiteral(envPtr, buf, len), envPtr); + return TCL_OK; + } else { + code = TclCompileTokens(interp, varTokenPtr+1, + varTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + return code; + } + } + TclEmitOpcode(INST_STR_LEN, envPtr); + return TCL_OK; + } + case STR_MATCH: { + int i, length, exactMatch = 0, nocase = 0; + CONST char *str; + + if (parsePtr->numWords < 4 || parsePtr->numWords > 5) { + /* Fail at run time, not in compilation */ + return TCL_OUT_LINE_COMPILE; + } + + if (parsePtr->numWords == 5) { + if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_OUT_LINE_COMPILE; + } + str = varTokenPtr[1].start; + length = varTokenPtr[1].size; + if ((length > 1) && + strncmp(str, "-nocase", (size_t) length) == 0) { + nocase = 1; + } else { + /* Fail at run time, not in compilation */ + return TCL_OUT_LINE_COMPILE; + } + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + } + + for (i = 0; i < 2; i++) { + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + str = varTokenPtr[1].start; + length = varTokenPtr[1].size; + if (!nocase && (i == 0)) { + /* + * On the first (pattern) arg, check to see if any + * glob special characters are in the word '*[]?\\'. + * If not, this is the same as 'string equal'. We + * can use strpbrk here because the glob chars are all + * in the ascii-7 range. If -nocase was specified, + * we can't do this because INST_STR_EQ has no support + * for nocase. + */ + Tcl_Obj *copy = Tcl_NewStringObj(str, length); + Tcl_IncrRefCount(copy); + exactMatch = (strpbrk(Tcl_GetString(copy), + "*[]?\\") == NULL); + Tcl_DecrRefCount(copy); + } + TclEmitPush( + TclRegisterNewLiteral(envPtr, str, length), envPtr); + } else { + code = TclCompileTokens(interp, varTokenPtr+1, + varTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + return code; + } + } + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + } + + if (exactMatch) { + TclEmitOpcode(INST_STR_EQ, envPtr); + } else { + TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr); + } + return TCL_OK; + } + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileVariableCmd -- + * + * Procedure called to reserve the local variables for the + * "variable" command. The command itself is *not* compiled. + * + * Results: + * Always returns TCL_OUT_LINE_COMPILE. + * + * Side effects: + * Indexed local variables are added to the environment. + * + *---------------------------------------------------------------------- + */ +int +TclCompileVariableCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Tcl_Token *varTokenPtr; + int i, numWords; + CONST char *varName, *tail; + + if (envPtr->procPtr == NULL) { + return TCL_OUT_LINE_COMPILE; + } + + numWords = parsePtr->numWords; + + varTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + for (i = 1; i < numWords; i += 2) { + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + varName = varTokenPtr[1].start; + tail = varName + varTokenPtr[1].size - 1; + if ((*tail == ')') || (tail < varName)) continue; + while ((tail > varName) && ((*tail != ':') || (*(tail-1) != ':'))) { + tail--; + } + if ((*tail == ':') && (tail > varName)) { + tail++; + } + (void) TclFindCompiledLocal(tail, (tail-varName+1), + /*create*/ 1, /*flags*/ 0, envPtr->procPtr); + varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + } + } + return TCL_OUT_LINE_COMPILE; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileWhileCmd -- * * Procedure called to compile the "while" command. @@ -1853,9 +2885,6 @@ TclCompileSetCmd(interp, parsePtr, envPtr) * indicating that the while command should be compiled "out of line" * by emitting code to invoke its command procedure at runtime. * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the "while" command. - * * Side effects: * Instructions are added to envPtr to execute the "while" command * at runtime. @@ -1871,14 +2900,16 @@ TclCompileWhileCmd(interp, parsePtr, envPtr) CompileEnv *envPtr; /* Holds resulting instructions. */ { Tcl_Token *testTokenPtr, *bodyTokenPtr; - JumpFixup jumpFalseFixup; - unsigned char *jumpPc; - int testCodeOffset, jumpDist, jumpBackDist, jumpBackOffset; - int range, maxDepth, code; + JumpFixup jumpEvalCondFixup; + int testCodeOffset, bodyCodeOffset, jumpDist; + int range, code; char buffer[32 + TCL_INTEGER_SPACE]; + int savedStackDepth = envPtr->currStackDepth; + int loopMayEnd = 1; /* This is set to 0 if it is recognized as + * an infinite loop. */ + Tcl_Obj *boolObj; + int boolVal; - envPtr->maxStackDepth = 0; - maxDepth = 0; if (parsePtr->numWords != 3) { Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), @@ -1890,15 +2921,45 @@ TclCompileWhileCmd(interp, parsePtr, envPtr) * If the test expression requires substitutions, don't compile the * while command inline. E.g., the expression might cause the loop to * never execute or execute forever, as in "while "$x < 5" {}". + * + * Bail out also if the body expression requires substitutions + * in order to insure correct behaviour [Bug 219166] */ testTokenPtr = parsePtr->tokenPtr + (parsePtr->tokenPtr->numComponents + 1); - if (testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + bodyTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1); + if ((testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) + || (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) { return TCL_OUT_LINE_COMPILE; } /* + * Find out if the condition is a constant. + */ + + boolObj = Tcl_NewStringObj(testTokenPtr[1].start, testTokenPtr[1].size); + Tcl_IncrRefCount(boolObj); + code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal); + Tcl_DecrRefCount(boolObj); + if (code == TCL_OK) { + if (boolVal) { + /* + * it is an infinite loop + */ + + loopMayEnd = 0; + } else { + /* + * This is an empty loop: "while 0 {...}" or such. + * Compile no bytecodes. + */ + + goto pushResult; + } + } + + /* * Create a ExceptionRange record for the loop body. This is used to * implement break and continue. */ @@ -1907,36 +2968,37 @@ TclCompileWhileCmd(interp, parsePtr, envPtr) envPtr->maxExceptDepth = TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth); range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); - envPtr->exceptArrayPtr[range].continueOffset = - (envPtr->codeNext - envPtr->codeStart); /* - * Compile the test expression then emit the conditional jump that - * terminates the while. We already know it's a simple word. + * Jump to the evaluation of the condition. This code uses the "loop + * rotation" optimisation (which eliminates one branch from the loop). + * "while cond body" produces then: + * goto A + * B: body : bodyCodeOffset + * A: cond -> result : testCodeOffset, continueOffset + * if (result) goto B + * + * The infinite loop "while 1 body" produces: + * B: body : all three offsets here + * goto B */ - testCodeOffset = (envPtr->codeNext - envPtr->codeStart); - envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset; - code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr); - if (code != TCL_OK) { - if (code == TCL_ERROR) { - Tcl_AddObjErrorInfo(interp, - "\n (\"while\" test expression)", -1); - } - goto error; + if (loopMayEnd) { + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup); + testCodeOffset = 0; /* avoid compiler warning */ + } else { + testCodeOffset = (envPtr->codeNext - envPtr->codeStart); } - maxDepth = envPtr->maxStackDepth; - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup); + /* * Compile the loop body. */ - bodyTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1); - envPtr->exceptArrayPtr[range].codeOffset = - (envPtr->codeNext - envPtr->codeStart); + bodyCodeOffset = (envPtr->codeNext - envPtr->codeStart); code = TclCompileCmdWord(interp, bodyTokenPtr+1, bodyTokenPtr->numComponents, envPtr); + envPtr->currStackDepth = savedStackDepth + 1; if (code != TCL_OK) { if (code == TCL_ERROR) { sprintf(buffer, "\n (\"while\" body line %d)", @@ -1945,59 +3007,55 @@ TclCompileWhileCmd(interp, parsePtr, envPtr) } goto error; } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); envPtr->exceptArrayPtr[range].numCodeBytes = - (envPtr->codeNext - envPtr->codeStart) - - envPtr->exceptArrayPtr[range].codeOffset; + (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset; TclEmitOpcode(INST_POP, envPtr); - - /* - * Jump back to the test at the top of the loop. Generate a 4 byte jump - * if the distance to the test is > 120 bytes. This is conservative and - * ensures that we won't have to replace this jump if we later need to - * replace the ifFalse jump with a 4 byte jump. - */ - - jumpBackOffset = (envPtr->codeNext - envPtr->codeStart); - jumpBackDist = (jumpBackOffset - testCodeOffset); - if (jumpBackDist > 120) { - TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr); - } else { - TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr); - } /* - * Fix the target of the jumpFalse after the test. + * Compile the test expression then emit the conditional jump that + * terminates the while. We already know it's a simple word. */ - jumpDist = (envPtr->codeNext - envPtr->codeStart) - - jumpFalseFixup.codeOffset; - if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) { - /* - * Update the loop body's starting PC offset since it moved down. - */ - - envPtr->exceptArrayPtr[range].codeOffset += 3; - - /* - * Update the jump back to the test at the top of the loop since it - * also moved down 3 bytes. - */ - - jumpBackOffset += 3; - jumpPc = (envPtr->codeStart + jumpBackOffset); - jumpBackDist += 3; - if (jumpBackDist > 120) { - TclUpdateInstInt4AtPc(INST_JUMP4, -jumpBackDist, jumpPc); + if (loopMayEnd) { + testCodeOffset = (envPtr->codeNext - envPtr->codeStart); + jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset; + if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) { + bodyCodeOffset += 3; + testCodeOffset += 3; + } + envPtr->currStackDepth = savedStackDepth; + code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + Tcl_AddObjErrorInfo(interp, + "\n (\"while\" test expression)", -1); + } + goto error; + } + envPtr->currStackDepth = savedStackDepth + 1; + + jumpDist = (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset; + if (jumpDist > 127) { + TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr); } else { - TclUpdateInstInt1AtPc(INST_JUMP1, -jumpBackDist, jumpPc); + TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr); } + } else { + jumpDist = (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset; + if (jumpDist > 127) { + TclEmitInstInt4(INST_JUMP4, -jumpDist, envPtr); + } else { + TclEmitInstInt1(INST_JUMP1, -jumpDist, envPtr); + } } + /* - * Set the loop's break target. + * Set the loop's body, continue and break offsets. */ + envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset; + envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset; envPtr->exceptArrayPtr[range].breakOffset = (envPtr->codeNext - envPtr->codeStart); @@ -2005,19 +3063,259 @@ TclCompileWhileCmd(interp, parsePtr, envPtr) * The while command's result is an empty string. */ - TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr); - if (maxDepth == 0) { - maxDepth = 1; - } - envPtr->maxStackDepth = maxDepth; + pushResult: + envPtr->currStackDepth = savedStackDepth; + TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); envPtr->exceptDepth--; return TCL_OK; error: - envPtr->maxStackDepth = maxDepth; envPtr->exceptDepth--; return code; } + +/* + *---------------------------------------------------------------------- + * + * TclPushVarName -- + * + * Procedure used in the compiling where pushing a variable name + * is necessary (append, lappend, set). + * + * Results: + * The return value is a standard Tcl result, which is normally TCL_OK + * unless there was an error while parsing string. If an error occurs + * then the interpreter's result contains a standard error message. + * + * Side effects: + * Instructions are added to envPtr to execute the "set" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +static int +TclPushVarName(interp, varTokenPtr, envPtr, flags, localIndexPtr, + simpleVarNamePtr, isScalarPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Token *varTokenPtr; /* Points to a variable token. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ + int flags; /* takes TCL_CREATE_VAR or + * TCL_NO_LARGE_INDEX */ + int *localIndexPtr; /* must not be NULL */ + int *simpleVarNamePtr; /* must not be NULL */ + int *isScalarPtr; /* must not be NULL */ +{ + register CONST char *p; + CONST char *name, *elName; + register int i, n; + int nameChars, elNameChars, simpleVarName, localIndex; + int code = TCL_OK; + + Tcl_Token *elemTokenPtr = NULL; + int elemTokenCount = 0; + int allocedTokens = 0; + int removedParen = 0; + /* + * Decide if we can use a frame slot for the var/array name or if we + * need to emit code to compute and push the name at runtime. We use a + * frame slot (entry in the array of local vars) if we are compiling a + * procedure body and if the name is simple text that does not include + * namespace qualifiers. + */ + simpleVarName = 0; + name = elName = NULL; + nameChars = elNameChars = 0; + localIndex = -1; + /* + * Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether + * curly braces surround the variable name. + * This really matters for array elements to handle things like + * set {x($foo)} 5 + * which raises an undefined var error if we are not careful here. + */ + + if ((varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) && + (varTokenPtr->start[0] != '{')) { + /* + * A simple variable name. Divide it up into "name" and "elName" + * strings. If it is not a local variable, look it up at runtime. + */ + simpleVarName = 1; + + name = varTokenPtr[1].start; + nameChars = varTokenPtr[1].size; + if ( *(name + nameChars - 1) == ')') { + /* + * last char is ')' => potential array reference. + */ + + for (i = 0, p = name; i < nameChars; i++, p++) { + if (*p == '(') { + elName = p + 1; + elNameChars = nameChars - i - 2; + nameChars = i ; + break; + } + } + + if ((elName != NULL) && elNameChars) { + /* + * An array element, the element name is a simple + * string: assemble the corresponding token. + */ + + elemTokenPtr = (Tcl_Token *) ckalloc(sizeof(Tcl_Token)); + allocedTokens = 1; + elemTokenPtr->type = TCL_TOKEN_TEXT; + elemTokenPtr->start = elName; + elemTokenPtr->size = elNameChars; + elemTokenPtr->numComponents = 0; + elemTokenCount = 1; + } + } + } else if (((n = varTokenPtr->numComponents) > 1) + && (varTokenPtr[1].type == TCL_TOKEN_TEXT) + && (varTokenPtr[n].type == TCL_TOKEN_TEXT) + && (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) { + + /* + * Check for parentheses inside first token + */ + + simpleVarName = 0; + for (i = 0, p = varTokenPtr[1].start; + i < varTokenPtr[1].size; i++, p++) { + if (*p == '(') { + simpleVarName = 1; + break; + } + } + if (simpleVarName) { + int remainingChars; + + /* + * Check the last token: if it is just ')', do not count + * it. Otherwise, remove the ')' and flag so that it is + * restored at the end. + */ + + if (varTokenPtr[n].size == 1) { + --n; + } else { + --varTokenPtr[n].size; + removedParen = n; + } + + name = varTokenPtr[1].start; + nameChars = p - varTokenPtr[1].start; + elName = p + 1; + remainingChars = (varTokenPtr[2].start - p) - 1; + elNameChars = (varTokenPtr[n].start - p) + varTokenPtr[n].size - 2; + + if (remainingChars) { + /* + * Make a first token with the extra characters in the first + * token. + */ + + elemTokenPtr = (Tcl_Token *) ckalloc(n * sizeof(Tcl_Token)); + allocedTokens = 1; + elemTokenPtr->type = TCL_TOKEN_TEXT; + elemTokenPtr->start = elName; + elemTokenPtr->size = remainingChars; + elemTokenPtr->numComponents = 0; + elemTokenCount = n; + + /* + * Copy the remaining tokens. + */ + + memcpy((void *) (elemTokenPtr+1), (void *) (&varTokenPtr[2]), + ((n-1) * sizeof(Tcl_Token))); + } else { + /* + * Use the already available tokens. + */ + + elemTokenPtr = &varTokenPtr[2]; + elemTokenCount = n - 1; + } + } + } + + if (simpleVarName) { + /* + * See whether name has any namespace separators (::'s). + */ + + int hasNsQualifiers = 0; + for (i = 0, p = name; i < nameChars; i++, p++) { + if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) { + hasNsQualifiers = 1; + break; + } + } + + /* + * Look up the var name's index in the array of local vars in the + * proc frame. If retrieving the var's value and it doesn't already + * exist, push its name and look it up at runtime. + */ + + if ((envPtr->procPtr != NULL) && !hasNsQualifiers) { + localIndex = TclFindCompiledLocal(name, nameChars, + /*create*/ (flags & TCL_CREATE_VAR), + /*flags*/ ((elName==NULL)? VAR_SCALAR : VAR_ARRAY), + envPtr->procPtr); + if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) { + /* we'll push the name */ + localIndex = -1; + } + } + if (localIndex < 0) { + TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameChars), envPtr); + } + + /* + * Compile the element script, if any. + */ + + if (elName != NULL) { + if (elNameChars) { + code = TclCompileTokens(interp, elemTokenPtr, + elemTokenCount, envPtr); + if (code != TCL_OK) { + goto done; + } + } else { + TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); + } + } + } else { + /* + * The var name isn't simple: compile and push it. + */ + + code = TclCompileTokens(interp, varTokenPtr+1, + varTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + goto done; + } + } + + done: + if (removedParen) { + ++varTokenPtr[removedParen].size; + } + if (allocedTokens) { + ckfree((char *) elemTokenPtr); + } + *localIndexPtr = localIndex; + *simpleVarNamePtr = simpleVarName; + *isScalarPtr = (elName == NULL); + return code; +} diff --git a/tcl/generic/tclCompExpr.c b/tcl/generic/tclCompExpr.c index ff368e20004..d1f25b5e157 100644 --- a/tcl/generic/tclCompExpr.c +++ b/tcl/generic/tclCompExpr.c @@ -4,6 +4,7 @@ * This file contains the code to compile Tcl expressions. * * Copyright (c) 1997 Sun Microsystems, Inc. + * Copyright (c) 1998-2000 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -50,26 +51,14 @@ typedef struct ExprInfo { Tcl_Interp *interp; /* Used for error reporting. */ Tcl_Parse *parsePtr; /* Structure filled with information about * the parsed expression. */ - char *expr; /* The expression that was originally passed + CONST char *expr; /* The expression that was originally passed * to TclCompileExpr. */ - char *lastChar; /* Points just after last byte of expr. */ + CONST char *lastChar; /* Points just after last byte of expr. */ int hasOperators; /* Set 1 if the expr has operators; 0 if * expr is only a primary. If 1 after * compiling an expr, a tryCvtToNumeric * instruction is emitted to convert the * primary to a number if possible. */ - int exprIsJustVarRef; /* Set 1 if the expr consists of just a - * variable reference as in the expression - * of "if $b then...". Otherwise 0. If 1 the - * expr is compiled out-of-line in order to - * implement expr's 2 level substitution - * semantics properly. */ - int exprIsComparison; /* Set 1 if the top-level operator in the - * expr is a comparison. Otherwise 0. If 1, - * because the operands might be strings, - * the expr is compiled out-of-line in order - * to implement expr's 2 level substitution - * semantics properly. */ } ExprInfo; /* @@ -101,6 +90,8 @@ typedef struct ExprInfo { #define OP_QUESTY 18 #define OP_LNOT 19 #define OP_BITNOT 20 +#define OP_STREQ 21 +#define OP_STRNEQ 22 /* * Table describing the expression operators. Entries in this table must @@ -119,7 +110,7 @@ typedef struct OperatorDesc { * Ignored if numOperands is 0. */ } OperatorDesc; -OperatorDesc operatorTable[] = { +static OperatorDesc operatorTable[] = { {"*", 2, INST_MULT}, {"/", 2, INST_DIV}, {"%", 2, INST_MOD}, @@ -141,6 +132,8 @@ OperatorDesc operatorTable[] = { {"?", 0}, {"!", 1, INST_LNOT}, {"~", 1, INST_BITNOT}, + {"eq", 2, INST_STR_EQ}, + {"ne", 2, INST_STR_NEQ}, {NULL} }; @@ -163,7 +156,7 @@ static int CompileLandOrLorExpr _ANSI_ARGS_(( ExprInfo *infoPtr, CompileEnv *envPtr, Tcl_Token **endPtrPtr)); static int CompileMathFuncCall _ANSI_ARGS_(( - Tcl_Token *exprTokenPtr, char *funcName, + Tcl_Token *exprTokenPtr, CONST char *funcName, ExprInfo *infoPtr, CompileEnv *envPtr, Tcl_Token **endPtrPtr)); static int CompileSubExpr _ANSI_ARGS_(( @@ -201,19 +194,6 @@ static void LogSyntaxError _ANSI_ARGS_((ExprInfo *infoPtr)); * on failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * - * envPtr->exprIsJustVarRef is set 1 if the expression consisted of - * a single variable reference as in the expression of "if $b then...". - * Otherwise it is set 0. This is used to implement Tcl's two level - * expression substitution semantics properly. - * - * envPtr->exprIsComparison is set 1 if the top-level operator in the - * expr is a comparison. Otherwise it is set 0. If 1, because the - * operands might be strings, the expr is compiled out-of-line in order - * to implement expr's 2 level substitution semantics properly. - * * Side effects: * Adds instructions to envPtr to evaluate the expression at runtime. * @@ -223,7 +203,7 @@ static void LogSyntaxError _ANSI_ARGS_((ExprInfo *infoPtr)); int TclCompileExpr(interp, script, numBytes, envPtr) Tcl_Interp *interp; /* Used for error reporting. */ - char *script; /* The source script to compile. */ + CONST char *script; /* The source script to compile. */ int numBytes; /* Number of bytes in script. If < 0, the * string consists of all bytes up to the * first null character. */ @@ -232,7 +212,7 @@ TclCompileExpr(interp, script, numBytes, envPtr) ExprInfo info; Tcl_Parse parse; Tcl_HashEntry *hPtr; - int maxDepth, new, i, code; + int new, i, code; /* * If this is the first time we've been called, initialize the table @@ -268,14 +248,11 @@ TclCompileExpr(interp, script, numBytes, envPtr) info.expr = script; info.lastChar = (script + numBytes); info.hasOperators = 0; - info.exprIsJustVarRef = 1; /* will be set 0 if anything else is seen */ - info.exprIsComparison = 0; /* * Parse the expression then compile it. */ - maxDepth = 0; code = Tcl_ParseExpr(interp, script, numBytes, &parse); if (code != TCL_OK) { goto done; @@ -286,7 +263,6 @@ TclCompileExpr(interp, script, numBytes, envPtr) Tcl_FreeParse(&parse); goto done; } - maxDepth = envPtr->maxStackDepth; if (!info.hasOperators) { /* @@ -301,9 +277,6 @@ TclCompileExpr(interp, script, numBytes, envPtr) Tcl_FreeParse(&parse); done: - envPtr->maxStackDepth = maxDepth; - envPtr->exprIsJustVarRef = info.exprIsJustVarRef; - envPtr->exprIsComparison = info.exprIsComparison; return code; } @@ -352,19 +325,6 @@ TclFinalizeCompilation() * on failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the subexpression. - * - * envPtr->exprIsJustVarRef is set 1 if the subexpression consisted of - * a single variable reference as in the expression of "if $b then...". - * Otherwise it is set 0. This is used to implement Tcl's two level - * expression substitution semantics properly. - * - * envPtr->exprIsComparison is set 1 if the top-level operator in the - * subexpression is a comparison. Otherwise it is set 0. If 1, because - * the operands might be strings, the expr is compiled out-of-line in - * order to implement expr's 2 level substitution semantics properly. - * * Side effects: * Adds instructions to envPtr to evaluate the subexpression. * @@ -383,15 +343,15 @@ CompileSubExpr(exprTokenPtr, infoPtr, envPtr) Tcl_Token *tokenPtr, *endPtr, *afterSubexprPtr; OperatorDesc *opDescPtr; Tcl_HashEntry *hPtr; - char *operator; - int maxDepth, objIndex, opIndex, length, code; + CONST char *operator; + Tcl_DString opBuf; + int objIndex, opIndex, length, code; char buffer[TCL_UTF_MAX]; if (exprTokenPtr->type != TCL_TOKEN_SUB_EXPR) { panic("CompileSubExpr: token type %d not TCL_TOKEN_SUB_EXPR\n", exprTokenPtr->type); } - maxDepth = 0; code = TCL_OK; /* @@ -410,37 +370,30 @@ CompileSubExpr(exprTokenPtr, infoPtr, envPtr) if (code != TCL_OK) { goto done; } - maxDepth = envPtr->maxStackDepth; tokenPtr += (tokenPtr->numComponents + 1); - infoPtr->exprIsJustVarRef = 0; break; case TCL_TOKEN_TEXT: if (tokenPtr->size > 0) { - objIndex = TclRegisterLiteral(envPtr, tokenPtr->start, - tokenPtr->size, /*onHeap*/ 0); + objIndex = TclRegisterNewLiteral(envPtr, tokenPtr->start, + tokenPtr->size); } else { - objIndex = TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0); + objIndex = TclRegisterNewLiteral(envPtr, "", 0); } TclEmitPush(objIndex, envPtr); - maxDepth = 1; tokenPtr += 1; - infoPtr->exprIsJustVarRef = 0; break; case TCL_TOKEN_BS: length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL, buffer); if (length > 0) { - objIndex = TclRegisterLiteral(envPtr, buffer, length, - /*onHeap*/ 0); + objIndex = TclRegisterNewLiteral(envPtr, buffer, length); } else { - objIndex = TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0); + objIndex = TclRegisterNewLiteral(envPtr, "", 0); } TclEmitPush(objIndex, envPtr); - maxDepth = 1; tokenPtr += 1; - infoPtr->exprIsJustVarRef = 0; break; case TCL_TOKEN_COMMAND: @@ -449,9 +402,7 @@ CompileSubExpr(exprTokenPtr, infoPtr, envPtr) if (code != TCL_OK) { goto done; } - maxDepth = envPtr->maxStackDepth; tokenPtr += 1; - infoPtr->exprIsJustVarRef = 0; break; case TCL_TOKEN_VARIABLE: @@ -459,42 +410,37 @@ CompileSubExpr(exprTokenPtr, infoPtr, envPtr) if (code != TCL_OK) { goto done; } - maxDepth = envPtr->maxStackDepth; tokenPtr += (tokenPtr->numComponents + 1); break; case TCL_TOKEN_SUB_EXPR: - infoPtr->exprIsComparison = 0; code = CompileSubExpr(tokenPtr, infoPtr, envPtr); if (code != TCL_OK) { goto done; } - maxDepth = envPtr->maxStackDepth; tokenPtr += (tokenPtr->numComponents + 1); break; - case TCL_TOKEN_OPERATOR: { - Tcl_DString operatorDString; - - Tcl_DStringInit(&operatorDString); - Tcl_DStringAppend(&operatorDString, tokenPtr->start, - tokenPtr->size); - operator = Tcl_DStringValue(&operatorDString); + case TCL_TOKEN_OPERATOR: + /* + * Look up the operator. If the operator isn't found, treat it + * as a math function. + */ + Tcl_DStringInit(&opBuf); + operator = Tcl_DStringAppend(&opBuf, + tokenPtr->start, tokenPtr->size); hPtr = Tcl_FindHashEntry(&opHashTable, operator); if (hPtr == NULL) { code = CompileMathFuncCall(exprTokenPtr, operator, infoPtr, envPtr, &endPtr); - Tcl_DStringFree(&operatorDString); + Tcl_DStringFree(&opBuf); if (code != TCL_OK) { goto done; } - maxDepth = envPtr->maxStackDepth; tokenPtr = endPtr; - infoPtr->exprIsJustVarRef = 0; - infoPtr->exprIsComparison = 0; break; } - Tcl_DStringFree(&operatorDString); + Tcl_DStringFree(&opBuf); opIndex = (int) Tcl_GetHashValue(hPtr); opDescPtr = &(operatorTable[opIndex]); @@ -509,7 +455,6 @@ CompileSubExpr(exprTokenPtr, infoPtr, envPtr) if (code != TCL_OK) { goto done; } - maxDepth = envPtr->maxStackDepth; tokenPtr += (tokenPtr->numComponents + 1); if (opDescPtr->numOperands == 2) { @@ -517,15 +462,10 @@ CompileSubExpr(exprTokenPtr, infoPtr, envPtr) if (code != TCL_OK) { goto done; } - maxDepth = TclMax((envPtr->maxStackDepth + 1), - maxDepth); tokenPtr += (tokenPtr->numComponents + 1); } TclEmitOpcode(opDescPtr->instruction, envPtr); infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - infoPtr->exprIsComparison = - ((opIndex >= OP_LESS) && (opIndex <= OP_NEQ)); break; } @@ -542,7 +482,6 @@ CompileSubExpr(exprTokenPtr, infoPtr, envPtr) if (code != TCL_OK) { goto done; } - maxDepth = envPtr->maxStackDepth; tokenPtr += (tokenPtr->numComponents + 1); /* @@ -566,8 +505,6 @@ CompileSubExpr(exprTokenPtr, infoPtr, envPtr) if (code != TCL_OK) { goto done; } - maxDepth = TclMax((envPtr->maxStackDepth + 1), - maxDepth); tokenPtr += (tokenPtr->numComponents + 1); TclEmitOpcode(((opIndex==OP_PLUS)? INST_ADD : INST_SUB), envPtr); @@ -580,7 +517,6 @@ CompileSubExpr(exprTokenPtr, infoPtr, envPtr) if (code != TCL_OK) { goto done; } - maxDepth = envPtr->maxStackDepth; tokenPtr = endPtr; break; @@ -590,7 +526,6 @@ CompileSubExpr(exprTokenPtr, infoPtr, envPtr) if (code != TCL_OK) { goto done; } - maxDepth = envPtr->maxStackDepth; tokenPtr = endPtr; break; @@ -599,10 +534,7 @@ CompileSubExpr(exprTokenPtr, infoPtr, envPtr) opIndex); } /* end switch on operator requiring special treatment */ infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - infoPtr->exprIsComparison = 0; break; - } default: panic("CompileSubExpr: unexpected token type %d\n", @@ -622,7 +554,6 @@ CompileSubExpr(exprTokenPtr, infoPtr, envPtr) } done: - envPtr->maxStackDepth = maxDepth; return code; } @@ -641,9 +572,6 @@ CompileSubExpr(exprTokenPtr, infoPtr, envPtr) * endPtrPtr. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * * Side effects: * Adds instructions to envPtr to evaluate the expression at runtime. * @@ -669,19 +597,18 @@ CompileLandOrLorExpr(exprTokenPtr, opIndex, infoPtr, envPtr, endPtrPtr) /* Used to fix up jumps used to convert the * first operand to 0 or 1. */ Tcl_Token *tokenPtr; - int dist, maxDepth, code; + int dist, code; + int savedStackDepth = envPtr->currStackDepth; /* * Emit code for the first operand. */ - maxDepth = 0; tokenPtr = exprTokenPtr+2; code = CompileSubExpr(tokenPtr, infoPtr, envPtr); if (code != TCL_OK) { goto done; } - maxDepth = envPtr->maxStackDepth; tokenPtr += (tokenPtr->numComponents + 1); /* @@ -690,14 +617,15 @@ CompileLandOrLorExpr(exprTokenPtr, opIndex, infoPtr, envPtr, endPtrPtr) */ TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &lhsTrueFixup); - TclEmitPush(TclRegisterLiteral(envPtr, "0", 1, /*onHeap*/ 0), envPtr); + TclEmitPush(TclRegisterNewLiteral(envPtr, "0", 1), envPtr); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &lhsEndFixup); dist = (envPtr->codeNext - envPtr->codeStart) - lhsTrueFixup.codeOffset; if (TclFixupForwardJump(envPtr, &lhsTrueFixup, dist, 127)) { badDist: panic("CompileLandOrLorExpr: bad jump distance %d\n", dist); } - TclEmitPush(TclRegisterLiteral(envPtr, "1", 1, /*onHeap*/ 0), envPtr); + envPtr->currStackDepth = savedStackDepth; + TclEmitPush(TclRegisterNewLiteral(envPtr, "1", 1), envPtr); dist = (envPtr->codeNext - envPtr->codeStart) - lhsEndFixup.codeOffset; if (TclFixupForwardJump(envPtr, &lhsEndFixup, dist, 127)) { goto badDist; @@ -722,7 +650,6 @@ CompileLandOrLorExpr(exprTokenPtr, opIndex, infoPtr, envPtr, endPtrPtr) if (code != TCL_OK) { goto done; } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); tokenPtr += (tokenPtr->numComponents + 1); /* @@ -744,7 +671,7 @@ CompileLandOrLorExpr(exprTokenPtr, opIndex, infoPtr, envPtr, endPtrPtr) *endPtrPtr = tokenPtr; done: - envPtr->maxStackDepth = maxDepth; + envPtr->currStackDepth = savedStackDepth + 1; return code; } @@ -763,9 +690,6 @@ CompileLandOrLorExpr(exprTokenPtr, opIndex, infoPtr, envPtr, endPtrPtr) * endPtrPtr. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * * Side effects: * Adds instructions to envPtr to evaluate the expression at runtime. * @@ -788,19 +712,18 @@ CompileCondExpr(exprTokenPtr, infoPtr, envPtr, endPtrPtr) * around the then and else expressions when * their target PCs are determined. */ Tcl_Token *tokenPtr; - int elseCodeOffset, dist, maxDepth, code; + int elseCodeOffset, dist, code; + int savedStackDepth = envPtr->currStackDepth; /* * Emit code for the test. */ - maxDepth = 0; tokenPtr = exprTokenPtr+2; code = CompileSubExpr(tokenPtr, infoPtr, envPtr); if (code != TCL_OK) { goto done; } - maxDepth = envPtr->maxStackDepth; tokenPtr += (tokenPtr->numComponents + 1); /* @@ -821,7 +744,6 @@ CompileCondExpr(exprTokenPtr, infoPtr, envPtr, endPtrPtr) if (code != TCL_OK) { goto done; } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); tokenPtr += (tokenPtr->numComponents + 1); if (!infoPtr->hasOperators) { TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); @@ -838,13 +760,13 @@ CompileCondExpr(exprTokenPtr, infoPtr, envPtr, endPtrPtr) * Compile the "else" expression. */ + envPtr->currStackDepth = savedStackDepth; elseCodeOffset = (envPtr->codeNext - envPtr->codeStart); infoPtr->hasOperators = 0; code = CompileSubExpr(tokenPtr, infoPtr, envPtr); if (code != TCL_OK) { goto done; } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); tokenPtr += (tokenPtr->numComponents + 1); if (!infoPtr->hasOperators) { TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); @@ -874,7 +796,7 @@ CompileCondExpr(exprTokenPtr, infoPtr, envPtr, endPtrPtr) *endPtrPtr = tokenPtr; done: - envPtr->maxStackDepth = maxDepth; + envPtr->currStackDepth = savedStackDepth + 1; return code; } @@ -893,9 +815,6 @@ CompileCondExpr(exprTokenPtr, infoPtr, envPtr, endPtrPtr) * endPtrPtr. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the function. - * * Side effects: * Adds instructions to envPtr to evaluate the math function at * runtime. @@ -907,7 +826,7 @@ static int CompileMathFuncCall(exprTokenPtr, funcName, infoPtr, envPtr, endPtrPtr) Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token * containing the math function call. */ - char *funcName; /* Name of the math function. */ + CONST char *funcName; /* Name of the math function. */ ExprInfo *infoPtr; /* Describes the compilation state for the * expression being compiled. */ CompileEnv *envPtr; /* Holds resulting instructions. */ @@ -920,14 +839,13 @@ CompileMathFuncCall(exprTokenPtr, funcName, infoPtr, envPtr, endPtrPtr) MathFunc *mathFuncPtr; Tcl_HashEntry *hPtr; Tcl_Token *tokenPtr, *afterSubexprPtr; - int maxDepth, code, i; + int code, i; /* * Look up the MathFunc record for the function. */ code = TCL_OK; - maxDepth = 0; hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName); if (hPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), @@ -942,9 +860,7 @@ CompileMathFuncCall(exprTokenPtr, funcName, infoPtr, envPtr, endPtrPtr) */ if (mathFuncPtr->builtinFuncIndex < 0) { - TclEmitPush(TclRegisterLiteral(envPtr, funcName, -1, /*onHeap*/ 0), - envPtr); - maxDepth = 1; + TclEmitPush(TclRegisterNewLiteral(envPtr, funcName, -1), envPtr); } /* @@ -962,13 +878,11 @@ CompileMathFuncCall(exprTokenPtr, funcName, infoPtr, envPtr, endPtrPtr) code = TCL_ERROR; goto done; } - infoPtr->exprIsComparison = 0; code = CompileSubExpr(tokenPtr, infoPtr, envPtr); if (code != TCL_OK) { goto done; } tokenPtr += (tokenPtr->numComponents + 1); - maxDepth++; } if (tokenPtr != afterSubexprPtr) { Tcl_ResetResult(interp); @@ -992,15 +906,25 @@ CompileMathFuncCall(exprTokenPtr, funcName, infoPtr, envPtr, endPtrPtr) */ if (mathFuncPtr->builtinFuncIndex >= 0) { /* a builtin function */ - TclEmitInstInt1(INST_CALL_BUILTIN_FUNC1, + /* + * Adjust the current stack depth by the number of arguments + * of the builtin function. This cannot be handled by the + * TclEmitInstInt1 macro as the number of arguments is not + * passed as an operand. + */ + + if (envPtr->maxStackDepth < envPtr->currStackDepth) { + envPtr->maxStackDepth = envPtr->currStackDepth; + } + TclEmitInstInt1(INST_CALL_BUILTIN_FUNC1, mathFuncPtr->builtinFuncIndex, envPtr); + envPtr->currStackDepth -= mathFuncPtr->numArgs; } else { TclEmitInstInt1(INST_CALL_FUNC1, (mathFuncPtr->numArgs+1), envPtr); } *endPtrPtr = afterSubexprPtr; done: - envPtr->maxStackDepth = maxDepth; return code; } @@ -1033,6 +957,7 @@ LogSyntaxError(infoPtr) sprintf(buffer, "syntax error in expression \"%.*s\"", ((numBytes > 60)? 60 : numBytes), infoPtr->expr); + Tcl_ResetResult(infoPtr->interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp), buffer, (char *) NULL); } diff --git a/tcl/generic/tclCompile.c b/tcl/generic/tclCompile.c index 4df50f28378..68be045c1b8 100644 --- a/tcl/generic/tclCompile.c +++ b/tcl/generic/tclCompile.c @@ -6,6 +6,7 @@ * sequence of instructions ("bytecodes"). * * Copyright (c) 1996-1998 Sun Microsystems, Inc. + * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -34,8 +35,10 @@ TCL_DECLARE_MUTEX(tableMutex) * This variable is linked to the Tcl variable "tcl_traceCompile". */ +#ifdef TCL_COMPILE_DEBUG int tclTraceCompile = 0; static int traceInitialized = 0; +#endif /* * A table describing the Tcl bytecode instructions. Entries in this table @@ -49,167 +52,223 @@ static int traceInitialized = 0; * existence of a procedure call frame to distinguish these. */ -InstructionDesc instructionTable[] = { - /* Name Bytes #Opnds Operand types Stack top, next */ - {"done", 1, 0, {OPERAND_NONE}}, - /* Finish ByteCode execution and return stktop (top stack item) */ - {"push1", 2, 1, {OPERAND_UINT1}}, - /* Push object at ByteCode objArray[op1] */ - {"push4", 5, 1, {OPERAND_UINT4}}, - /* Push object at ByteCode objArray[op4] */ - {"pop", 1, 0, {OPERAND_NONE}}, - /* Pop the topmost stack object */ - {"dup", 1, 0, {OPERAND_NONE}}, - /* Duplicate the topmost stack object and push the result */ - {"concat1", 2, 1, {OPERAND_UINT1}}, - /* Concatenate the top op1 items and push result */ - {"invokeStk1", 2, 1, {OPERAND_UINT1}}, - /* Invoke command named objv[0]; <objc,objv> = <op1,top op1> */ - {"invokeStk4", 5, 1, {OPERAND_UINT4}}, - /* Invoke command named objv[0]; <objc,objv> = <op4,top op4> */ - {"evalStk", 1, 0, {OPERAND_NONE}}, - /* Evaluate command in stktop using Tcl_EvalObj. */ - {"exprStk", 1, 0, {OPERAND_NONE}}, - /* Execute expression in stktop using Tcl_ExprStringObj. */ +InstructionDesc tclInstructionTable[] = { + /* Name Bytes stackEffect #Opnds Operand types Stack top, next */ + {"done", 1, -1, 0, {OPERAND_NONE}}, + /* Finish ByteCode execution and return stktop (top stack item) */ + {"push1", 2, +1, 1, {OPERAND_UINT1}}, + /* Push object at ByteCode objArray[op1] */ + {"push4", 5, +1, 1, {OPERAND_UINT4}}, + /* Push object at ByteCode objArray[op4] */ + {"pop", 1, -1, 0, {OPERAND_NONE}}, + /* Pop the topmost stack object */ + {"dup", 1, +1, 0, {OPERAND_NONE}}, + /* Duplicate the topmost stack object and push the result */ + {"concat1", 2, INT_MIN, 1, {OPERAND_UINT1}}, + /* Concatenate the top op1 items and push result */ + {"invokeStk1", 2, INT_MIN, 1, {OPERAND_UINT1}}, + /* Invoke command named objv[0]; <objc,objv> = <op1,top op1> */ + {"invokeStk4", 5, INT_MIN, 1, {OPERAND_UINT4}}, + /* Invoke command named objv[0]; <objc,objv> = <op4,top op4> */ + {"evalStk", 1, 0, 0, {OPERAND_NONE}}, + /* Evaluate command in stktop using Tcl_EvalObj. */ + {"exprStk", 1, 0, 0, {OPERAND_NONE}}, + /* Execute expression in stktop using Tcl_ExprStringObj. */ - {"loadScalar1", 2, 1, {OPERAND_UINT1}}, - /* Load scalar variable at index op1 <= 255 in call frame */ - {"loadScalar4", 5, 1, {OPERAND_UINT4}}, - /* Load scalar variable at index op1 >= 256 in call frame */ - {"loadScalarStk", 1, 0, {OPERAND_NONE}}, - /* Load scalar variable; scalar's name is stktop */ - {"loadArray1", 2, 1, {OPERAND_UINT1}}, - /* Load array element; array at slot op1<=255, element is stktop */ - {"loadArray4", 5, 1, {OPERAND_UINT4}}, - /* Load array element; array at slot op1 > 255, element is stktop */ - {"loadArrayStk", 1, 0, {OPERAND_NONE}}, - /* Load array element; element is stktop, array name is stknext */ - {"loadStk", 1, 0, {OPERAND_NONE}}, - /* Load general variable; unparsed variable name is stktop */ - {"storeScalar1", 2, 1, {OPERAND_UINT1}}, - /* Store scalar variable at op1<=255 in frame; value is stktop */ - {"storeScalar4", 5, 1, {OPERAND_UINT4}}, - /* Store scalar variable at op1 > 255 in frame; value is stktop */ - {"storeScalarStk", 1, 0, {OPERAND_NONE}}, - /* Store scalar; value is stktop, scalar name is stknext */ - {"storeArray1", 2, 1, {OPERAND_UINT1}}, - /* Store array element; array at op1<=255, value is top then elem */ - {"storeArray4", 5, 1, {OPERAND_UINT4}}, - /* Store array element; array at op1>=256, value is top then elem */ - {"storeArrayStk", 1, 0, {OPERAND_NONE}}, - /* Store array element; value is stktop, then elem, array names */ - {"storeStk", 1, 0, {OPERAND_NONE}}, - /* Store general variable; value is stktop, then unparsed name */ + {"loadScalar1", 2, 1, 1, {OPERAND_UINT1}}, + /* Load scalar variable at index op1 <= 255 in call frame */ + {"loadScalar4", 5, 1, 1, {OPERAND_UINT4}}, + /* Load scalar variable at index op1 >= 256 in call frame */ + {"loadScalarStk", 1, 0, 0, {OPERAND_NONE}}, + /* Load scalar variable; scalar's name is stktop */ + {"loadArray1", 2, 0, 1, {OPERAND_UINT1}}, + /* Load array element; array at slot op1<=255, element is stktop */ + {"loadArray4", 5, 0, 1, {OPERAND_UINT4}}, + /* Load array element; array at slot op1 > 255, element is stktop */ + {"loadArrayStk", 1, -1, 0, {OPERAND_NONE}}, + /* Load array element; element is stktop, array name is stknext */ + {"loadStk", 1, 0, 0, {OPERAND_NONE}}, + /* Load general variable; unparsed variable name is stktop */ + {"storeScalar1", 2, 0, 1, {OPERAND_UINT1}}, + /* Store scalar variable at op1<=255 in frame; value is stktop */ + {"storeScalar4", 5, 0, 1, {OPERAND_UINT4}}, + /* Store scalar variable at op1 > 255 in frame; value is stktop */ + {"storeScalarStk", 1, -1, 0, {OPERAND_NONE}}, + /* Store scalar; value is stktop, scalar name is stknext */ + {"storeArray1", 2, -1, 1, {OPERAND_UINT1}}, + /* Store array element; array at op1<=255, value is top then elem */ + {"storeArray4", 5, -1, 1, {OPERAND_UINT4}}, + /* Store array element; array at op1>=256, value is top then elem */ + {"storeArrayStk", 1, -2, 0, {OPERAND_NONE}}, + /* Store array element; value is stktop, then elem, array names */ + {"storeStk", 1, -1, 0, {OPERAND_NONE}}, + /* Store general variable; value is stktop, then unparsed name */ - {"incrScalar1", 2, 1, {OPERAND_UINT1}}, - /* Incr scalar at index op1<=255 in frame; incr amount is stktop */ - {"incrScalarStk", 1, 0, {OPERAND_NONE}}, - /* Incr scalar; incr amount is stktop, scalar's name is stknext */ - {"incrArray1", 2, 1, {OPERAND_UINT1}}, - /* Incr array elem; arr at slot op1<=255, amount is top then elem */ - {"incrArrayStk", 1, 0, {OPERAND_NONE}}, - /* Incr array element; amount is top then elem then array names */ - {"incrStk", 1, 0, {OPERAND_NONE}}, - /* Incr general variable; amount is stktop then unparsed var name */ - {"incrScalar1Imm", 3, 2, {OPERAND_UINT1, OPERAND_INT1}}, - /* Incr scalar at slot op1 <= 255; amount is 2nd operand byte */ - {"incrScalarStkImm", 2, 1, {OPERAND_INT1}}, - /* Incr scalar; scalar name is stktop; incr amount is op1 */ - {"incrArray1Imm", 3, 2, {OPERAND_UINT1, OPERAND_INT1}}, - /* Incr array elem; array at slot op1 <= 255, elem is stktop, + {"incrScalar1", 2, 0, 1, {OPERAND_UINT1}}, + /* Incr scalar at index op1<=255 in frame; incr amount is stktop */ + {"incrScalarStk", 1, -1, 0, {OPERAND_NONE}}, + /* Incr scalar; incr amount is stktop, scalar's name is stknext */ + {"incrArray1", 2, -1, 1, {OPERAND_UINT1}}, + /* Incr array elem; arr at slot op1<=255, amount is top then elem */ + {"incrArrayStk", 1, -2, 0, {OPERAND_NONE}}, + /* Incr array element; amount is top then elem then array names */ + {"incrStk", 1, -1, 0, {OPERAND_NONE}}, + /* Incr general variable; amount is stktop then unparsed var name */ + {"incrScalar1Imm", 3, +1, 2, {OPERAND_UINT1, OPERAND_INT1}}, + /* Incr scalar at slot op1 <= 255; amount is 2nd operand byte */ + {"incrScalarStkImm", 2, 0, 1, {OPERAND_INT1}}, + /* Incr scalar; scalar name is stktop; incr amount is op1 */ + {"incrArray1Imm", 3, 0, 2, {OPERAND_UINT1, OPERAND_INT1}}, + /* Incr array elem; array at slot op1 <= 255, elem is stktop, * amount is 2nd operand byte */ - {"incrArrayStkImm", 2, 1, {OPERAND_INT1}}, - /* Incr array element; elem is top then array name, amount is op1 */ - {"incrStkImm", 2, 1, {OPERAND_INT1}}, - /* Incr general variable; unparsed name is top, amount is op1 */ + {"incrArrayStkImm", 2, -1, 1, {OPERAND_INT1}}, + /* Incr array element; elem is top then array name, amount is op1 */ + {"incrStkImm", 2, 0, 1, {OPERAND_INT1}}, + /* Incr general variable; unparsed name is top, amount is op1 */ - {"jump1", 2, 1, {OPERAND_INT1}}, - /* Jump relative to (pc + op1) */ - {"jump4", 5, 1, {OPERAND_INT4}}, - /* Jump relative to (pc + op4) */ - {"jumpTrue1", 2, 1, {OPERAND_INT1}}, - /* Jump relative to (pc + op1) if stktop expr object is true */ - {"jumpTrue4", 5, 1, {OPERAND_INT4}}, - /* Jump relative to (pc + op4) if stktop expr object is true */ - {"jumpFalse1", 2, 1, {OPERAND_INT1}}, - /* Jump relative to (pc + op1) if stktop expr object is false */ - {"jumpFalse4", 5, 1, {OPERAND_INT4}}, - /* Jump relative to (pc + op4) if stktop expr object is false */ - - {"lor", 1, 0, {OPERAND_NONE}}, - /* Logical or: push (stknext || stktop) */ - {"land", 1, 0, {OPERAND_NONE}}, - /* Logical and: push (stknext && stktop) */ - {"bitor", 1, 0, {OPERAND_NONE}}, - /* Bitwise or: push (stknext | stktop) */ - {"bitxor", 1, 0, {OPERAND_NONE}}, - /* Bitwise xor push (stknext ^ stktop) */ - {"bitand", 1, 0, {OPERAND_NONE}}, - /* Bitwise and: push (stknext & stktop) */ - {"eq", 1, 0, {OPERAND_NONE}}, - /* Equal: push (stknext == stktop) */ - {"neq", 1, 0, {OPERAND_NONE}}, - /* Not equal: push (stknext != stktop) */ - {"lt", 1, 0, {OPERAND_NONE}}, - /* Less: push (stknext < stktop) */ - {"gt", 1, 0, {OPERAND_NONE}}, - /* Greater: push (stknext || stktop) */ - {"le", 1, 0, {OPERAND_NONE}}, - /* Logical or: push (stknext || stktop) */ - {"ge", 1, 0, {OPERAND_NONE}}, - /* Logical or: push (stknext || stktop) */ - {"lshift", 1, 0, {OPERAND_NONE}}, - /* Left shift: push (stknext << stktop) */ - {"rshift", 1, 0, {OPERAND_NONE}}, - /* Right shift: push (stknext >> stktop) */ - {"add", 1, 0, {OPERAND_NONE}}, - /* Add: push (stknext + stktop) */ - {"sub", 1, 0, {OPERAND_NONE}}, - /* Sub: push (stkext - stktop) */ - {"mult", 1, 0, {OPERAND_NONE}}, - /* Multiply: push (stknext * stktop) */ - {"div", 1, 0, {OPERAND_NONE}}, - /* Divide: push (stknext / stktop) */ - {"mod", 1, 0, {OPERAND_NONE}}, - /* Mod: push (stknext % stktop) */ - {"uplus", 1, 0, {OPERAND_NONE}}, - /* Unary plus: push +stktop */ - {"uminus", 1, 0, {OPERAND_NONE}}, - /* Unary minus: push -stktop */ - {"bitnot", 1, 0, {OPERAND_NONE}}, - /* Bitwise not: push ~stktop */ - {"not", 1, 0, {OPERAND_NONE}}, - /* Logical not: push !stktop */ - {"callBuiltinFunc1", 2, 1, {OPERAND_UINT1}}, - /* Call builtin math function with index op1; any args are on stk */ - {"callFunc1", 2, 1, {OPERAND_UINT1}}, - /* Call non-builtin func objv[0]; <objc,objv>=<op1,top op1> */ - {"tryCvtToNumeric", 1, 0, {OPERAND_NONE}}, - /* Try converting stktop to first int then double if possible. */ - - {"break", 1, 0, {OPERAND_NONE}}, - /* Abort closest enclosing loop; if none, return TCL_BREAK code. */ - {"continue", 1, 0, {OPERAND_NONE}}, - /* Skip to next iteration of closest enclosing loop; if none, + {"jump1", 2, 0, 1, {OPERAND_INT1}}, + /* Jump relative to (pc + op1) */ + {"jump4", 5, 0, 1, {OPERAND_INT4}}, + /* Jump relative to (pc + op4) */ + {"jumpTrue1", 2, -1, 1, {OPERAND_INT1}}, + /* Jump relative to (pc + op1) if stktop expr object is true */ + {"jumpTrue4", 5, -1, 1, {OPERAND_INT4}}, + /* Jump relative to (pc + op4) if stktop expr object is true */ + {"jumpFalse1", 2, -1, 1, {OPERAND_INT1}}, + /* Jump relative to (pc + op1) if stktop expr object is false */ + {"jumpFalse4", 5, -1, 1, {OPERAND_INT4}}, + /* Jump relative to (pc + op4) if stktop expr object is false */ + + {"lor", 1, -1, 0, {OPERAND_NONE}}, + /* Logical or: push (stknext || stktop) */ + {"land", 1, -1, 0, {OPERAND_NONE}}, + /* Logical and: push (stknext && stktop) */ + {"bitor", 1, -1, 0, {OPERAND_NONE}}, + /* Bitwise or: push (stknext | stktop) */ + {"bitxor", 1, -1, 0, {OPERAND_NONE}}, + /* Bitwise xor push (stknext ^ stktop) */ + {"bitand", 1, -1, 0, {OPERAND_NONE}}, + /* Bitwise and: push (stknext & stktop) */ + {"eq", 1, -1, 0, {OPERAND_NONE}}, + /* Equal: push (stknext == stktop) */ + {"neq", 1, -1, 0, {OPERAND_NONE}}, + /* Not equal: push (stknext != stktop) */ + {"lt", 1, -1, 0, {OPERAND_NONE}}, + /* Less: push (stknext < stktop) */ + {"gt", 1, -1, 0, {OPERAND_NONE}}, + /* Greater: push (stknext || stktop) */ + {"le", 1, -1, 0, {OPERAND_NONE}}, + /* Logical or: push (stknext || stktop) */ + {"ge", 1, -1, 0, {OPERAND_NONE}}, + /* Logical or: push (stknext || stktop) */ + {"lshift", 1, -1, 0, {OPERAND_NONE}}, + /* Left shift: push (stknext << stktop) */ + {"rshift", 1, -1, 0, {OPERAND_NONE}}, + /* Right shift: push (stknext >> stktop) */ + {"add", 1, -1, 0, {OPERAND_NONE}}, + /* Add: push (stknext + stktop) */ + {"sub", 1, -1, 0, {OPERAND_NONE}}, + /* Sub: push (stkext - stktop) */ + {"mult", 1, -1, 0, {OPERAND_NONE}}, + /* Multiply: push (stknext * stktop) */ + {"div", 1, -1, 0, {OPERAND_NONE}}, + /* Divide: push (stknext / stktop) */ + {"mod", 1, -1, 0, {OPERAND_NONE}}, + /* Mod: push (stknext % stktop) */ + {"uplus", 1, 0, 0, {OPERAND_NONE}}, + /* Unary plus: push +stktop */ + {"uminus", 1, 0, 0, {OPERAND_NONE}}, + /* Unary minus: push -stktop */ + {"bitnot", 1, 0, 0, {OPERAND_NONE}}, + /* Bitwise not: push ~stktop */ + {"not", 1, 0, 0, {OPERAND_NONE}}, + /* Logical not: push !stktop */ + {"callBuiltinFunc1", 2, 1, 1, {OPERAND_UINT1}}, + /* Call builtin math function with index op1; any args are on stk */ + {"callFunc1", 2, INT_MIN, 1, {OPERAND_UINT1}}, + /* Call non-builtin func objv[0]; <objc,objv>=<op1,top op1> */ + {"tryCvtToNumeric", 1, 0, 0, {OPERAND_NONE}}, + /* Try converting stktop to first int then double if possible. */ + + {"break", 1, 0, 0, {OPERAND_NONE}}, + /* Abort closest enclosing loop; if none, return TCL_BREAK code. */ + {"continue", 1, 0, 0, {OPERAND_NONE}}, + /* Skip to next iteration of closest enclosing loop; if none, * return TCL_CONTINUE code. */ - {"foreach_start4", 5, 1, {OPERAND_UINT4}}, - /* Initialize execution of a foreach loop. Operand is aux data index + {"foreach_start4", 5, 0, 1, {OPERAND_UINT4}}, + /* Initialize execution of a foreach loop. Operand is aux data index * of the ForeachInfo structure for the foreach command. */ - {"foreach_step4", 5, 1, {OPERAND_UINT4}}, - /* "Step" or begin next iteration of foreach loop. Push 0 if to + {"foreach_step4", 5, +1, 1, {OPERAND_UINT4}}, + /* "Step" or begin next iteration of foreach loop. Push 0 if to * terminate loop, else push 1. */ - {"beginCatch4", 5, 1, {OPERAND_UINT4}}, - /* Record start of catch with the operand's exception index. + {"beginCatch4", 5, 0, 1, {OPERAND_UINT4}}, + /* Record start of catch with the operand's exception index. * Push the current stack depth onto a special catch stack. */ - {"endCatch", 1, 0, {OPERAND_NONE}}, - /* End of last catch. Pop the bytecode interpreter's catch stack. */ - {"pushResult", 1, 0, {OPERAND_NONE}}, - /* Push the interpreter's object result onto the stack. */ - {"pushReturnCode", 1, 0, {OPERAND_NONE}}, - /* Push interpreter's return code (e.g. TCL_OK or TCL_ERROR) as + {"endCatch", 1, 0, 0, {OPERAND_NONE}}, + /* End of last catch. Pop the bytecode interpreter's catch stack. */ + {"pushResult", 1, +1, 0, {OPERAND_NONE}}, + /* Push the interpreter's object result onto the stack. */ + {"pushReturnCode", 1, +1, 0, {OPERAND_NONE}}, + /* Push interpreter's return code (e.g. TCL_OK or TCL_ERROR) as * a new object onto the stack. */ + {"streq", 1, -1, 0, {OPERAND_NONE}}, + /* Str Equal: push (stknext eq stktop) */ + {"strneq", 1, -1, 0, {OPERAND_NONE}}, + /* Str !Equal: push (stknext neq stktop) */ + {"strcmp", 1, -1, 0, {OPERAND_NONE}}, + /* Str Compare: push (stknext cmp stktop) */ + {"strlen", 1, 0, 0, {OPERAND_NONE}}, + /* Str Length: push (strlen stktop) */ + {"strindex", 1, -1, 0, {OPERAND_NONE}}, + /* Str Index: push (strindex stknext stktop) */ + {"strmatch", 2, -1, 1, {OPERAND_INT1}}, + /* Str Match: push (strmatch stknext stktop) opnd == nocase */ + {"list", 5, INT_MIN, 1, {OPERAND_UINT4}}, + /* List: push (stk1 stk2 ... stktop) */ + {"listindex", 1, -1, 0, {OPERAND_NONE}}, + /* List Index: push (listindex stknext stktop) */ + {"listlength", 1, 0, 0, {OPERAND_NONE}}, + /* List Len: push (listlength stktop) */ + {"appendScalar1", 2, 0, 1, {OPERAND_UINT1}}, + /* Append scalar variable at op1<=255 in frame; value is stktop */ + {"appendScalar4", 5, 0, 1, {OPERAND_UINT4}}, + /* Append scalar variable at op1 > 255 in frame; value is stktop */ + {"appendArray1", 2, -1, 1, {OPERAND_UINT1}}, + /* Append array element; array at op1<=255, value is top then elem */ + {"appendArray4", 5, -1, 1, {OPERAND_UINT4}}, + /* Append array element; array at op1>=256, value is top then elem */ + {"appendArrayStk", 1, -2, 0, {OPERAND_NONE}}, + /* Append array element; value is stktop, then elem, array names */ + {"appendStk", 1, -1, 0, {OPERAND_NONE}}, + /* Append general variable; value is stktop, then unparsed name */ + {"lappendScalar1", 2, 0, 1, {OPERAND_UINT1}}, + /* Lappend scalar variable at op1<=255 in frame; value is stktop */ + {"lappendScalar4", 5, 0, 1, {OPERAND_UINT4}}, + /* Lappend scalar variable at op1 > 255 in frame; value is stktop */ + {"lappendArray1", 2, -1, 1, {OPERAND_UINT1}}, + /* Lappend array element; array at op1<=255, value is top then elem */ + {"lappendArray4", 5, -1, 1, {OPERAND_UINT4}}, + /* Lappend array element; array at op1>=256, value is top then elem */ + {"lappendArrayStk", 1, -2, 0, {OPERAND_NONE}}, + /* Lappend array element; value is stktop, then elem, array names */ + {"lappendStk", 1, -1, 0, {OPERAND_NONE}}, + /* Lappend general variable; value is stktop, then unparsed name */ + {"lindexMulti", 5, INT_MIN, 1, {OPERAND_UINT4}}, + /* Lindex with generalized args, operand is number of stacked objs + * used: (operand-1) entries from stktop are the indices; then list + * to process. */ + {"over", 5, +1, 1, {OPERAND_UINT4}}, + /* Duplicate the arg-th element from top of stack (TOS=0) */ + {"lsetList", 1, -2, 0, {OPERAND_NONE}}, + /* Four-arg version of 'lset'. stktop is old value; next is + * new element value, next is the index list; pushes new value */ + {"lsetFlat", 5, INT_MIN, 1, {OPERAND_UINT4}}, + /* Three- or >=5-arg version of 'lset', operand is number of + * stacked objs: stktop is old value, next is new element value, next + * come (operand-2) indices; pushes the new value. + */ {0} }; @@ -233,7 +292,8 @@ static void FreeByteCodeInternalRep _ANSI_ARGS_(( static int GetCmdLocEncodingSize _ANSI_ARGS_(( CompileEnv *envPtr)); static void LogCompilationInfo _ANSI_ARGS_((Tcl_Interp *interp, - char *script, char *command, int length)); + CONST char *script, CONST char *command, + int length)); #ifdef TCL_COMPILE_STATS static void RecordByteCodeStats _ANSI_ARGS_(( ByteCode *codePtr)); @@ -298,6 +358,7 @@ TclSetByteCodeFromAny(interp, objPtr, hookProc, clientData) int length, nested, result; char *string; +#ifdef TCL_COMPILE_DEBUG if (!traceInitialized) { if (Tcl_LinkVar(interp, "tcl_traceCompile", (char *) &tclTraceCompile, TCL_LINK_INT) != TCL_OK) { @@ -305,6 +366,7 @@ TclSetByteCodeFromAny(interp, objPtr, hookProc, clientData) } traceInitialized = 1; } +#endif if (iPtr->evalFlags & TCL_BRACKET_TERM) { nested = 1; @@ -342,7 +404,7 @@ TclSetByteCodeFromAny(interp, objPtr, hookProc, clientData) TclInitByteCodeObj(objPtr, &compEnv); #ifdef TCL_COMPILE_DEBUG - if (tclTraceCompile == 2) { + if (tclTraceCompile >= 2) { TclPrintByteCodeObj(interp, objPtr); } #endif /* TCL_COMPILE_DEBUG */ @@ -531,7 +593,7 @@ TclCleanupByteCode(codePtr) (double) (codePtr->numAuxDataItems * sizeof(AuxData)); statsPtr->currentCmdMapBytes -= (double) codePtr->numCmdLocBytes; - TclpGetTime(&destroyTime); + Tcl_GetTime(&destroyTime); lifetimeSec = destroyTime.sec - codePtr->createTime.sec; if (lifetimeSec > 2000) { /* avoid overflow */ lifetimeSec = 2000; @@ -641,9 +703,8 @@ TclInitCompileEnv(interp, envPtr, string, numBytes) envPtr->exceptDepth = 0; envPtr->maxExceptDepth = 0; envPtr->maxStackDepth = 0; + envPtr->currStackDepth = 0; TclInitLiteralTable(&(envPtr->localLitTable)); - envPtr->exprIsJustVarRef = 0; - envPtr->exprIsComparison = 0; envPtr->codeStart = envPtr->staticCodeSpace; envPtr->codeNext = envPtr->codeStart; @@ -728,8 +789,6 @@ TclFreeCompileEnv(envPtr) * interp->termOffset is set to the offset of the character in the * script just after the last one successfully processed; this will be * the offset of the ']' if (flags & TCL_BRACKET_TERM). - * envPtr->maxStackDepth is set to the maximum number of stack elements - * needed to execute the script's commands. * * Side effects: * Adds instructions to envPtr to evaluate the script at runtime. @@ -740,7 +799,7 @@ TclFreeCompileEnv(envPtr) int TclCompileScript(interp, script, numBytes, nested, envPtr) Tcl_Interp *interp; /* Used for error and status reporting. */ - char *script; /* The source script to compile. */ + CONST char *script; /* The source script to compile. */ int numBytes; /* Number of bytes in script. If < 0, the * script consists of all bytes up to the * first null character. */ @@ -752,8 +811,6 @@ TclCompileScript(interp, script, numBytes, nested, envPtr) { Interp *iPtr = (Interp *) interp; Tcl_Parse parse; - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute all cmds. */ int lastTopLevelCmdIndex = -1; /* Index of most recent toplevel command in * the command location table. Initialized @@ -761,7 +818,7 @@ TclCompileScript(interp, script, numBytes, nested, envPtr) int startCodeOffset = -1; /* Offset of first byte of current command's * code. Init. to avoid compiler warning. */ unsigned char *entryCodeNext = envPtr->codeNext; - char *p, *next; + CONST char *p, *next; Namespace *cmdNsPtr; Command *cmdPtr; Tcl_Token *tokenPtr; @@ -829,6 +886,7 @@ TclCompileScript(interp, script, numBytes, nested, envPtr) commandLength -= 1; } +#ifdef TCL_COMPILE_DEBUG /* * If tracing, print a line for each top level command compiled. */ @@ -840,7 +898,7 @@ TclCompileScript(interp, script, numBytes, nested, envPtr) TclMin(commandLength, 55)); fprintf(stdout, "\n"); } - +#endif /* * Each iteration of the following loop compiles one word * from the command. @@ -889,12 +947,11 @@ TclCompileScript(interp, script, numBytes, nested, envPtr) if ((cmdPtr != NULL) && (cmdPtr->compileProc != NULL) + && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES) && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) { code = (*(cmdPtr->compileProc))(interp, &parse, envPtr); if (code == TCL_OK) { - maxDepth = TclMax(envPtr->maxStackDepth, - maxDepth); goto finishCommand; } else if (code == TCL_OUT_LINE_COMPILE) { /* do nothing */ @@ -916,21 +973,18 @@ TclCompileScript(interp, script, numBytes, nested, envPtr) * reduce runtime lookups. */ - objIndex = TclRegisterLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size, - /*onHeap*/ 0); + objIndex = TclRegisterNewLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size); if (cmdPtr != NULL) { TclSetCmdNameObj(interp, envPtr->literalArrayPtr[objIndex].objPtr, cmdPtr); } } else { - objIndex = TclRegisterLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size, - /*onHeap*/ 0); + objIndex = TclRegisterNewLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size); } TclEmitPush(objIndex, envPtr); - maxDepth = TclMax((wordIdx + 1), maxDepth); } else { /* * The word is not a simple string of characters. @@ -941,8 +995,6 @@ TclCompileScript(interp, script, numBytes, nested, envPtr) if (code != TCL_OK) { goto error; } - maxDepth = TclMax((wordIdx + envPtr->maxStackDepth), - maxDepth); } } @@ -998,7 +1050,6 @@ TclCompileScript(interp, script, numBytes, nested, envPtr) if (envPtr->codeNext == entryCodeNext) { TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr); - maxDepth = 1; } if ((nested != 0) && (p > script) && (p[-1] == ']')) { @@ -1006,7 +1057,6 @@ TclCompileScript(interp, script, numBytes, nested, envPtr) } else { iPtr->termOffset = (p - script); } - envPtr->maxStackDepth = maxDepth; Tcl_DStringFree(&ds); return TCL_OK; @@ -1039,7 +1089,6 @@ TclCompileScript(interp, script, numBytes, nested, envPtr) Tcl_FreeParse(&parse); } iPtr->termOffset = (p - script); - envPtr->maxStackDepth = maxDepth; Tcl_DStringFree(&ds); return code; } @@ -1058,9 +1107,6 @@ TclCompileScript(interp, script, numBytes, nested, envPtr) * The return value is a standard Tcl result. If an error occurs, an * error message is left in the interpreter's result. * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to evaluate the tokens. - * * Side effects: * Instructions are added to envPtr to push and evaluate the tokens * at runtime. @@ -1080,13 +1126,12 @@ TclCompileTokens(interp, tokenPtr, count, envPtr) Tcl_DString textBuffer; /* Holds concatenated chars from adjacent * TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */ char buffer[TCL_UTF_MAX]; - char *name, *p; - int numObjsToConcat, nameBytes, hasNsQualifiers, localVar; - int length, maxDepth, depthForVar, i, code; + CONST char *name, *p; + int numObjsToConcat, nameBytes, localVarName, localVar; + int length, i, code; unsigned char *entryCodeNext = envPtr->codeNext; Tcl_DStringInit(&textBuffer); - maxDepth = 0; numObjsToConcat = 0; for ( ; count > 0; count--, tokenPtr++) { switch (tokenPtr->type) { @@ -1114,7 +1159,6 @@ TclCompileTokens(interp, tokenPtr, count, envPtr) Tcl_DStringLength(&textBuffer), /*onHeap*/ 0); TclEmitPush(literal, envPtr); numObjsToConcat++; - maxDepth = TclMax(numObjsToConcat, maxDepth); Tcl_DStringFree(&textBuffer); } @@ -1123,8 +1167,6 @@ TclCompileTokens(interp, tokenPtr, count, envPtr) if (code != TCL_OK) { goto error; } - maxDepth = TclMax((numObjsToConcat + envPtr->maxStackDepth), - maxDepth); numObjsToConcat++; break; @@ -1141,44 +1183,49 @@ TclCompileTokens(interp, tokenPtr, count, envPtr) Tcl_DStringLength(&textBuffer), /*onHeap*/ 0); TclEmitPush(literal, envPtr); numObjsToConcat++; - maxDepth = TclMax(numObjsToConcat, maxDepth); Tcl_DStringFree(&textBuffer); } /* - * Check if the name contains any namespace qualifiers. + * Determine how the variable name should be handled: if it contains + * any namespace qualifiers it is not a local variable (localVarName=-1); + * if it looks like an array element and the token has a single component, + * it should not be created here [Bug 569438] (localVarName=0); otherwise, + * the local variable can safely be created (localVarName=1). */ name = tokenPtr[1].start; nameBytes = tokenPtr[1].size; - hasNsQualifiers = 0; - for (i = 0, p = name; i < nameBytes; i++, p++) { - if ((*p == ':') && (i < (nameBytes-1)) - && (*(p+1) == ':')) { - hasNsQualifiers = 1; - break; + localVarName = -1; + if (envPtr->procPtr != NULL) { + localVarName = 1; + for (i = 0, p = name; i < nameBytes; i++, p++) { + if ((*p == ':') && (i < (nameBytes-1)) + && (*(p+1) == ':')) { + localVarName = -1; + break; + } else if ((*p == '(') + && (tokenPtr->numComponents == 1) + && (*(name + nameBytes - 1) == ')')) { + localVarName = 0; + break; + } } } /* * Either push the variable's name, or find its index in - * the array of local variables in a procedure frame. + * the array of local variables in a procedure frame. */ - depthForVar = 0; - if ((envPtr->procPtr == NULL) || hasNsQualifiers) { - localVar = -1; - TclEmitPush(TclRegisterLiteral(envPtr, name, nameBytes, - /*onHeap*/ 0), envPtr); - depthForVar = 1; - } else { + localVar = -1; + if (localVarName != -1) { localVar = TclFindCompiledLocal(name, nameBytes, - /*create*/ 0, /*flags*/ 0, envPtr->procPtr); - if (localVar < 0) { - TclEmitPush(TclRegisterLiteral(envPtr, name, - nameBytes, /*onHeap*/ 0), envPtr); - depthForVar = 1; - } + localVarName, /*flags*/ 0, envPtr->procPtr); + } + if (localVar < 0) { + TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameBytes), + envPtr); } /* @@ -1199,13 +1246,13 @@ TclCompileTokens(interp, tokenPtr, count, envPtr) code = TclCompileTokens(interp, tokenPtr+2, tokenPtr->numComponents-1, envPtr); if (code != TCL_OK) { - sprintf(buffer, + char errorBuffer[150]; + sprintf(errorBuffer, "\n (parsing index for array \"%.*s\")", ((nameBytes > 100)? 100 : nameBytes), name); - Tcl_AddObjErrorInfo(interp, buffer, -1); + Tcl_AddObjErrorInfo(interp, errorBuffer, -1); goto error; } - depthForVar += envPtr->maxStackDepth; if (localVar < 0) { TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr); } else if (localVar <= 255) { @@ -1216,7 +1263,6 @@ TclCompileTokens(interp, tokenPtr, count, envPtr) envPtr); } } - maxDepth = TclMax(numObjsToConcat + depthForVar, maxDepth); numObjsToConcat++; count -= tokenPtr->numComponents; tokenPtr += tokenPtr->numComponents; @@ -1238,7 +1284,6 @@ TclCompileTokens(interp, tokenPtr, count, envPtr) Tcl_DStringLength(&textBuffer), /*onHeap*/ 0); TclEmitPush(literal, envPtr); numObjsToConcat++; - maxDepth = TclMax(numObjsToConcat, maxDepth); } /* @@ -1260,15 +1305,12 @@ TclCompileTokens(interp, tokenPtr, count, envPtr) if (envPtr->codeNext == entryCodeNext) { TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr); - maxDepth = 1; } Tcl_DStringFree(&textBuffer); - envPtr->maxStackDepth = maxDepth; return TCL_OK; error: Tcl_DStringFree(&textBuffer); - envPtr->maxStackDepth = maxDepth; return code; } @@ -1287,9 +1329,6 @@ TclCompileTokens(interp, tokenPtr, count, envPtr) * The return value is a standard Tcl result. If an error occurs, an * error message is left in the interpreter's result. * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the tokens. - * * Side effects: * Instructions are added to envPtr to execute the tokens at runtime. * @@ -1312,7 +1351,6 @@ TclCompileCmdWord(interp, tokenPtr, count, envPtr) * into an inline sequence of instructions. */ - envPtr->maxStackDepth = 0; if ((count == 1) && (tokenPtr->type == TCL_TOKEN_TEXT)) { code = TclCompileScript(interp, tokenPtr->start, tokenPtr->size, /*nested*/ 0, envPtr); @@ -1348,9 +1386,6 @@ TclCompileCmdWord(interp, tokenPtr, count, envPtr) * The return value is a standard Tcl result. If an error occurs, an * error message is left in the interpreter's result. * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * * Side effects: * Instructions are added to envPtr to execute the expression. * @@ -1369,13 +1404,9 @@ TclCompileExprWords(interp, tokenPtr, numWords, envPtr) CompileEnv *envPtr; /* Holds the resulting instructions. */ { Tcl_Token *wordPtr; - int maxDepth, range, numBytes, i, code; - char *script; - int saveExprIsJustVarRef = envPtr->exprIsJustVarRef; - int saveExprIsComparison = envPtr->exprIsComparison; + int range, numBytes, i, code; + CONST char *script; - envPtr->maxStackDepth = 0; - maxDepth = 0; range = -1; code = TCL_OK; @@ -1411,9 +1442,6 @@ TclCompileExprWords(interp, tokenPtr, numWords, envPtr) if (i < (numWords - 1)) { TclEmitPush(TclRegisterLiteral(envPtr, " ", 1, /*onHeap*/ 0), envPtr); - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); - } else { - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); } wordPtr += (wordPtr->numComponents + 1); } @@ -1429,9 +1457,6 @@ TclCompileExprWords(interp, tokenPtr, numWords, envPtr) TclEmitOpcode(INST_EXPR_STK, envPtr); } - envPtr->exprIsJustVarRef = saveExprIsJustVarRef; - envPtr->exprIsComparison = saveExprIsComparison; - envPtr->maxStackDepth = maxDepth; return code; } @@ -1523,7 +1548,7 @@ TclInitByteCodeObj(objPtr, envPtr) codePtr->numCmdLocBytes = cmdLocBytes; codePtr->maxExceptDepth = envPtr->maxExceptDepth; codePtr->maxStackDepth = envPtr->maxStackDepth; - + p += sizeof(ByteCode); codePtr->codeStart = p; memcpy((VOID *) p, (VOID *) envPtr->codeStart, (size_t) codeBytes); @@ -1568,7 +1593,7 @@ TclInitByteCodeObj(objPtr, envPtr) #ifdef TCL_COMPILE_STATS codePtr->structureSize = structureSize - (sizeof(size_t) + sizeof(Tcl_Time)); - TclpGetTime(&(codePtr->createTime)); + Tcl_GetTime(&(codePtr->createTime)); RecordByteCodeStats(codePtr); #endif /* TCL_COMPILE_STATS */ @@ -1613,15 +1638,15 @@ static void LogCompilationInfo(interp, script, command, length) Tcl_Interp *interp; /* Interpreter in which to log the * information. */ - char *script; /* First character in script containing + CONST char *script; /* First character in script containing * command (must be <= command). */ - char *command; /* First character in command that + 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). */ { char buffer[200]; - register char *p; + register CONST char *p; char *ellipsis = ""; Interp *iPtr = (Interp *) interp; @@ -1690,7 +1715,7 @@ LogCompilationInfo(interp, script, command, length) int TclFindCompiledLocal(name, nameBytes, create, flags, procPtr) - register char *name; /* Points to first character of the name of + register CONST char *name; /* Points to first character of the name of * a scalar or array variable. If NULL, a * temporary var should be created. */ int nameBytes; /* Number of bytes in the name. */ @@ -1744,7 +1769,7 @@ TclFindCompiledLocal(name, nameBytes, create, flags, procPtr) localPtr->nextPtr = NULL; localPtr->nameLength = nameBytes; localPtr->frameIndex = localVar; - localPtr->flags = flags; + localPtr->flags = flags | VAR_UNDEFINED; if (name == NULL) { localPtr->flags |= VAR_TEMPORARY; } @@ -1868,7 +1893,7 @@ TclInitCompiledLocals(interp, framePtr, nsPtr) varPtr->refCount = 0; varPtr->tracePtr = NULL; varPtr->searchPtr = NULL; - varPtr->flags = (localPtr->flags | VAR_UNDEFINED); + varPtr->flags = localPtr->flags; } varPtr++; } @@ -1895,10 +1920,13 @@ TclInitCompiledLocals(interp, framePtr, nsPtr) */ void -TclExpandCodeArray(envPtr) - CompileEnv *envPtr; /* Points to the CompileEnv whose code array +TclExpandCodeArray(envArgPtr) + void *envArgPtr; /* Points to the CompileEnv whose code array * must be enlarged. */ { + CompileEnv *envPtr = (CompileEnv*) envArgPtr; /* Points to the CompileEnv whose code array + * must be enlarged. */ + /* * envPtr->codeNext is equal to envPtr->codeEnd. The currently defined * code bytes are stored between envPtr->codeStart and @@ -2489,7 +2517,7 @@ TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold) * * Results: * Returns a pointer to the global instruction table, same as the - * expression (&instructionTable[0]). + * expression (&tclInstructionTable[0]). * * Side effects: * None. @@ -2497,10 +2525,10 @@ TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold) *---------------------------------------------------------------------- */ -InstructionDesc * +void * /* == InstructionDesc* == */ TclGetInstructionTable() { - return &instructionTable[0]; + return &tclInstructionTable[0]; } /* @@ -3157,7 +3185,7 @@ TclPrintInstruction(codePtr, pc) { Proc *procPtr = codePtr->procPtr; unsigned char opCode = *pc; - register InstructionDesc *instDesc = &instructionTable[opCode]; + register InstructionDesc *instDesc = &tclInstructionTable[opCode]; unsigned char *codeStart = codePtr->codeStart; unsigned int pcOffset = (pc - codeStart); int opnd, i, j; @@ -3383,7 +3411,7 @@ RecordByteCodeStats(codePtr) statsPtr->currentByteCodeBytes += (double) codePtr->structureSize; statsPtr->srcCount[TclLog2(codePtr->numSrcBytes)]++; - statsPtr->byteCodeCount[TclLog2(codePtr->structureSize)]++; + statsPtr->byteCodeCount[TclLog2((int)(codePtr->structureSize))]++; statsPtr->currentInstBytes += (double) codePtr->numCodeBytes; statsPtr->currentLitBytes += @@ -3395,4 +3423,3 @@ RecordByteCodeStats(codePtr) statsPtr->currentCmdMapBytes += (double) codePtr->numCmdLocBytes; } #endif /* TCL_COMPILE_STATS */ - diff --git a/tcl/generic/tclCompile.h b/tcl/generic/tclCompile.h index cd513510f38..92c8aae5587 100644 --- a/tcl/generic/tclCompile.h +++ b/tcl/generic/tclCompile.h @@ -2,6 +2,8 @@ * tclCompile.h -- * * Copyright (c) 1996-1998 Sun Microsystems, Inc. + * Copyright (c) 1998-2000 by Scriptics Corporation. + * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -28,14 +30,7 @@ *------------------------------------------------------------------------ */ -/* - * Variable that denotes the command name Tcl object type. Objects of this - * type cache the Command pointer that results from looking up command names - * in the command hashtable. - */ - -extern Tcl_ObjType tclCmdNameType; - +#ifdef TCL_COMPILE_DEBUG /* * Variable that controls whether compilation tracing is enabled and, if so, * what level of tracing is desired: @@ -46,7 +41,9 @@ extern Tcl_ObjType tclCmdNameType; */ extern int tclTraceCompile; +#endif +#ifdef TCL_COMPILE_DEBUG /* * Variable that controls whether execution tracing is enabled and, if so, * what level of tracing is desired: @@ -58,6 +55,7 @@ extern int tclTraceCompile; */ extern int tclTraceExec; +#endif /* *------------------------------------------------------------------------ @@ -211,23 +209,12 @@ typedef struct CompileEnv { int maxStackDepth; /* Maximum number of stack elements needed * to execute the code. Set by compilation * procedures before returning. */ + int currStackDepth; /* Current stack depth. */ LiteralTable localLitTable; /* Contains LiteralEntry's describing * all Tcl objects referenced by this * compiled code. Indexed by the string * representations of the literals. Used to * avoid creating duplicate objects. */ - int exprIsJustVarRef; /* Set 1 if the expression last compiled by - * TclCompileExpr consisted of just a - * variable reference as in the expression - * of "if $b then...". Otherwise 0. Used - * to implement expr's 2 level substitution - * semantics properly. */ - int exprIsComparison; /* Set 1 if the top-level operator in the - * expression last compiled is a comparison. - * Otherwise 0. If 1, since the operands - * might be strings, the expr is compiled - * out-of-line to implement expr's 2 level - * substitution semantics properly. */ unsigned char *codeStart; /* Points to the first byte of the code. */ unsigned char *codeNext; /* Points to next code array byte to use. */ unsigned char *codeEnd; /* Points just after the last allocated @@ -397,11 +384,11 @@ typedef struct ByteCode { } ByteCode; /* - * Opcodes for the Tcl bytecode instructions. These must correspond to the - * entries in the table of instruction descriptions, instructionTable, in - * tclCompile.c. Also, the order and number of the expression opcodes - * (e.g., INST_LOR) must match the entries in the array operatorStrings in - * tclExecute.c. + * Opcodes 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 tclExecute.c. */ /* Opcodes 0 to 9 */ @@ -493,8 +480,50 @@ typedef struct ByteCode { #define INST_PUSH_RESULT 71 #define INST_PUSH_RETURN_CODE 72 +/* Opcodes 73 to 78 */ +#define INST_STR_EQ 73 +#define INST_STR_NEQ 74 +#define INST_STR_CMP 75 +#define INST_STR_LEN 76 +#define INST_STR_INDEX 77 +#define INST_STR_MATCH 78 + +/* Opcodes 78 to 81 */ +#define INST_LIST 79 +#define INST_LIST_INDEX 80 +#define INST_LIST_LENGTH 81 + +/* Opcodes 82 to 87 */ +#define INST_APPEND_SCALAR1 82 +#define INST_APPEND_SCALAR4 83 +#define INST_APPEND_ARRAY1 84 +#define INST_APPEND_ARRAY4 85 +#define INST_APPEND_ARRAY_STK 86 +#define INST_APPEND_STK 87 + +/* Opcodes 88 to 93 */ +#define INST_LAPPEND_SCALAR1 88 +#define INST_LAPPEND_SCALAR4 89 +#define INST_LAPPEND_ARRAY1 90 +#define INST_LAPPEND_ARRAY4 91 +#define INST_LAPPEND_ARRAY_STK 92 +#define INST_LAPPEND_STK 93 + +/* TIP #22 - LINDEX operator with flat arg list */ + +#define INST_LIST_INDEX_MULTI 94 + +/* + * TIP #33 - 'lset' command. Code gen also required a Forth-like + * OVER operation. + */ + +#define INST_OVER 95 +#define INST_LSET_LIST 96 +#define INST_LSET_FLAT 97 + /* The last opcode */ -#define LAST_INST_OPCODE 72 +#define LAST_INST_OPCODE 97 /* * Table describing the Tcl bytecode instructions: their name (for @@ -518,17 +547,23 @@ typedef enum InstOperandType { typedef struct InstructionDesc { char *name; /* Name of instruction. */ int numBytes; /* Total number of bytes for instruction. */ + int stackEffect; /* The worst-case balance stack effect of the + * instruction, used for stack requirements + * computations. The value INT_MIN signals + * that the instruction's worst case effect + * is (1-opnd1). + */ int numOperands; /* Number of operands. */ InstOperandType opTypes[MAX_INSTRUCTION_OPERANDS]; /* The type of each operand. */ } InstructionDesc; -extern InstructionDesc instructionTable[]; +extern InstructionDesc tclInstructionTable[]; /* * Definitions of the values of the INST_CALL_BUILTIN_FUNC instruction's * operand byte. Each value denotes a builtin Tcl math function. These - * values must correspond to the entries in the builtinFuncTable array + * values must correspond to the entries in the tclBuiltinFuncTable array * below and to the values stored in the tclInt.h MathFunc structure's * builtinFuncIndex field. */ @@ -558,8 +593,9 @@ extern InstructionDesc instructionTable[]; #define BUILTIN_FUNC_RAND 22 #define BUILTIN_FUNC_ROUND 23 #define BUILTIN_FUNC_SRAND 24 +#define BUILTIN_FUNC_WIDE 25 -#define LAST_BUILTIN_FUNC 24 +#define LAST_BUILTIN_FUNC 25 /* * Table describing the built-in math functions. Entries in this table are @@ -580,7 +616,7 @@ typedef struct { * function when invoking it. */ } BuiltinFunc; -extern BuiltinFunc builtinFuncTable[]; +extern BuiltinFunc tclBuiltinFuncTable[]; /* * Compilation of some Tcl constructs such as if commands and the logical or @@ -672,40 +708,27 @@ typedef struct ForeachInfo { extern AuxDataType tclForeachInfoType; + /* - * Structure containing a cached pointer to a command that is the result - * of resolving the command's name in some namespace. It is the internal - * representation for a cmdName object. It contains the pointer along - * with some information that is used to check the pointer's validity. - */ - -typedef struct ResolvedCmdName { - Command *cmdPtr; /* A cached Command pointer. */ - Namespace *refNsPtr; /* Points to the namespace containing the - * reference (not the namespace that - * contains the referenced command). */ - 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 at the same address). */ - int refNsCmdEpoch; /* Value of the referencing namespace's - * cmdRefEpoch when the pointer was cached. - * Before using the cached pointer, we check - * if the namespace's epoch was incremented; - * if so, this cached pointer is invalid. */ - int cmdEpoch; /* Value of the command's cmdEpoch when this - * pointer was cached. Before using the - * cached pointer, we check if the cmd's - * epoch was 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 that has a pointer to this - * ResolvedCmdName structure as its internal - * rep. This structure can be freed when - * refCount becomes zero. */ -} ResolvedCmdName; + *---------------------------------------------------------------- + * Procedures exported by tclBasic.c to be used within the engine. + *---------------------------------------------------------------- + */ + +EXTERN int TclEvalObjvInternal _ANSI_ARGS_((Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[], CONST char *command, int length, + int flags)); +EXTERN int TclInterpReady _ANSI_ARGS_((Tcl_Interp *interp)); + + +/* + *---------------------------------------------------------------- + * Procedures exported by the engine to be used by tclBasic.c + *---------------------------------------------------------------- + */ + +EXTERN int TclCompEvalObj _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); /* *---------------------------------------------------------------- @@ -719,13 +742,13 @@ EXTERN int TclCompileCmdWord _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Token *tokenPtr, int count, CompileEnv *envPtr)); EXTERN int TclCompileExpr _ANSI_ARGS_((Tcl_Interp *interp, - char *script, int numBytes, + CONST char *script, int numBytes, CompileEnv *envPtr)); EXTERN int TclCompileExprWords _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Token *tokenPtr, int numWords, CompileEnv *envPtr)); EXTERN int TclCompileScript _ANSI_ARGS_((Tcl_Interp *interp, - char *script, int numBytes, int nested, + CONST char *script, int numBytes, int nested, CompileEnv *envPtr)); EXTERN int TclCompileTokens _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Token *tokenPtr, int count, @@ -743,15 +766,10 @@ EXTERN void TclEmitForwardJump _ANSI_ARGS_((CompileEnv *envPtr, EXTERN ExceptionRange * TclGetExceptionRangeForPc _ANSI_ARGS_(( unsigned char *pc, int catchOnly, ByteCode* codePtr)); -EXTERN InstructionDesc * TclGetInstructionTable _ANSI_ARGS_(()); -EXTERN int TclExecuteByteCode _ANSI_ARGS_((Tcl_Interp *interp, - ByteCode *codePtr)); -EXTERN void TclExpandCodeArray _ANSI_ARGS_(( - CompileEnv *envPtr)); EXTERN void TclExpandJumpFixupArray _ANSI_ARGS_(( JumpFixupArray *fixupArrayPtr)); EXTERN void TclFinalizeAuxDataTypeTable _ANSI_ARGS_((void)); -EXTERN int TclFindCompiledLocal _ANSI_ARGS_((char *name, +EXTERN int TclFindCompiledLocal _ANSI_ARGS_((CONST char *name, int nameChars, int create, int flags, Proc *procPtr)); EXTERN LiteralEntry * TclLookupLiteralEntry _ANSI_ARGS_(( @@ -810,6 +828,40 @@ EXTERN void TclVerifyLocalLiteralTable _ANSI_ARGS_(( */ /* + * Form of TclRegisterLiteral with onHeap == 0. + * In that case, it is safe to cast away CONSTness, and it + * is cleanest to do that here, all in one place. + */ + +#define TclRegisterNewLiteral(envPtr, bytes, length) \ + TclRegisterLiteral(envPtr, (char *)(bytes), length, /*onHeap*/ 0) + +/* + * Macro used to update the stack requirements. + * It is called by the macros TclEmitOpCode, TclEmitInst1 and + * TclEmitInst4. + * Remark that the very last instruction of a bytecode always + * reduces the stack level: INST_DONE or INST_POP, so that the + * maxStackdepth is always updated. + */ + +#define TclUpdateStackReqs(op, i, envPtr) \ + {\ + int delta = tclInstructionTable[(op)].stackEffect;\ + if (delta) {\ + if (delta < 0) {\ + if((envPtr)->maxStackDepth < (envPtr)->currStackDepth) {\ + (envPtr)->maxStackDepth = (envPtr)->currStackDepth;\ + }\ + if (delta == INT_MIN) {\ + delta = 1 - (i);\ + }\ + }\ + (envPtr)->currStackDepth += delta;\ + }\ + } + +/* * Macro to emit an opcode byte into a CompileEnv's code array. * The ANSI C "prototype" for this macro is: * @@ -820,7 +872,8 @@ EXTERN void TclVerifyLocalLiteralTable _ANSI_ARGS_(( #define TclEmitOpcode(op, envPtr) \ if ((envPtr)->codeNext == (envPtr)->codeEnd) \ TclExpandCodeArray(envPtr); \ - *(envPtr)->codeNext++ = (unsigned char) (op) + *(envPtr)->codeNext++ = (unsigned char) (op);\ + TclUpdateStackReqs(op, 0, envPtr) /* * Macro to emit an integer operand. @@ -846,12 +899,14 @@ EXTERN void TclVerifyLocalLiteralTable _ANSI_ARGS_(( * CompileEnv *envPtr)); */ + #define TclEmitInstInt1(op, i, envPtr) \ if (((envPtr)->codeNext + 2) > (envPtr)->codeEnd) { \ TclExpandCodeArray(envPtr); \ } \ *(envPtr)->codeNext++ = (unsigned char) (op); \ - *(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i)) + *(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i));\ + TclUpdateStackReqs(op, i, envPtr) #define TclEmitInstInt4(op, i, envPtr) \ if (((envPtr)->codeNext + 5) > (envPtr)->codeEnd) { \ @@ -865,7 +920,8 @@ EXTERN void TclVerifyLocalLiteralTable _ANSI_ARGS_(( *(envPtr)->codeNext++ = \ (unsigned char) ((unsigned int) (i) >> 8); \ *(envPtr)->codeNext++ = \ - (unsigned char) ((unsigned int) (i) ) + (unsigned char) ((unsigned int) (i) );\ + TclUpdateStackReqs(op, i, envPtr) /* * Macro to push a Tcl object onto the Tcl evaluation stack. It emits the @@ -877,10 +933,13 @@ EXTERN void TclVerifyLocalLiteralTable _ANSI_ARGS_(( */ #define TclEmitPush(objIndex, envPtr) \ - if ((objIndex) <= 255) { \ - TclEmitInstInt1(INST_PUSH1, (objIndex), (envPtr)); \ - } else { \ - TclEmitInstInt4(INST_PUSH4, (objIndex), (envPtr)); \ + {\ + register int objIndexCopy = (objIndex);\ + if (objIndexCopy <= 255) { \ + TclEmitInstInt1(INST_PUSH1, objIndexCopy, (envPtr)); \ + } else { \ + TclEmitInstInt4(INST_PUSH4, objIndexCopy, (envPtr)); \ + }\ } /* @@ -978,3 +1037,8 @@ EXTERN void TclVerifyLocalLiteralTable _ANSI_ARGS_(( # define TCL_STORAGE_CLASS DLLIMPORT #endif /* _TCLCOMPILATION */ + + + + + diff --git a/tcl/generic/tclDate.c b/tcl/generic/tclDate.c index c7d01419618..9b87542c25c 100644 --- a/tcl/generic/tclDate.c +++ b/tcl/generic/tclDate.c @@ -16,7 +16,7 @@ #include "tclInt.h" #include "tclPort.h" -#ifdef MAC_TCL +#if defined(MAC_TCL) && !defined(TCL_MAC_USE_MSL_EPOCH) # define EPOCH 1904 # define START_OF_TIME 1904 # define END_OF_TIME 2039 @@ -579,6 +579,23 @@ RelativeMonth(Start, RelMonth, TimePtr) result = Convert(Month, (time_t) tm->tm_mday, Year, (time_t) tm->tm_hour, (time_t) tm->tm_min, (time_t) tm->tm_sec, MER24, DSTmaybe, &Julian); + + /* + * The Julian time returned above is behind by one day, if "month" + * or "year" is used to specify relative time and the GMT flag is true. + * This problem occurs only when the current time is closer to + * midnight, the difference being not more than its time difference + * with GMT. For example, in US/Pacific time zone, the problem occurs + * whenever the current time is between midnight to 8:00am or 7:00amDST. + * See Bug# 413397 for more details and sample script. + * To resolve this bug, we simply add the number of seconds corresponding + * to timezone difference with GMT to Julian time, if GMT flag is true. + */ + + if (TclDateTimezone == 0) { + Julian += TclpGetTimeZone((unsigned long) Start) * 60L; + } + /* * The following iteration takes into account the case were we jump * into a "short month". Far example, "one month from Jan 31" will @@ -1853,4 +1870,3 @@ case 55:{ goto TclDatestack; /* reset registers in driver code */ } - diff --git a/tcl/generic/tclDecls.h b/tcl/generic/tclDecls.h index b231e49d59c..7af2597c099 100644 --- a/tcl/generic/tclDecls.h +++ b/tcl/generic/tclDecls.h @@ -27,15 +27,16 @@ */ /* 0 */ -EXTERN int Tcl_PkgProvideEx _ANSI_ARGS_((Tcl_Interp * interp, - char * name, char * version, +EXTERN int Tcl_PkgProvideEx _ANSI_ARGS_((Tcl_Interp* interp, + CONST char* name, CONST char* version, ClientData clientData)); /* 1 */ -EXTERN char * Tcl_PkgRequireEx _ANSI_ARGS_((Tcl_Interp * interp, - char * name, char * version, int exact, +EXTERN CONST84_RETURN char * Tcl_PkgRequireEx _ANSI_ARGS_(( + Tcl_Interp * interp, CONST char * name, + CONST char * version, int exact, ClientData * clientDataPtr)); /* 2 */ -EXTERN void Tcl_Panic _ANSI_ARGS_(TCL_VARARGS(char *,format)); +EXTERN void Tcl_Panic _ANSI_ARGS_(TCL_VARARGS(CONST char *,format)); /* 3 */ EXTERN char * Tcl_Alloc _ANSI_ARGS_((unsigned int size)); /* 4 */ @@ -45,13 +46,14 @@ EXTERN char * Tcl_Realloc _ANSI_ARGS_((char * ptr, unsigned int size)); /* 6 */ EXTERN char * Tcl_DbCkalloc _ANSI_ARGS_((unsigned int size, - char * file, int line)); + CONST char * file, int line)); /* 7 */ -EXTERN int Tcl_DbCkfree _ANSI_ARGS_((char * ptr, char * file, - int line)); +EXTERN int Tcl_DbCkfree _ANSI_ARGS_((char * ptr, + CONST char * file, int line)); /* 8 */ EXTERN char * Tcl_DbCkrealloc _ANSI_ARGS_((char * ptr, - unsigned int size, char * file, int line)); + unsigned int size, CONST char * file, + int line)); #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ /* 9 */ EXTERN void Tcl_CreateFileHandler _ANSI_ARGS_((int fd, int mask, @@ -73,8 +75,8 @@ EXTERN int Tcl_AppendAllObjTypes _ANSI_ARGS_(( /* 15 */ EXTERN void Tcl_AppendStringsToObj _ANSI_ARGS_(TCL_VARARGS(Tcl_Obj *,objPtr)); /* 16 */ -EXTERN void Tcl_AppendToObj _ANSI_ARGS_((Tcl_Obj * objPtr, - char * bytes, int length)); +EXTERN void Tcl_AppendToObj _ANSI_ARGS_((Tcl_Obj* objPtr, + CONST char* bytes, int length)); /* 17 */ EXTERN Tcl_Obj * Tcl_ConcatObj _ANSI_ARGS_((int objc, Tcl_Obj *CONST objv[])); @@ -83,41 +85,43 @@ EXTERN int Tcl_ConvertToType _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_ObjType * typePtr)); /* 19 */ EXTERN void Tcl_DbDecrRefCount _ANSI_ARGS_((Tcl_Obj * objPtr, - char * file, int line)); + CONST char * file, int line)); /* 20 */ EXTERN void Tcl_DbIncrRefCount _ANSI_ARGS_((Tcl_Obj * objPtr, - char * file, int line)); + CONST char * file, int line)); /* 21 */ EXTERN int Tcl_DbIsShared _ANSI_ARGS_((Tcl_Obj * objPtr, - char * file, int line)); + CONST char * file, int line)); /* 22 */ EXTERN Tcl_Obj * Tcl_DbNewBooleanObj _ANSI_ARGS_((int boolValue, - char * file, int line)); + CONST char * file, int line)); /* 23 */ EXTERN Tcl_Obj * Tcl_DbNewByteArrayObj _ANSI_ARGS_(( - unsigned char * bytes, int length, - char * file, int line)); + CONST unsigned char * bytes, int length, + CONST char * file, int line)); /* 24 */ EXTERN Tcl_Obj * Tcl_DbNewDoubleObj _ANSI_ARGS_((double doubleValue, - char * file, int line)); + CONST char * file, int line)); /* 25 */ EXTERN Tcl_Obj * Tcl_DbNewListObj _ANSI_ARGS_((int objc, - Tcl_Obj *CONST objv[], char * file, int line)); + Tcl_Obj *CONST * objv, CONST char * file, + int line)); /* 26 */ EXTERN Tcl_Obj * Tcl_DbNewLongObj _ANSI_ARGS_((long longValue, - char * file, int line)); + CONST char * file, int line)); /* 27 */ -EXTERN Tcl_Obj * Tcl_DbNewObj _ANSI_ARGS_((char * file, int line)); +EXTERN Tcl_Obj * Tcl_DbNewObj _ANSI_ARGS_((CONST char * file, + int line)); /* 28 */ EXTERN Tcl_Obj * Tcl_DbNewStringObj _ANSI_ARGS_((CONST char * bytes, - int length, char * file, int line)); + int length, CONST char * file, int line)); /* 29 */ EXTERN Tcl_Obj * Tcl_DuplicateObj _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 30 */ EXTERN void TclFreeObj _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 31 */ EXTERN int Tcl_GetBoolean _ANSI_ARGS_((Tcl_Interp * interp, - char * str, int * boolPtr)); + CONST char * str, int * boolPtr)); /* 32 */ EXTERN int Tcl_GetBooleanFromObj _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Obj * objPtr, @@ -127,18 +131,18 @@ EXTERN unsigned char * Tcl_GetByteArrayFromObj _ANSI_ARGS_(( Tcl_Obj * objPtr, int * lengthPtr)); /* 34 */ EXTERN int Tcl_GetDouble _ANSI_ARGS_((Tcl_Interp * interp, - char * str, double * doublePtr)); + CONST char * str, double * doublePtr)); /* 35 */ EXTERN int Tcl_GetDoubleFromObj _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Obj * objPtr, double * doublePtr)); /* 36 */ EXTERN int Tcl_GetIndexFromObj _ANSI_ARGS_((Tcl_Interp * interp, - Tcl_Obj * objPtr, char ** tablePtr, - char * msg, int flags, int * indexPtr)); + Tcl_Obj * objPtr, CONST84 char ** tablePtr, + CONST char * msg, int flags, int * indexPtr)); /* 37 */ EXTERN int Tcl_GetInt _ANSI_ARGS_((Tcl_Interp * interp, - char * str, int * intPtr)); + CONST char * str, int * intPtr)); /* 38 */ EXTERN int Tcl_GetIntFromObj _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * intPtr)); @@ -146,7 +150,7 @@ EXTERN int Tcl_GetIntFromObj _ANSI_ARGS_((Tcl_Interp * interp, EXTERN int Tcl_GetLongFromObj _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, long * longPtr)); /* 40 */ -EXTERN Tcl_ObjType * Tcl_GetObjType _ANSI_ARGS_((char * typeName)); +EXTERN Tcl_ObjType * Tcl_GetObjType _ANSI_ARGS_((CONST char * typeName)); /* 41 */ EXTERN char * Tcl_GetStringFromObj _ANSI_ARGS_((Tcl_Obj * objPtr, int * lengthPtr)); @@ -171,7 +175,7 @@ EXTERN int Tcl_ListObjIndex _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj ** objPtrPtr)); /* 47 */ EXTERN int Tcl_ListObjLength _ANSI_ARGS_((Tcl_Interp * interp, - Tcl_Obj * listPtr, int * intPtr)); + Tcl_Obj * listPtr, int * lengthPtr)); /* 48 */ EXTERN int Tcl_ListObjReplace _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, int first, int count, @@ -180,7 +184,7 @@ EXTERN int Tcl_ListObjReplace _ANSI_ARGS_((Tcl_Interp * interp, EXTERN Tcl_Obj * Tcl_NewBooleanObj _ANSI_ARGS_((int boolValue)); /* 50 */ EXTERN Tcl_Obj * Tcl_NewByteArrayObj _ANSI_ARGS_(( - unsigned char * bytes, int length)); + CONST unsigned char* bytes, int length)); /* 51 */ EXTERN Tcl_Obj * Tcl_NewDoubleObj _ANSI_ARGS_((double doubleValue)); /* 52 */ @@ -203,7 +207,7 @@ EXTERN unsigned char * Tcl_SetByteArrayLength _ANSI_ARGS_((Tcl_Obj * objPtr, int length)); /* 59 */ EXTERN void Tcl_SetByteArrayObj _ANSI_ARGS_((Tcl_Obj * objPtr, - unsigned char * bytes, int length)); + CONST unsigned char * bytes, int length)); /* 60 */ EXTERN void Tcl_SetDoubleObj _ANSI_ARGS_((Tcl_Obj * objPtr, double doubleValue)); @@ -220,8 +224,8 @@ EXTERN void Tcl_SetLongObj _ANSI_ARGS_((Tcl_Obj * objPtr, EXTERN void Tcl_SetObjLength _ANSI_ARGS_((Tcl_Obj * objPtr, int length)); /* 65 */ -EXTERN void Tcl_SetStringObj _ANSI_ARGS_((Tcl_Obj * objPtr, - char * bytes, int length)); +EXTERN void Tcl_SetStringObj _ANSI_ARGS_((Tcl_Obj* objPtr, + CONST char* bytes, int length)); /* 66 */ EXTERN void Tcl_AddErrorInfo _ANSI_ARGS_((Tcl_Interp * interp, CONST char * message)); @@ -254,8 +258,8 @@ EXTERN char Tcl_Backslash _ANSI_ARGS_((CONST char * src, int * readPtr)); /* 78 */ EXTERN int Tcl_BadChannelOption _ANSI_ARGS_(( - Tcl_Interp * interp, char * optionName, - char * optionList)); + Tcl_Interp * interp, CONST char * optionName, + CONST char * optionList)); /* 79 */ EXTERN void Tcl_CallWhenDeleted _ANSI_ARGS_((Tcl_Interp * interp, Tcl_InterpDeleteProc * proc, @@ -268,9 +272,10 @@ EXTERN void Tcl_CancelIdleCall _ANSI_ARGS_(( EXTERN int Tcl_Close _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 82 */ -EXTERN int Tcl_CommandComplete _ANSI_ARGS_((char * cmd)); +EXTERN int Tcl_CommandComplete _ANSI_ARGS_((CONST char * cmd)); /* 83 */ -EXTERN char * Tcl_Concat _ANSI_ARGS_((int argc, char ** argv)); +EXTERN char * Tcl_Concat _ANSI_ARGS_((int argc, + CONST84 char * CONST * argv)); /* 84 */ EXTERN int Tcl_ConvertElement _ANSI_ARGS_((CONST char * src, char * dst, int flags)); @@ -280,16 +285,18 @@ EXTERN int Tcl_ConvertCountedElement _ANSI_ARGS_(( int flags)); /* 86 */ EXTERN int Tcl_CreateAlias _ANSI_ARGS_((Tcl_Interp * slave, - char * slaveCmd, Tcl_Interp * target, - char * targetCmd, int argc, char ** argv)); + CONST char * slaveCmd, Tcl_Interp * target, + CONST char * targetCmd, int argc, + CONST84 char * CONST * argv)); /* 87 */ EXTERN int Tcl_CreateAliasObj _ANSI_ARGS_((Tcl_Interp * slave, - char * slaveCmd, Tcl_Interp * target, - char * targetCmd, int objc, + CONST char * slaveCmd, Tcl_Interp * target, + CONST char * targetCmd, int objc, Tcl_Obj *CONST objv[])); /* 88 */ EXTERN Tcl_Channel Tcl_CreateChannel _ANSI_ARGS_(( - Tcl_ChannelType * typePtr, char * chanName, + Tcl_ChannelType * typePtr, + CONST char * chanName, ClientData instanceData, int mask)); /* 89 */ EXTERN void Tcl_CreateChannelHandler _ANSI_ARGS_(( @@ -301,7 +308,7 @@ EXTERN void Tcl_CreateCloseHandler _ANSI_ARGS_((Tcl_Channel chan, Tcl_CloseProc * proc, ClientData clientData)); /* 91 */ EXTERN Tcl_Command Tcl_CreateCommand _ANSI_ARGS_((Tcl_Interp * interp, - char * cmdName, Tcl_CmdProc * proc, + CONST char * cmdName, Tcl_CmdProc * proc, ClientData clientData, Tcl_CmdDeleteProc * deleteProc)); /* 92 */ @@ -316,17 +323,17 @@ EXTERN void Tcl_CreateExitHandler _ANSI_ARGS_(( EXTERN Tcl_Interp * Tcl_CreateInterp _ANSI_ARGS_((void)); /* 95 */ EXTERN void Tcl_CreateMathFunc _ANSI_ARGS_((Tcl_Interp * interp, - char * name, int numArgs, + CONST char * name, int numArgs, Tcl_ValueType * argTypes, Tcl_MathProc * proc, ClientData clientData)); /* 96 */ EXTERN Tcl_Command Tcl_CreateObjCommand _ANSI_ARGS_(( - Tcl_Interp * interp, char * cmdName, + Tcl_Interp * interp, CONST char * cmdName, Tcl_ObjCmdProc * proc, ClientData clientData, Tcl_CmdDeleteProc * deleteProc)); /* 97 */ EXTERN Tcl_Interp * Tcl_CreateSlave _ANSI_ARGS_((Tcl_Interp * interp, - char * slaveName, int isSafe)); + CONST char * slaveName, int isSafe)); /* 98 */ EXTERN Tcl_TimerToken Tcl_CreateTimerHandler _ANSI_ARGS_((int milliseconds, Tcl_TimerProc * proc, ClientData clientData)); @@ -336,7 +343,7 @@ EXTERN Tcl_Trace Tcl_CreateTrace _ANSI_ARGS_((Tcl_Interp * interp, ClientData clientData)); /* 100 */ EXTERN void Tcl_DeleteAssocData _ANSI_ARGS_((Tcl_Interp * interp, - char * name)); + CONST char * name)); /* 101 */ EXTERN void Tcl_DeleteChannelHandler _ANSI_ARGS_(( Tcl_Channel chan, Tcl_ChannelProc * proc, @@ -346,7 +353,7 @@ EXTERN void Tcl_DeleteCloseHandler _ANSI_ARGS_((Tcl_Channel chan, Tcl_CloseProc * proc, ClientData clientData)); /* 103 */ EXTERN int Tcl_DeleteCommand _ANSI_ARGS_((Tcl_Interp * interp, - char * cmdName)); + CONST char * cmdName)); /* 104 */ EXTERN int Tcl_DeleteCommandFromToken _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Command command)); @@ -424,15 +431,15 @@ EXTERN void Tcl_DStringStartSublist _ANSI_ARGS_(( /* 126 */ EXTERN int Tcl_Eof _ANSI_ARGS_((Tcl_Channel chan)); /* 127 */ -EXTERN char * Tcl_ErrnoId _ANSI_ARGS_((void)); +EXTERN CONST84_RETURN char * Tcl_ErrnoId _ANSI_ARGS_((void)); /* 128 */ -EXTERN char * Tcl_ErrnoMsg _ANSI_ARGS_((int err)); +EXTERN CONST84_RETURN char * Tcl_ErrnoMsg _ANSI_ARGS_((int err)); /* 129 */ EXTERN int Tcl_Eval _ANSI_ARGS_((Tcl_Interp * interp, - char * string)); + CONST char * string)); /* 130 */ EXTERN int Tcl_EvalFile _ANSI_ARGS_((Tcl_Interp * interp, - char * fileName)); + CONST char * fileName)); /* 131 */ EXTERN int Tcl_EvalObj _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); @@ -444,22 +451,23 @@ EXTERN void Tcl_EventuallyFree _ANSI_ARGS_(( EXTERN void Tcl_Exit _ANSI_ARGS_((int status)); /* 134 */ EXTERN int Tcl_ExposeCommand _ANSI_ARGS_((Tcl_Interp * interp, - char * hiddenCmdToken, char * cmdName)); + CONST char * hiddenCmdToken, + CONST char * cmdName)); /* 135 */ EXTERN int Tcl_ExprBoolean _ANSI_ARGS_((Tcl_Interp * interp, - char * str, int * ptr)); + CONST char * str, int * ptr)); /* 136 */ EXTERN int Tcl_ExprBooleanObj _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * ptr)); /* 137 */ EXTERN int Tcl_ExprDouble _ANSI_ARGS_((Tcl_Interp * interp, - char * str, double * ptr)); + CONST char * str, double * ptr)); /* 138 */ EXTERN int Tcl_ExprDoubleObj _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, double * ptr)); /* 139 */ EXTERN int Tcl_ExprLong _ANSI_ARGS_((Tcl_Interp * interp, - char * str, long * ptr)); + CONST char * str, long * ptr)); /* 140 */ EXTERN int Tcl_ExprLongObj _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, long * ptr)); @@ -468,7 +476,7 @@ EXTERN int Tcl_ExprObj _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_Obj ** resultPtrPtr)); /* 142 */ EXTERN int Tcl_ExprString _ANSI_ARGS_((Tcl_Interp * interp, - char * string)); + CONST char * string)); /* 143 */ EXTERN void Tcl_Finalize _ANSI_ARGS_((void)); /* 144 */ @@ -483,22 +491,23 @@ EXTERN int Tcl_Flush _ANSI_ARGS_((Tcl_Channel chan)); EXTERN void Tcl_FreeResult _ANSI_ARGS_((Tcl_Interp * interp)); /* 148 */ EXTERN int Tcl_GetAlias _ANSI_ARGS_((Tcl_Interp * interp, - char * slaveCmd, + CONST char * slaveCmd, Tcl_Interp ** targetInterpPtr, - char ** targetCmdPtr, int * argcPtr, - char *** argvPtr)); + CONST84 char ** targetCmdPtr, int * argcPtr, + CONST84 char *** argvPtr)); /* 149 */ EXTERN int Tcl_GetAliasObj _ANSI_ARGS_((Tcl_Interp * interp, - char * slaveCmd, + CONST char * slaveCmd, Tcl_Interp ** targetInterpPtr, - char ** targetCmdPtr, int * objcPtr, + CONST84 char ** targetCmdPtr, int * objcPtr, Tcl_Obj *** objv)); /* 150 */ EXTERN ClientData Tcl_GetAssocData _ANSI_ARGS_((Tcl_Interp * interp, - char * name, Tcl_InterpDeleteProc ** procPtr)); + CONST char * name, + Tcl_InterpDeleteProc ** procPtr)); /* 151 */ EXTERN Tcl_Channel Tcl_GetChannel _ANSI_ARGS_((Tcl_Interp * interp, - char * chanName, int * modePtr)); + CONST char * chanName, int * modePtr)); /* 152 */ EXTERN int Tcl_GetChannelBufferSize _ANSI_ARGS_(( Tcl_Channel chan)); @@ -511,23 +520,24 @@ EXTERN ClientData Tcl_GetChannelInstanceData _ANSI_ARGS_(( /* 155 */ EXTERN int Tcl_GetChannelMode _ANSI_ARGS_((Tcl_Channel chan)); /* 156 */ -EXTERN char * Tcl_GetChannelName _ANSI_ARGS_((Tcl_Channel chan)); +EXTERN CONST84_RETURN char * Tcl_GetChannelName _ANSI_ARGS_(( + Tcl_Channel chan)); /* 157 */ EXTERN int Tcl_GetChannelOption _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Channel chan, - char * optionName, Tcl_DString * dsPtr)); + CONST char * optionName, Tcl_DString * dsPtr)); /* 158 */ EXTERN Tcl_ChannelType * Tcl_GetChannelType _ANSI_ARGS_((Tcl_Channel chan)); /* 159 */ EXTERN int Tcl_GetCommandInfo _ANSI_ARGS_((Tcl_Interp * interp, - char * cmdName, Tcl_CmdInfo * infoPtr)); + CONST char * cmdName, Tcl_CmdInfo * infoPtr)); /* 160 */ -EXTERN char * Tcl_GetCommandName _ANSI_ARGS_((Tcl_Interp * interp, - Tcl_Command command)); +EXTERN CONST84_RETURN char * Tcl_GetCommandName _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Command command)); /* 161 */ EXTERN int Tcl_GetErrno _ANSI_ARGS_((void)); /* 162 */ -EXTERN char * Tcl_GetHostName _ANSI_ARGS_((void)); +EXTERN CONST84_RETURN char * Tcl_GetHostName _ANSI_ARGS_((void)); /* 163 */ EXTERN int Tcl_GetInterpPath _ANSI_ARGS_(( Tcl_Interp * askInterp, @@ -541,11 +551,11 @@ EXTERN Tcl_Obj * Tcl_GetObjResult _ANSI_ARGS_((Tcl_Interp * interp)); #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ /* 167 */ EXTERN int Tcl_GetOpenFile _ANSI_ARGS_((Tcl_Interp * interp, - char * str, int forWriting, int checkUsage, - ClientData * filePtr)); + CONST char * str, int forWriting, + int checkUsage, ClientData * filePtr)); #endif /* UNIX */ /* 168 */ -EXTERN Tcl_PathType Tcl_GetPathType _ANSI_ARGS_((char * path)); +EXTERN Tcl_PathType Tcl_GetPathType _ANSI_ARGS_((CONST char * path)); /* 169 */ EXTERN int Tcl_Gets _ANSI_ARGS_((Tcl_Channel chan, Tcl_DString * dsPtr)); @@ -556,26 +566,29 @@ EXTERN int Tcl_GetsObj _ANSI_ARGS_((Tcl_Channel chan, EXTERN int Tcl_GetServiceMode _ANSI_ARGS_((void)); /* 172 */ EXTERN Tcl_Interp * Tcl_GetSlave _ANSI_ARGS_((Tcl_Interp * interp, - char * slaveName)); + CONST char * slaveName)); /* 173 */ EXTERN Tcl_Channel Tcl_GetStdChannel _ANSI_ARGS_((int type)); /* 174 */ -EXTERN char * Tcl_GetStringResult _ANSI_ARGS_((Tcl_Interp * interp)); +EXTERN CONST84_RETURN char * Tcl_GetStringResult _ANSI_ARGS_(( + Tcl_Interp * interp)); /* 175 */ -EXTERN char * Tcl_GetVar _ANSI_ARGS_((Tcl_Interp * interp, - char * varName, int flags)); +EXTERN CONST84_RETURN char * Tcl_GetVar _ANSI_ARGS_((Tcl_Interp * interp, + CONST char * varName, int flags)); /* 176 */ -EXTERN char * Tcl_GetVar2 _ANSI_ARGS_((Tcl_Interp * interp, - char * part1, char * part2, int flags)); +EXTERN CONST84_RETURN char * Tcl_GetVar2 _ANSI_ARGS_((Tcl_Interp * interp, + CONST char * part1, CONST char * part2, + int flags)); /* 177 */ EXTERN int Tcl_GlobalEval _ANSI_ARGS_((Tcl_Interp * interp, - char * command)); + CONST char * command)); /* 178 */ EXTERN int Tcl_GlobalEvalObj _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 179 */ EXTERN int Tcl_HideCommand _ANSI_ARGS_((Tcl_Interp * interp, - char * cmdName, char * hiddenCmdToken)); + CONST char * cmdName, + CONST char * hiddenCmdToken)); /* 180 */ EXTERN int Tcl_Init _ANSI_ARGS_((Tcl_Interp * interp)); /* 181 */ @@ -590,11 +603,12 @@ EXTERN int Tcl_InterpDeleted _ANSI_ARGS_((Tcl_Interp * interp)); /* 185 */ EXTERN int Tcl_IsSafe _ANSI_ARGS_((Tcl_Interp * interp)); /* 186 */ -EXTERN char * Tcl_JoinPath _ANSI_ARGS_((int argc, char ** argv, +EXTERN char * Tcl_JoinPath _ANSI_ARGS_((int argc, + CONST84 char * CONST * argv, Tcl_DString * resultPtr)); /* 187 */ EXTERN int Tcl_LinkVar _ANSI_ARGS_((Tcl_Interp * interp, - char * varName, char * addr, int type)); + CONST char * varName, char * addr, int type)); /* Slot 188 is reserved */ /* 189 */ EXTERN Tcl_Channel Tcl_MakeFileChannel _ANSI_ARGS_((ClientData handle, @@ -605,7 +619,8 @@ EXTERN int Tcl_MakeSafe _ANSI_ARGS_((Tcl_Interp * interp)); EXTERN Tcl_Channel Tcl_MakeTcpClientChannel _ANSI_ARGS_(( ClientData tcpSocket)); /* 192 */ -EXTERN char * Tcl_Merge _ANSI_ARGS_((int argc, char ** argv)); +EXTERN char * Tcl_Merge _ANSI_ARGS_((int argc, + CONST84 char * CONST * argv)); /* 193 */ EXTERN Tcl_HashEntry * Tcl_NextHashEntry _ANSI_ARGS_(( Tcl_HashSearch * searchPtr)); @@ -623,26 +638,26 @@ EXTERN Tcl_Obj * Tcl_ObjSetVar2 _ANSI_ARGS_((Tcl_Interp * interp, #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ /* 197 */ EXTERN Tcl_Channel Tcl_OpenCommandChannel _ANSI_ARGS_(( - Tcl_Interp * interp, int argc, char ** argv, - int flags)); + Tcl_Interp * interp, int argc, + CONST84 char ** argv, int flags)); #endif /* UNIX */ #ifdef __WIN32__ /* 197 */ EXTERN Tcl_Channel Tcl_OpenCommandChannel _ANSI_ARGS_(( - Tcl_Interp * interp, int argc, char ** argv, - int flags)); + Tcl_Interp * interp, int argc, + CONST84 char ** argv, int flags)); #endif /* __WIN32__ */ /* 198 */ EXTERN Tcl_Channel Tcl_OpenFileChannel _ANSI_ARGS_((Tcl_Interp * interp, - char * fileName, char * modeString, - int permissions)); + CONST char * fileName, + CONST char * modeString, int permissions)); /* 199 */ EXTERN Tcl_Channel Tcl_OpenTcpClient _ANSI_ARGS_((Tcl_Interp * interp, - int port, char * address, char * myaddr, - int myport, int async)); + int port, CONST char * address, + CONST char * myaddr, int myport, int async)); /* 200 */ EXTERN Tcl_Channel Tcl_OpenTcpServer _ANSI_ARGS_((Tcl_Interp * interp, - int port, char * host, + int port, CONST char * host, Tcl_TcpAcceptProc * acceptProc, ClientData callbackData)); /* 201 */ @@ -653,7 +668,7 @@ EXTERN void Tcl_PrintDouble _ANSI_ARGS_((Tcl_Interp * interp, /* 203 */ EXTERN int Tcl_PutEnv _ANSI_ARGS_((CONST char * string)); /* 204 */ -EXTERN char * Tcl_PosixError _ANSI_ARGS_((Tcl_Interp * interp)); +EXTERN CONST84_RETURN char * Tcl_PosixError _ANSI_ARGS_((Tcl_Interp * interp)); /* 205 */ EXTERN void Tcl_QueueEvent _ANSI_ARGS_((Tcl_Event * evPtr, Tcl_QueuePosition position)); @@ -670,7 +685,7 @@ EXTERN void Tcl_ReapDetachedProcs _ANSI_ARGS_((void)); #endif /* __WIN32__ */ /* 208 */ EXTERN int Tcl_RecordAndEval _ANSI_ARGS_((Tcl_Interp * interp, - char * cmd, int flags)); + CONST char * cmd, int flags)); /* 209 */ EXTERN int Tcl_RecordAndEvalObj _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Obj * cmdPtr, @@ -683,17 +698,18 @@ EXTERN void Tcl_RegisterObjType _ANSI_ARGS_(( Tcl_ObjType * typePtr)); /* 212 */ EXTERN Tcl_RegExp Tcl_RegExpCompile _ANSI_ARGS_((Tcl_Interp * interp, - char * string)); + CONST char * string)); /* 213 */ EXTERN int Tcl_RegExpExec _ANSI_ARGS_((Tcl_Interp * interp, Tcl_RegExp regexp, CONST char * str, CONST char * start)); /* 214 */ EXTERN int Tcl_RegExpMatch _ANSI_ARGS_((Tcl_Interp * interp, - char * str, char * pattern)); + CONST char * str, CONST char * pattern)); /* 215 */ EXTERN void Tcl_RegExpRange _ANSI_ARGS_((Tcl_RegExp regexp, - int index, char ** startPtr, char ** endPtr)); + int index, CONST84 char ** startPtr, + CONST84 char ** endPtr)); /* 216 */ EXTERN void Tcl_Release _ANSI_ARGS_((ClientData clientData)); /* 217 */ @@ -705,15 +721,16 @@ EXTERN int Tcl_ScanElement _ANSI_ARGS_((CONST char * str, EXTERN int Tcl_ScanCountedElement _ANSI_ARGS_((CONST char * str, int length, int * flagPtr)); /* 220 */ -EXTERN int Tcl_Seek _ANSI_ARGS_((Tcl_Channel chan, int offset, - int mode)); +EXTERN int Tcl_SeekOld _ANSI_ARGS_((Tcl_Channel chan, + int offset, int mode)); /* 221 */ EXTERN int Tcl_ServiceAll _ANSI_ARGS_((void)); /* 222 */ EXTERN int Tcl_ServiceEvent _ANSI_ARGS_((int flags)); /* 223 */ EXTERN void Tcl_SetAssocData _ANSI_ARGS_((Tcl_Interp * interp, - char * name, Tcl_InterpDeleteProc * proc, + CONST char * name, + Tcl_InterpDeleteProc * proc, ClientData clientData)); /* 224 */ EXTERN void Tcl_SetChannelBufferSize _ANSI_ARGS_(( @@ -721,10 +738,12 @@ EXTERN void Tcl_SetChannelBufferSize _ANSI_ARGS_(( /* 225 */ EXTERN int Tcl_SetChannelOption _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Channel chan, - char * optionName, char * newValue)); + CONST char * optionName, + CONST char * newValue)); /* 226 */ EXTERN int Tcl_SetCommandInfo _ANSI_ARGS_((Tcl_Interp * interp, - char * cmdName, Tcl_CmdInfo * infoPtr)); + CONST char * cmdName, + CONST Tcl_CmdInfo * infoPtr)); /* 227 */ EXTERN void Tcl_SetErrno _ANSI_ARGS_((int err)); /* 228 */ @@ -752,108 +771,112 @@ EXTERN void Tcl_SetObjResult _ANSI_ARGS_((Tcl_Interp * interp, EXTERN void Tcl_SetStdChannel _ANSI_ARGS_((Tcl_Channel channel, int type)); /* 237 */ -EXTERN char * Tcl_SetVar _ANSI_ARGS_((Tcl_Interp * interp, - char * varName, char * newValue, int flags)); -/* 238 */ -EXTERN char * Tcl_SetVar2 _ANSI_ARGS_((Tcl_Interp * interp, - char * part1, char * part2, char * newValue, +EXTERN CONST84_RETURN char * Tcl_SetVar _ANSI_ARGS_((Tcl_Interp * interp, + CONST char * varName, CONST char * newValue, int flags)); +/* 238 */ +EXTERN CONST84_RETURN char * Tcl_SetVar2 _ANSI_ARGS_((Tcl_Interp * interp, + CONST char * part1, CONST char * part2, + CONST char * newValue, int flags)); /* 239 */ -EXTERN char * Tcl_SignalId _ANSI_ARGS_((int sig)); +EXTERN CONST84_RETURN char * Tcl_SignalId _ANSI_ARGS_((int sig)); /* 240 */ -EXTERN char * Tcl_SignalMsg _ANSI_ARGS_((int sig)); +EXTERN CONST84_RETURN char * Tcl_SignalMsg _ANSI_ARGS_((int sig)); /* 241 */ EXTERN void Tcl_SourceRCFile _ANSI_ARGS_((Tcl_Interp * interp)); /* 242 */ EXTERN int Tcl_SplitList _ANSI_ARGS_((Tcl_Interp * interp, CONST char * listStr, int * argcPtr, - char *** argvPtr)); + CONST84 char *** argvPtr)); /* 243 */ EXTERN void Tcl_SplitPath _ANSI_ARGS_((CONST char * path, - int * argcPtr, char *** argvPtr)); + int * argcPtr, CONST84 char *** argvPtr)); /* 244 */ EXTERN void Tcl_StaticPackage _ANSI_ARGS_((Tcl_Interp * interp, - char * pkgName, + CONST char * pkgName, Tcl_PackageInitProc * initProc, Tcl_PackageInitProc * safeInitProc)); /* 245 */ EXTERN int Tcl_StringMatch _ANSI_ARGS_((CONST char * str, CONST char * pattern)); /* 246 */ -EXTERN int Tcl_Tell _ANSI_ARGS_((Tcl_Channel chan)); +EXTERN int Tcl_TellOld _ANSI_ARGS_((Tcl_Channel chan)); /* 247 */ EXTERN int Tcl_TraceVar _ANSI_ARGS_((Tcl_Interp * interp, - char * varName, int flags, + CONST char * varName, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 248 */ EXTERN int Tcl_TraceVar2 _ANSI_ARGS_((Tcl_Interp * interp, - char * part1, char * part2, int flags, - Tcl_VarTraceProc * proc, + CONST char * part1, CONST char * part2, + int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 249 */ EXTERN char * Tcl_TranslateFileName _ANSI_ARGS_(( - Tcl_Interp * interp, char * name, + Tcl_Interp * interp, CONST char * name, Tcl_DString * bufferPtr)); /* 250 */ -EXTERN int Tcl_Ungets _ANSI_ARGS_((Tcl_Channel chan, char * str, - int len, int atHead)); +EXTERN int Tcl_Ungets _ANSI_ARGS_((Tcl_Channel chan, + CONST char * str, int len, int atHead)); /* 251 */ EXTERN void Tcl_UnlinkVar _ANSI_ARGS_((Tcl_Interp * interp, - char * varName)); + CONST char * varName)); /* 252 */ EXTERN int Tcl_UnregisterChannel _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Channel chan)); /* 253 */ EXTERN int Tcl_UnsetVar _ANSI_ARGS_((Tcl_Interp * interp, - char * varName, int flags)); + CONST char * varName, int flags)); /* 254 */ EXTERN int Tcl_UnsetVar2 _ANSI_ARGS_((Tcl_Interp * interp, - char * part1, char * part2, int flags)); + CONST char * part1, CONST char * part2, + int flags)); /* 255 */ EXTERN void Tcl_UntraceVar _ANSI_ARGS_((Tcl_Interp * interp, - char * varName, int flags, + CONST char * varName, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 256 */ EXTERN void Tcl_UntraceVar2 _ANSI_ARGS_((Tcl_Interp * interp, - char * part1, char * part2, int flags, - Tcl_VarTraceProc * proc, + CONST char * part1, CONST char * part2, + int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 257 */ EXTERN void Tcl_UpdateLinkedVar _ANSI_ARGS_((Tcl_Interp * interp, - char * varName)); + CONST char * varName)); /* 258 */ EXTERN int Tcl_UpVar _ANSI_ARGS_((Tcl_Interp * interp, - char * frameName, char * varName, - char * localName, int flags)); + CONST char * frameName, CONST char * varName, + CONST char * localName, int flags)); /* 259 */ EXTERN int Tcl_UpVar2 _ANSI_ARGS_((Tcl_Interp * interp, - char * frameName, char * part1, char * part2, - char * localName, int flags)); + CONST char * frameName, CONST char * part1, + CONST char * part2, CONST char * localName, + int flags)); /* 260 */ EXTERN int Tcl_VarEval _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); /* 261 */ EXTERN ClientData Tcl_VarTraceInfo _ANSI_ARGS_((Tcl_Interp * interp, - char * varName, int flags, + CONST char * varName, int flags, Tcl_VarTraceProc * procPtr, ClientData prevClientData)); /* 262 */ EXTERN ClientData Tcl_VarTraceInfo2 _ANSI_ARGS_((Tcl_Interp * interp, - char * part1, char * part2, int flags, - Tcl_VarTraceProc * procPtr, + CONST char * part1, CONST char * part2, + int flags, Tcl_VarTraceProc * procPtr, ClientData prevClientData)); /* 263 */ -EXTERN int Tcl_Write _ANSI_ARGS_((Tcl_Channel chan, char * s, - int slen)); +EXTERN int Tcl_Write _ANSI_ARGS_((Tcl_Channel chan, + CONST char * s, int slen)); /* 264 */ EXTERN void Tcl_WrongNumArgs _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], - char * message)); + CONST char * message)); /* 265 */ -EXTERN int Tcl_DumpActiveMemory _ANSI_ARGS_((char * fileName)); +EXTERN int Tcl_DumpActiveMemory _ANSI_ARGS_(( + CONST char * fileName)); /* 266 */ -EXTERN void Tcl_ValidateAllMemory _ANSI_ARGS_((char * file, +EXTERN void Tcl_ValidateAllMemory _ANSI_ARGS_((CONST char * file, int line)); /* 267 */ EXTERN void Tcl_AppendResultVA _ANSI_ARGS_((Tcl_Interp * interp, @@ -862,23 +885,27 @@ EXTERN void Tcl_AppendResultVA _ANSI_ARGS_((Tcl_Interp * interp, EXTERN void Tcl_AppendStringsToObjVA _ANSI_ARGS_(( Tcl_Obj * objPtr, va_list argList)); /* 269 */ -EXTERN char * Tcl_HashStats _ANSI_ARGS_((Tcl_HashTable * tablePtr)); +EXTERN CONST84_RETURN char * Tcl_HashStats _ANSI_ARGS_(( + Tcl_HashTable * tablePtr)); /* 270 */ -EXTERN char * Tcl_ParseVar _ANSI_ARGS_((Tcl_Interp * interp, - char * str, char ** termPtr)); +EXTERN CONST84_RETURN char * Tcl_ParseVar _ANSI_ARGS_((Tcl_Interp * interp, + CONST char * str, CONST84 char ** termPtr)); /* 271 */ -EXTERN char * Tcl_PkgPresent _ANSI_ARGS_((Tcl_Interp * interp, - char * name, char * version, int exact)); +EXTERN CONST84_RETURN char * Tcl_PkgPresent _ANSI_ARGS_((Tcl_Interp * interp, + CONST char * name, CONST char * version, + int exact)); /* 272 */ -EXTERN char * Tcl_PkgPresentEx _ANSI_ARGS_((Tcl_Interp * interp, - char * name, char * version, int exact, +EXTERN CONST84_RETURN char * Tcl_PkgPresentEx _ANSI_ARGS_(( + Tcl_Interp * interp, CONST char * name, + CONST char * version, int exact, ClientData * clientDataPtr)); /* 273 */ EXTERN int Tcl_PkgProvide _ANSI_ARGS_((Tcl_Interp * interp, - char * name, char * version)); + CONST char * name, CONST char * version)); /* 274 */ -EXTERN char * Tcl_PkgRequire _ANSI_ARGS_((Tcl_Interp * interp, - char * name, char * version, int exact)); +EXTERN CONST84_RETURN char * Tcl_PkgRequire _ANSI_ARGS_((Tcl_Interp * interp, + CONST char * name, CONST char * version, + int exact)); /* 275 */ EXTERN void Tcl_SetErrorCodeVA _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); @@ -888,16 +915,9 @@ EXTERN int Tcl_VarEvalVA _ANSI_ARGS_((Tcl_Interp * interp, /* 277 */ EXTERN Tcl_Pid Tcl_WaitPid _ANSI_ARGS_((Tcl_Pid pid, int * statPtr, int options)); -#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ -/* 278 */ -EXTERN void Tcl_PanicVA _ANSI_ARGS_((char * format, - va_list argList)); -#endif /* UNIX */ -#ifdef __WIN32__ /* 278 */ -EXTERN void Tcl_PanicVA _ANSI_ARGS_((char * format, +EXTERN void Tcl_PanicVA _ANSI_ARGS_((CONST char * format, va_list argList)); -#endif /* __WIN32__ */ /* 279 */ EXTERN void Tcl_GetVersion _ANSI_ARGS_((int * major, int * minor, int * patchLevel, int * type)); @@ -913,7 +933,8 @@ EXTERN int Tcl_UnstackChannel _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 283 */ EXTERN Tcl_Channel Tcl_GetStackedChannel _ANSI_ARGS_((Tcl_Channel chan)); -/* Slot 284 is reserved */ +/* 284 */ +EXTERN void Tcl_SetMainLoop _ANSI_ARGS_((Tcl_MainLoopProc * proc)); /* Slot 285 is reserved */ /* 286 */ EXTERN void Tcl_AppendObjToObj _ANSI_ARGS_((Tcl_Obj * objPtr, @@ -932,7 +953,7 @@ EXTERN void Tcl_DiscardResult _ANSI_ARGS_(( Tcl_SavedResult * statePtr)); /* 291 */ EXTERN int Tcl_EvalEx _ANSI_ARGS_((Tcl_Interp * interp, - char * script, int numBytes, int flags)); + CONST char * script, int numBytes, int flags)); /* 292 */ EXTERN int Tcl_EvalObjv _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], int flags)); @@ -965,7 +986,7 @@ EXTERN Tcl_ThreadId Tcl_GetCurrentThread _ANSI_ARGS_((void)); EXTERN Tcl_Encoding Tcl_GetEncoding _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name)); /* 302 */ -EXTERN char * Tcl_GetEncodingName _ANSI_ARGS_(( +EXTERN CONST84_RETURN char * Tcl_GetEncodingName _ANSI_ARGS_(( Tcl_Encoding encoding)); /* 303 */ EXTERN void Tcl_GetEncodingNames _ANSI_ARGS_(( @@ -973,14 +994,15 @@ EXTERN void Tcl_GetEncodingNames _ANSI_ARGS_(( /* 304 */ EXTERN int Tcl_GetIndexFromObjStruct _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Obj * objPtr, - char ** tablePtr, int offset, char * msg, - int flags, int * indexPtr)); + CONST VOID * tablePtr, int offset, + CONST char * msg, int flags, int * indexPtr)); /* 305 */ EXTERN VOID * Tcl_GetThreadData _ANSI_ARGS_(( Tcl_ThreadDataKey * keyPtr, int size)); /* 306 */ EXTERN Tcl_Obj * Tcl_GetVar2Ex _ANSI_ARGS_((Tcl_Interp * interp, - char * part1, char * part2, int flags)); + CONST char * part1, CONST char * part2, + int flags)); /* 307 */ EXTERN ClientData Tcl_InitNotifier _ANSI_ARGS_((void)); /* 308 */ @@ -1012,7 +1034,7 @@ EXTERN int Tcl_SetSystemEncoding _ANSI_ARGS_(( Tcl_Interp * interp, CONST char * name)); /* 317 */ EXTERN Tcl_Obj * Tcl_SetVar2Ex _ANSI_ARGS_((Tcl_Interp * interp, - char * part1, char * part2, + CONST char * part1, CONST char * part2, Tcl_Obj * newValuePtr, int flags)); /* 318 */ EXTERN void Tcl_ThreadAlert _ANSI_ARGS_((Tcl_ThreadId threadId)); @@ -1032,7 +1054,7 @@ EXTERN Tcl_UniChar Tcl_UniCharToUpper _ANSI_ARGS_((int ch)); /* 324 */ EXTERN int Tcl_UniCharToUtf _ANSI_ARGS_((int ch, char * buf)); /* 325 */ -EXTERN char * Tcl_UtfAtIndex _ANSI_ARGS_((CONST char * src, +EXTERN CONST84_RETURN char * Tcl_UtfAtIndex _ANSI_ARGS_((CONST char * src, int index)); /* 326 */ EXTERN int Tcl_UtfCharComplete _ANSI_ARGS_((CONST char * src, @@ -1041,15 +1063,15 @@ EXTERN int Tcl_UtfCharComplete _ANSI_ARGS_((CONST char * src, EXTERN int Tcl_UtfBackslash _ANSI_ARGS_((CONST char * src, int * readPtr, char * dst)); /* 328 */ -EXTERN char * Tcl_UtfFindFirst _ANSI_ARGS_((CONST char * src, +EXTERN CONST84_RETURN char * Tcl_UtfFindFirst _ANSI_ARGS_((CONST char * src, int ch)); /* 329 */ -EXTERN char * Tcl_UtfFindLast _ANSI_ARGS_((CONST char * src, +EXTERN CONST84_RETURN char * Tcl_UtfFindLast _ANSI_ARGS_((CONST char * src, int ch)); /* 330 */ -EXTERN char * Tcl_UtfNext _ANSI_ARGS_((CONST char * src)); +EXTERN CONST84_RETURN char * Tcl_UtfNext _ANSI_ARGS_((CONST char * src)); /* 331 */ -EXTERN char * Tcl_UtfPrev _ANSI_ARGS_((CONST char * src, +EXTERN CONST84_RETURN char * Tcl_UtfPrev _ANSI_ARGS_((CONST char * src, CONST char * start)); /* 332 */ EXTERN int Tcl_UtfToExternal _ANSI_ARGS_((Tcl_Interp * interp, @@ -1080,9 +1102,10 @@ EXTERN int Tcl_WriteObj _ANSI_ARGS_((Tcl_Channel chan, /* 340 */ EXTERN char * Tcl_GetString _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 341 */ -EXTERN char * Tcl_GetDefaultEncodingDir _ANSI_ARGS_((void)); +EXTERN CONST84_RETURN char * Tcl_GetDefaultEncodingDir _ANSI_ARGS_((void)); /* 342 */ -EXTERN void Tcl_SetDefaultEncodingDir _ANSI_ARGS_((char * path)); +EXTERN void Tcl_SetDefaultEncodingDir _ANSI_ARGS_(( + CONST char * path)); /* 343 */ EXTERN void Tcl_AlertNotifier _ANSI_ARGS_((ClientData clientData)); /* 344 */ @@ -1102,7 +1125,7 @@ EXTERN int Tcl_UniCharIsUpper _ANSI_ARGS_((int ch)); /* 351 */ EXTERN int Tcl_UniCharIsWordChar _ANSI_ARGS_((int ch)); /* 352 */ -EXTERN int Tcl_UniCharLen _ANSI_ARGS_((Tcl_UniChar * str)); +EXTERN int Tcl_UniCharLen _ANSI_ARGS_((CONST Tcl_UniChar * str)); /* 353 */ EXTERN int Tcl_UniCharNcmp _ANSI_ARGS_((CONST Tcl_UniChar * cs, CONST Tcl_UniChar * ct, unsigned long n)); @@ -1125,28 +1148,29 @@ EXTERN Tcl_Obj * Tcl_EvalTokens _ANSI_ARGS_((Tcl_Interp * interp, EXTERN void Tcl_FreeParse _ANSI_ARGS_((Tcl_Parse * parsePtr)); /* 359 */ EXTERN void Tcl_LogCommandInfo _ANSI_ARGS_((Tcl_Interp * interp, - char * script, char * command, int length)); + CONST char * script, CONST char * command, + int length)); /* 360 */ EXTERN int Tcl_ParseBraces _ANSI_ARGS_((Tcl_Interp * interp, - char * string, int numBytes, + CONST char * string, int numBytes, Tcl_Parse * parsePtr, int append, - char ** termPtr)); + CONST84 char ** termPtr)); /* 361 */ EXTERN int Tcl_ParseCommand _ANSI_ARGS_((Tcl_Interp * interp, - char * string, int numBytes, int nested, - Tcl_Parse * parsePtr)); + CONST char * string, int numBytes, + int nested, Tcl_Parse * parsePtr)); /* 362 */ EXTERN int Tcl_ParseExpr _ANSI_ARGS_((Tcl_Interp * interp, - char * string, int numBytes, + CONST char * string, int numBytes, Tcl_Parse * parsePtr)); /* 363 */ EXTERN int Tcl_ParseQuotedString _ANSI_ARGS_(( - Tcl_Interp * interp, char * string, + Tcl_Interp * interp, CONST char * string, int numBytes, Tcl_Parse * parsePtr, - int append, char ** termPtr)); + int append, CONST84 char ** termPtr)); /* 364 */ EXTERN int Tcl_ParseVarName _ANSI_ARGS_((Tcl_Interp * interp, - char * string, int numBytes, + CONST char * string, int numBytes, Tcl_Parse * parsePtr, int append)); /* 365 */ EXTERN char * Tcl_GetCwd _ANSI_ARGS_((Tcl_Interp * interp, @@ -1183,11 +1207,11 @@ EXTERN int Tcl_RegExpExecObj _ANSI_ARGS_((Tcl_Interp * interp, EXTERN void Tcl_RegExpGetInfo _ANSI_ARGS_((Tcl_RegExp regexp, Tcl_RegExpInfo * infoPtr)); /* 378 */ -EXTERN Tcl_Obj * Tcl_NewUnicodeObj _ANSI_ARGS_((Tcl_UniChar * unicode, - int numChars)); +EXTERN Tcl_Obj * Tcl_NewUnicodeObj _ANSI_ARGS_(( + CONST Tcl_UniChar * unicode, int numChars)); /* 379 */ EXTERN void Tcl_SetUnicodeObj _ANSI_ARGS_((Tcl_Obj * objPtr, - Tcl_UniChar * unicode, int numChars)); + CONST Tcl_UniChar * unicode, int numChars)); /* 380 */ EXTERN int Tcl_GetCharLength _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 381 */ @@ -1200,7 +1224,7 @@ EXTERN Tcl_Obj * Tcl_GetRange _ANSI_ARGS_((Tcl_Obj * objPtr, int first, int last)); /* 384 */ EXTERN void Tcl_AppendUnicodeToObj _ANSI_ARGS_((Tcl_Obj * objPtr, - Tcl_UniChar * unicode, int length)); + CONST Tcl_UniChar * unicode, int length)); /* 385 */ EXTERN int Tcl_RegExpMatchObj _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * stringObj, Tcl_Obj * patternObj)); @@ -1213,7 +1237,7 @@ EXTERN Tcl_Mutex * Tcl_GetAllocMutex _ANSI_ARGS_((void)); EXTERN int Tcl_GetChannelNames _ANSI_ARGS_((Tcl_Interp * interp)); /* 389 */ EXTERN int Tcl_GetChannelNamesEx _ANSI_ARGS_(( - Tcl_Interp * interp, char * pattern)); + Tcl_Interp * interp, CONST char * pattern)); /* 390 */ EXTERN int Tcl_ProcObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, @@ -1233,13 +1257,13 @@ EXTERN int Tcl_ReadRaw _ANSI_ARGS_((Tcl_Channel chan, char * dst, int bytesToRead)); /* 395 */ EXTERN int Tcl_WriteRaw _ANSI_ARGS_((Tcl_Channel chan, - char * src, int srcLen)); + CONST char * src, int srcLen)); /* 396 */ EXTERN Tcl_Channel Tcl_GetTopChannel _ANSI_ARGS_((Tcl_Channel chan)); /* 397 */ EXTERN int Tcl_ChannelBuffered _ANSI_ARGS_((Tcl_Channel chan)); /* 398 */ -EXTERN char * Tcl_ChannelName _ANSI_ARGS_(( +EXTERN CONST84_RETURN char * Tcl_ChannelName _ANSI_ARGS_(( Tcl_ChannelType * chanTypePtr)); /* 399 */ EXTERN Tcl_ChannelTypeVersion Tcl_ChannelVersion _ANSI_ARGS_(( @@ -1280,6 +1304,266 @@ EXTERN Tcl_DriverFlushProc * Tcl_ChannelFlushProc _ANSI_ARGS_(( /* 411 */ EXTERN Tcl_DriverHandlerProc * Tcl_ChannelHandlerProc _ANSI_ARGS_(( Tcl_ChannelType * chanTypePtr)); +/* 412 */ +EXTERN int Tcl_JoinThread _ANSI_ARGS_((Tcl_ThreadId id, + int* result)); +/* 413 */ +EXTERN int Tcl_IsChannelShared _ANSI_ARGS_((Tcl_Channel channel)); +/* 414 */ +EXTERN int Tcl_IsChannelRegistered _ANSI_ARGS_(( + Tcl_Interp* interp, Tcl_Channel channel)); +/* 415 */ +EXTERN void Tcl_CutChannel _ANSI_ARGS_((Tcl_Channel channel)); +/* 416 */ +EXTERN void Tcl_SpliceChannel _ANSI_ARGS_((Tcl_Channel channel)); +/* 417 */ +EXTERN void Tcl_ClearChannelHandlers _ANSI_ARGS_(( + Tcl_Channel channel)); +/* 418 */ +EXTERN int Tcl_IsChannelExisting _ANSI_ARGS_(( + CONST char* channelName)); +/* 419 */ +EXTERN int Tcl_UniCharNcasecmp _ANSI_ARGS_(( + CONST Tcl_UniChar * cs, + CONST Tcl_UniChar * ct, unsigned long n)); +/* 420 */ +EXTERN int Tcl_UniCharCaseMatch _ANSI_ARGS_(( + CONST Tcl_UniChar * ustr, + CONST Tcl_UniChar * pattern, int nocase)); +/* 421 */ +EXTERN Tcl_HashEntry * Tcl_FindHashEntry _ANSI_ARGS_(( + Tcl_HashTable * tablePtr, CONST char * key)); +/* 422 */ +EXTERN Tcl_HashEntry * Tcl_CreateHashEntry _ANSI_ARGS_(( + Tcl_HashTable * tablePtr, CONST char * key, + int * newPtr)); +/* 423 */ +EXTERN void Tcl_InitCustomHashTable _ANSI_ARGS_(( + Tcl_HashTable * tablePtr, int keyType, + Tcl_HashKeyType * typePtr)); +/* 424 */ +EXTERN void Tcl_InitObjHashTable _ANSI_ARGS_(( + Tcl_HashTable * tablePtr)); +/* 425 */ +EXTERN ClientData Tcl_CommandTraceInfo _ANSI_ARGS_(( + Tcl_Interp * interp, CONST char * varName, + int flags, Tcl_CommandTraceProc * procPtr, + ClientData prevClientData)); +/* 426 */ +EXTERN int Tcl_TraceCommand _ANSI_ARGS_((Tcl_Interp * interp, + CONST char * varName, int flags, + Tcl_CommandTraceProc * proc, + ClientData clientData)); +/* 427 */ +EXTERN void Tcl_UntraceCommand _ANSI_ARGS_((Tcl_Interp * interp, + CONST char * varName, int flags, + Tcl_CommandTraceProc * proc, + ClientData clientData)); +/* 428 */ +EXTERN char * Tcl_AttemptAlloc _ANSI_ARGS_((unsigned int size)); +/* 429 */ +EXTERN char * Tcl_AttemptDbCkalloc _ANSI_ARGS_((unsigned int size, + CONST char * file, int line)); +/* 430 */ +EXTERN char * Tcl_AttemptRealloc _ANSI_ARGS_((char * ptr, + unsigned int size)); +/* 431 */ +EXTERN char * Tcl_AttemptDbCkrealloc _ANSI_ARGS_((char * ptr, + unsigned int size, CONST char * file, + int line)); +/* 432 */ +EXTERN int Tcl_AttemptSetObjLength _ANSI_ARGS_(( + Tcl_Obj * objPtr, int length)); +/* 433 */ +EXTERN Tcl_ThreadId Tcl_GetChannelThread _ANSI_ARGS_(( + Tcl_Channel channel)); +/* 434 */ +EXTERN Tcl_UniChar * Tcl_GetUnicodeFromObj _ANSI_ARGS_((Tcl_Obj * objPtr, + int * lengthPtr)); +/* 435 */ +EXTERN int Tcl_GetMathFuncInfo _ANSI_ARGS_((Tcl_Interp * interp, + CONST char * name, int * numArgsPtr, + Tcl_ValueType ** argTypesPtr, + Tcl_MathProc ** procPtr, + ClientData * clientDataPtr)); +/* 436 */ +EXTERN Tcl_Obj * Tcl_ListMathFuncs _ANSI_ARGS_((Tcl_Interp * interp, + CONST char * pattern)); +/* 437 */ +EXTERN Tcl_Obj * Tcl_SubstObj _ANSI_ARGS_((Tcl_Interp * interp, + Tcl_Obj * objPtr, int flags)); +/* 438 */ +EXTERN int Tcl_DetachChannel _ANSI_ARGS_((Tcl_Interp* interp, + Tcl_Channel channel)); +/* 439 */ +EXTERN int Tcl_IsStandardChannel _ANSI_ARGS_(( + Tcl_Channel channel)); +/* 440 */ +EXTERN int Tcl_FSCopyFile _ANSI_ARGS_((Tcl_Obj * srcPathPtr, + Tcl_Obj * destPathPtr)); +/* 441 */ +EXTERN int Tcl_FSCopyDirectory _ANSI_ARGS_(( + Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr, + Tcl_Obj ** errorPtr)); +/* 442 */ +EXTERN int Tcl_FSCreateDirectory _ANSI_ARGS_((Tcl_Obj * pathPtr)); +/* 443 */ +EXTERN int Tcl_FSDeleteFile _ANSI_ARGS_((Tcl_Obj * pathPtr)); +/* 444 */ +EXTERN int Tcl_FSLoadFile _ANSI_ARGS_((Tcl_Interp * interp, + Tcl_Obj * pathPtr, CONST char * sym1, + CONST char * sym2, + Tcl_PackageInitProc ** proc1Ptr, + Tcl_PackageInitProc ** proc2Ptr, + Tcl_LoadHandle * handlePtr, + Tcl_FSUnloadFileProc ** unloadProcPtr)); +/* 445 */ +EXTERN int Tcl_FSMatchInDirectory _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Obj * result, + Tcl_Obj * pathPtr, CONST char * pattern, + Tcl_GlobTypeData * types)); +/* 446 */ +EXTERN Tcl_Obj * Tcl_FSLink _ANSI_ARGS_((Tcl_Obj * pathPtr, + Tcl_Obj * toPtr, int linkAction)); +/* 447 */ +EXTERN int Tcl_FSRemoveDirectory _ANSI_ARGS_((Tcl_Obj * pathPtr, + int recursive, Tcl_Obj ** errorPtr)); +/* 448 */ +EXTERN int Tcl_FSRenameFile _ANSI_ARGS_((Tcl_Obj * srcPathPtr, + Tcl_Obj * destPathPtr)); +/* 449 */ +EXTERN int Tcl_FSLstat _ANSI_ARGS_((Tcl_Obj * pathPtr, + Tcl_StatBuf * buf)); +/* 450 */ +EXTERN int Tcl_FSUtime _ANSI_ARGS_((Tcl_Obj * pathPtr, + struct utimbuf * tval)); +/* 451 */ +EXTERN int Tcl_FSFileAttrsGet _ANSI_ARGS_((Tcl_Interp * interp, + int index, Tcl_Obj * pathPtr, + Tcl_Obj ** objPtrRef)); +/* 452 */ +EXTERN int Tcl_FSFileAttrsSet _ANSI_ARGS_((Tcl_Interp * interp, + int index, Tcl_Obj * pathPtr, + Tcl_Obj * objPtr)); +/* 453 */ +EXTERN CONST char ** Tcl_FSFileAttrStrings _ANSI_ARGS_((Tcl_Obj * pathPtr, + Tcl_Obj ** objPtrRef)); +/* 454 */ +EXTERN int Tcl_FSStat _ANSI_ARGS_((Tcl_Obj * pathPtr, + Tcl_StatBuf * buf)); +/* 455 */ +EXTERN int Tcl_FSAccess _ANSI_ARGS_((Tcl_Obj * pathPtr, + int mode)); +/* 456 */ +EXTERN Tcl_Channel Tcl_FSOpenFileChannel _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Obj * pathPtr, + CONST char * modeString, int permissions)); +/* 457 */ +EXTERN Tcl_Obj* Tcl_FSGetCwd _ANSI_ARGS_((Tcl_Interp * interp)); +/* 458 */ +EXTERN int Tcl_FSChdir _ANSI_ARGS_((Tcl_Obj * pathPtr)); +/* 459 */ +EXTERN int Tcl_FSConvertToPathType _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Obj * pathPtr)); +/* 460 */ +EXTERN Tcl_Obj* Tcl_FSJoinPath _ANSI_ARGS_((Tcl_Obj * listObj, + int elements)); +/* 461 */ +EXTERN Tcl_Obj* Tcl_FSSplitPath _ANSI_ARGS_((Tcl_Obj* pathPtr, + int * lenPtr)); +/* 462 */ +EXTERN int Tcl_FSEqualPaths _ANSI_ARGS_((Tcl_Obj* firstPtr, + Tcl_Obj* secondPtr)); +/* 463 */ +EXTERN Tcl_Obj* Tcl_FSGetNormalizedPath _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Obj* pathObjPtr)); +/* 464 */ +EXTERN Tcl_Obj* Tcl_FSJoinToPath _ANSI_ARGS_((Tcl_Obj * basePtr, + int objc, Tcl_Obj *CONST objv[])); +/* 465 */ +EXTERN ClientData Tcl_FSGetInternalRep _ANSI_ARGS_(( + Tcl_Obj* pathObjPtr, Tcl_Filesystem * fsPtr)); +/* 466 */ +EXTERN Tcl_Obj* Tcl_FSGetTranslatedPath _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Obj* pathPtr)); +/* 467 */ +EXTERN int Tcl_FSEvalFile _ANSI_ARGS_((Tcl_Interp * interp, + Tcl_Obj * fileName)); +/* 468 */ +EXTERN Tcl_Obj* Tcl_FSNewNativePath _ANSI_ARGS_(( + Tcl_Filesystem* fromFilesystem, + ClientData clientData)); +/* 469 */ +EXTERN CONST char* Tcl_FSGetNativePath _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); +/* 470 */ +EXTERN Tcl_Obj* Tcl_FSFileSystemInfo _ANSI_ARGS_(( + Tcl_Obj* pathObjPtr)); +/* 471 */ +EXTERN Tcl_Obj* Tcl_FSPathSeparator _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); +/* 472 */ +EXTERN Tcl_Obj* Tcl_FSListVolumes _ANSI_ARGS_((void)); +/* 473 */ +EXTERN int Tcl_FSRegister _ANSI_ARGS_((ClientData clientData, + Tcl_Filesystem * fsPtr)); +/* 474 */ +EXTERN int Tcl_FSUnregister _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); +/* 475 */ +EXTERN ClientData Tcl_FSData _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); +/* 476 */ +EXTERN CONST char* Tcl_FSGetTranslatedStringPath _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Obj* pathPtr)); +/* 477 */ +EXTERN Tcl_Filesystem* Tcl_FSGetFileSystemForPath _ANSI_ARGS_(( + Tcl_Obj* pathObjPtr)); +/* 478 */ +EXTERN Tcl_PathType Tcl_FSGetPathType _ANSI_ARGS_((Tcl_Obj * pathObjPtr)); +/* 479 */ +EXTERN int Tcl_OutputBuffered _ANSI_ARGS_((Tcl_Channel chan)); +/* 480 */ +EXTERN void Tcl_FSMountsChanged _ANSI_ARGS_(( + Tcl_Filesystem * fsPtr)); +/* 481 */ +EXTERN int Tcl_EvalTokensStandard _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Token * tokenPtr, + int count)); +/* 482 */ +EXTERN void Tcl_GetTime _ANSI_ARGS_((Tcl_Time* timeBuf)); +/* 483 */ +EXTERN Tcl_Trace Tcl_CreateObjTrace _ANSI_ARGS_((Tcl_Interp* interp, + int level, int flags, + Tcl_CmdObjTraceProc* objProc, + ClientData clientData, + Tcl_CmdObjTraceDeleteProc* delProc)); +/* 484 */ +EXTERN int Tcl_GetCommandInfoFromToken _ANSI_ARGS_(( + Tcl_Command token, Tcl_CmdInfo* infoPtr)); +/* 485 */ +EXTERN int Tcl_SetCommandInfoFromToken _ANSI_ARGS_(( + Tcl_Command token, + CONST Tcl_CmdInfo* infoPtr)); +/* 486 */ +EXTERN Tcl_Obj * Tcl_DbNewWideIntObj _ANSI_ARGS_(( + Tcl_WideInt wideValue, CONST char * file, + int line)); +/* 487 */ +EXTERN int Tcl_GetWideIntFromObj _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Obj * objPtr, + Tcl_WideInt * widePtr)); +/* 488 */ +EXTERN Tcl_Obj * Tcl_NewWideIntObj _ANSI_ARGS_((Tcl_WideInt wideValue)); +/* 489 */ +EXTERN void Tcl_SetWideIntObj _ANSI_ARGS_((Tcl_Obj * objPtr, + Tcl_WideInt wideValue)); +/* 490 */ +EXTERN Tcl_StatBuf * Tcl_AllocStatBuf _ANSI_ARGS_((void)); +/* 491 */ +EXTERN Tcl_WideInt Tcl_Seek _ANSI_ARGS_((Tcl_Channel chan, + Tcl_WideInt offset, int mode)); +/* 492 */ +EXTERN Tcl_WideInt Tcl_Tell _ANSI_ARGS_((Tcl_Channel chan)); +/* 493 */ +EXTERN Tcl_DriverWideSeekProc * Tcl_ChannelWideSeekProc _ANSI_ARGS_(( + Tcl_ChannelType * chanTypePtr)); typedef struct TclStubHooks { struct TclPlatStubs *tclPlatStubs; @@ -1291,15 +1575,15 @@ typedef struct TclStubs { int magic; struct TclStubHooks *hooks; - int (*tcl_PkgProvideEx) _ANSI_ARGS_((Tcl_Interp * interp, char * name, char * version, ClientData clientData)); /* 0 */ - char * (*tcl_PkgRequireEx) _ANSI_ARGS_((Tcl_Interp * interp, char * name, char * version, int exact, ClientData * clientDataPtr)); /* 1 */ - void (*tcl_Panic) _ANSI_ARGS_(TCL_VARARGS(char *,format)); /* 2 */ + int (*tcl_PkgProvideEx) _ANSI_ARGS_((Tcl_Interp* interp, CONST char* name, CONST char* version, ClientData clientData)); /* 0 */ + CONST84_RETURN char * (*tcl_PkgRequireEx) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact, ClientData * clientDataPtr)); /* 1 */ + void (*tcl_Panic) _ANSI_ARGS_(TCL_VARARGS(CONST char *,format)); /* 2 */ char * (*tcl_Alloc) _ANSI_ARGS_((unsigned int size)); /* 3 */ void (*tcl_Free) _ANSI_ARGS_((char * ptr)); /* 4 */ char * (*tcl_Realloc) _ANSI_ARGS_((char * ptr, unsigned int size)); /* 5 */ - char * (*tcl_DbCkalloc) _ANSI_ARGS_((unsigned int size, char * file, int line)); /* 6 */ - int (*tcl_DbCkfree) _ANSI_ARGS_((char * ptr, char * file, int line)); /* 7 */ - char * (*tcl_DbCkrealloc) _ANSI_ARGS_((char * ptr, unsigned int size, char * file, int line)); /* 8 */ + char * (*tcl_DbCkalloc) _ANSI_ARGS_((unsigned int size, CONST char * file, int line)); /* 6 */ + int (*tcl_DbCkfree) _ANSI_ARGS_((char * ptr, CONST char * file, int line)); /* 7 */ + char * (*tcl_DbCkrealloc) _ANSI_ARGS_((char * ptr, unsigned int size, CONST char * file, int line)); /* 8 */ #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ void (*tcl_CreateFileHandler) _ANSI_ARGS_((int fd, int mask, Tcl_FileProc * proc, ClientData clientData)); /* 9 */ #endif /* UNIX */ @@ -1323,41 +1607,41 @@ typedef struct TclStubs { int (*tcl_WaitForEvent) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 13 */ int (*tcl_AppendAllObjTypes) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 14 */ void (*tcl_AppendStringsToObj) _ANSI_ARGS_(TCL_VARARGS(Tcl_Obj *,objPtr)); /* 15 */ - void (*tcl_AppendToObj) _ANSI_ARGS_((Tcl_Obj * objPtr, char * bytes, int length)); /* 16 */ + void (*tcl_AppendToObj) _ANSI_ARGS_((Tcl_Obj* objPtr, CONST char* bytes, int length)); /* 16 */ Tcl_Obj * (*tcl_ConcatObj) _ANSI_ARGS_((int objc, Tcl_Obj *CONST objv[])); /* 17 */ int (*tcl_ConvertToType) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_ObjType * typePtr)); /* 18 */ - void (*tcl_DbDecrRefCount) _ANSI_ARGS_((Tcl_Obj * objPtr, char * file, int line)); /* 19 */ - void (*tcl_DbIncrRefCount) _ANSI_ARGS_((Tcl_Obj * objPtr, char * file, int line)); /* 20 */ - int (*tcl_DbIsShared) _ANSI_ARGS_((Tcl_Obj * objPtr, char * file, int line)); /* 21 */ - Tcl_Obj * (*tcl_DbNewBooleanObj) _ANSI_ARGS_((int boolValue, char * file, int line)); /* 22 */ - Tcl_Obj * (*tcl_DbNewByteArrayObj) _ANSI_ARGS_((unsigned char * bytes, int length, char * file, int line)); /* 23 */ - Tcl_Obj * (*tcl_DbNewDoubleObj) _ANSI_ARGS_((double doubleValue, char * file, int line)); /* 24 */ - Tcl_Obj * (*tcl_DbNewListObj) _ANSI_ARGS_((int objc, Tcl_Obj *CONST objv[], char * file, int line)); /* 25 */ - Tcl_Obj * (*tcl_DbNewLongObj) _ANSI_ARGS_((long longValue, char * file, int line)); /* 26 */ - Tcl_Obj * (*tcl_DbNewObj) _ANSI_ARGS_((char * file, int line)); /* 27 */ - Tcl_Obj * (*tcl_DbNewStringObj) _ANSI_ARGS_((CONST char * bytes, int length, char * file, int line)); /* 28 */ + void (*tcl_DbDecrRefCount) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST char * file, int line)); /* 19 */ + void (*tcl_DbIncrRefCount) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST char * file, int line)); /* 20 */ + int (*tcl_DbIsShared) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST char * file, int line)); /* 21 */ + Tcl_Obj * (*tcl_DbNewBooleanObj) _ANSI_ARGS_((int boolValue, CONST char * file, int line)); /* 22 */ + Tcl_Obj * (*tcl_DbNewByteArrayObj) _ANSI_ARGS_((CONST unsigned char * bytes, int length, CONST char * file, int line)); /* 23 */ + Tcl_Obj * (*tcl_DbNewDoubleObj) _ANSI_ARGS_((double doubleValue, CONST char * file, int line)); /* 24 */ + Tcl_Obj * (*tcl_DbNewListObj) _ANSI_ARGS_((int objc, Tcl_Obj *CONST * objv, CONST char * file, int line)); /* 25 */ + Tcl_Obj * (*tcl_DbNewLongObj) _ANSI_ARGS_((long longValue, CONST char * file, int line)); /* 26 */ + Tcl_Obj * (*tcl_DbNewObj) _ANSI_ARGS_((CONST char * file, int line)); /* 27 */ + Tcl_Obj * (*tcl_DbNewStringObj) _ANSI_ARGS_((CONST char * bytes, int length, CONST char * file, int line)); /* 28 */ Tcl_Obj * (*tcl_DuplicateObj) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 29 */ void (*tclFreeObj) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 30 */ - int (*tcl_GetBoolean) _ANSI_ARGS_((Tcl_Interp * interp, char * str, int * boolPtr)); /* 31 */ + int (*tcl_GetBoolean) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, int * boolPtr)); /* 31 */ int (*tcl_GetBooleanFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * boolPtr)); /* 32 */ unsigned char * (*tcl_GetByteArrayFromObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int * lengthPtr)); /* 33 */ - int (*tcl_GetDouble) _ANSI_ARGS_((Tcl_Interp * interp, char * str, double * doublePtr)); /* 34 */ + int (*tcl_GetDouble) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, double * doublePtr)); /* 34 */ int (*tcl_GetDoubleFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, double * doublePtr)); /* 35 */ - int (*tcl_GetIndexFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, char ** tablePtr, char * msg, int flags, int * indexPtr)); /* 36 */ - int (*tcl_GetInt) _ANSI_ARGS_((Tcl_Interp * interp, char * str, int * intPtr)); /* 37 */ + int (*tcl_GetIndexFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, CONST84 char ** tablePtr, CONST char * msg, int flags, int * indexPtr)); /* 36 */ + int (*tcl_GetInt) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, int * intPtr)); /* 37 */ int (*tcl_GetIntFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * intPtr)); /* 38 */ int (*tcl_GetLongFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, long * longPtr)); /* 39 */ - Tcl_ObjType * (*tcl_GetObjType) _ANSI_ARGS_((char * typeName)); /* 40 */ + Tcl_ObjType * (*tcl_GetObjType) _ANSI_ARGS_((CONST char * typeName)); /* 40 */ char * (*tcl_GetStringFromObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int * lengthPtr)); /* 41 */ void (*tcl_InvalidateStringRep) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 42 */ int (*tcl_ListObjAppendList) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, Tcl_Obj * elemListPtr)); /* 43 */ int (*tcl_ListObjAppendElement) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, Tcl_Obj * objPtr)); /* 44 */ int (*tcl_ListObjGetElements) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, int * objcPtr, Tcl_Obj *** objvPtr)); /* 45 */ int (*tcl_ListObjIndex) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, int index, Tcl_Obj ** objPtrPtr)); /* 46 */ - int (*tcl_ListObjLength) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, int * intPtr)); /* 47 */ + int (*tcl_ListObjLength) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, int * lengthPtr)); /* 47 */ int (*tcl_ListObjReplace) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, int first, int count, int objc, Tcl_Obj *CONST objv[])); /* 48 */ Tcl_Obj * (*tcl_NewBooleanObj) _ANSI_ARGS_((int boolValue)); /* 49 */ - Tcl_Obj * (*tcl_NewByteArrayObj) _ANSI_ARGS_((unsigned char * bytes, int length)); /* 50 */ + Tcl_Obj * (*tcl_NewByteArrayObj) _ANSI_ARGS_((CONST unsigned char* bytes, int length)); /* 50 */ Tcl_Obj * (*tcl_NewDoubleObj) _ANSI_ARGS_((double doubleValue)); /* 51 */ Tcl_Obj * (*tcl_NewIntObj) _ANSI_ARGS_((int intValue)); /* 52 */ Tcl_Obj * (*tcl_NewListObj) _ANSI_ARGS_((int objc, Tcl_Obj *CONST objv[])); /* 53 */ @@ -1366,13 +1650,13 @@ typedef struct TclStubs { Tcl_Obj * (*tcl_NewStringObj) _ANSI_ARGS_((CONST char * bytes, int length)); /* 56 */ void (*tcl_SetBooleanObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int boolValue)); /* 57 */ unsigned char * (*tcl_SetByteArrayLength) _ANSI_ARGS_((Tcl_Obj * objPtr, int length)); /* 58 */ - void (*tcl_SetByteArrayObj) _ANSI_ARGS_((Tcl_Obj * objPtr, unsigned char * bytes, int length)); /* 59 */ + void (*tcl_SetByteArrayObj) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST unsigned char * bytes, int length)); /* 59 */ void (*tcl_SetDoubleObj) _ANSI_ARGS_((Tcl_Obj * objPtr, double doubleValue)); /* 60 */ void (*tcl_SetIntObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int intValue)); /* 61 */ void (*tcl_SetListObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int objc, Tcl_Obj *CONST objv[])); /* 62 */ void (*tcl_SetLongObj) _ANSI_ARGS_((Tcl_Obj * objPtr, long longValue)); /* 63 */ void (*tcl_SetObjLength) _ANSI_ARGS_((Tcl_Obj * objPtr, int length)); /* 64 */ - void (*tcl_SetStringObj) _ANSI_ARGS_((Tcl_Obj * objPtr, char * bytes, int length)); /* 65 */ + void (*tcl_SetStringObj) _ANSI_ARGS_((Tcl_Obj* objPtr, CONST char* bytes, int length)); /* 65 */ void (*tcl_AddErrorInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * message)); /* 66 */ void (*tcl_AddObjErrorInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * message, int length)); /* 67 */ void (*tcl_AllowExceptions) _ANSI_ARGS_((Tcl_Interp * interp)); /* 68 */ @@ -1385,32 +1669,32 @@ typedef struct TclStubs { int (*tcl_AsyncReady) _ANSI_ARGS_((void)); /* 75 */ void (*tcl_BackgroundError) _ANSI_ARGS_((Tcl_Interp * interp)); /* 76 */ char (*tcl_Backslash) _ANSI_ARGS_((CONST char * src, int * readPtr)); /* 77 */ - int (*tcl_BadChannelOption) _ANSI_ARGS_((Tcl_Interp * interp, char * optionName, char * optionList)); /* 78 */ + int (*tcl_BadChannelOption) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * optionName, CONST char * optionList)); /* 78 */ void (*tcl_CallWhenDeleted) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_InterpDeleteProc * proc, ClientData clientData)); /* 79 */ void (*tcl_CancelIdleCall) _ANSI_ARGS_((Tcl_IdleProc * idleProc, ClientData clientData)); /* 80 */ int (*tcl_Close) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 81 */ - int (*tcl_CommandComplete) _ANSI_ARGS_((char * cmd)); /* 82 */ - char * (*tcl_Concat) _ANSI_ARGS_((int argc, char ** argv)); /* 83 */ + int (*tcl_CommandComplete) _ANSI_ARGS_((CONST char * cmd)); /* 82 */ + char * (*tcl_Concat) _ANSI_ARGS_((int argc, CONST84 char * CONST * argv)); /* 83 */ int (*tcl_ConvertElement) _ANSI_ARGS_((CONST char * src, char * dst, int flags)); /* 84 */ int (*tcl_ConvertCountedElement) _ANSI_ARGS_((CONST char * src, int length, char * dst, int flags)); /* 85 */ - int (*tcl_CreateAlias) _ANSI_ARGS_((Tcl_Interp * slave, char * slaveCmd, Tcl_Interp * target, char * targetCmd, int argc, char ** argv)); /* 86 */ - int (*tcl_CreateAliasObj) _ANSI_ARGS_((Tcl_Interp * slave, char * slaveCmd, Tcl_Interp * target, char * targetCmd, int objc, Tcl_Obj *CONST objv[])); /* 87 */ - Tcl_Channel (*tcl_CreateChannel) _ANSI_ARGS_((Tcl_ChannelType * typePtr, char * chanName, ClientData instanceData, int mask)); /* 88 */ + int (*tcl_CreateAlias) _ANSI_ARGS_((Tcl_Interp * slave, CONST char * slaveCmd, Tcl_Interp * target, CONST char * targetCmd, int argc, CONST84 char * CONST * argv)); /* 86 */ + int (*tcl_CreateAliasObj) _ANSI_ARGS_((Tcl_Interp * slave, CONST char * slaveCmd, Tcl_Interp * target, CONST char * targetCmd, int objc, Tcl_Obj *CONST objv[])); /* 87 */ + Tcl_Channel (*tcl_CreateChannel) _ANSI_ARGS_((Tcl_ChannelType * typePtr, CONST char * chanName, ClientData instanceData, int mask)); /* 88 */ void (*tcl_CreateChannelHandler) _ANSI_ARGS_((Tcl_Channel chan, int mask, Tcl_ChannelProc * proc, ClientData clientData)); /* 89 */ void (*tcl_CreateCloseHandler) _ANSI_ARGS_((Tcl_Channel chan, Tcl_CloseProc * proc, ClientData clientData)); /* 90 */ - Tcl_Command (*tcl_CreateCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * cmdName, Tcl_CmdProc * proc, ClientData clientData, Tcl_CmdDeleteProc * deleteProc)); /* 91 */ + Tcl_Command (*tcl_CreateCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, Tcl_CmdProc * proc, ClientData clientData, Tcl_CmdDeleteProc * deleteProc)); /* 91 */ void (*tcl_CreateEventSource) _ANSI_ARGS_((Tcl_EventSetupProc * setupProc, Tcl_EventCheckProc * checkProc, ClientData clientData)); /* 92 */ void (*tcl_CreateExitHandler) _ANSI_ARGS_((Tcl_ExitProc * proc, ClientData clientData)); /* 93 */ Tcl_Interp * (*tcl_CreateInterp) _ANSI_ARGS_((void)); /* 94 */ - void (*tcl_CreateMathFunc) _ANSI_ARGS_((Tcl_Interp * interp, char * name, int numArgs, Tcl_ValueType * argTypes, Tcl_MathProc * proc, ClientData clientData)); /* 95 */ - Tcl_Command (*tcl_CreateObjCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * cmdName, Tcl_ObjCmdProc * proc, ClientData clientData, Tcl_CmdDeleteProc * deleteProc)); /* 96 */ - Tcl_Interp * (*tcl_CreateSlave) _ANSI_ARGS_((Tcl_Interp * interp, char * slaveName, int isSafe)); /* 97 */ + void (*tcl_CreateMathFunc) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, int numArgs, Tcl_ValueType * argTypes, Tcl_MathProc * proc, ClientData clientData)); /* 95 */ + Tcl_Command (*tcl_CreateObjCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, Tcl_ObjCmdProc * proc, ClientData clientData, Tcl_CmdDeleteProc * deleteProc)); /* 96 */ + Tcl_Interp * (*tcl_CreateSlave) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * slaveName, int isSafe)); /* 97 */ Tcl_TimerToken (*tcl_CreateTimerHandler) _ANSI_ARGS_((int milliseconds, Tcl_TimerProc * proc, ClientData clientData)); /* 98 */ Tcl_Trace (*tcl_CreateTrace) _ANSI_ARGS_((Tcl_Interp * interp, int level, Tcl_CmdTraceProc * proc, ClientData clientData)); /* 99 */ - void (*tcl_DeleteAssocData) _ANSI_ARGS_((Tcl_Interp * interp, char * name)); /* 100 */ + void (*tcl_DeleteAssocData) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name)); /* 100 */ void (*tcl_DeleteChannelHandler) _ANSI_ARGS_((Tcl_Channel chan, Tcl_ChannelProc * proc, ClientData clientData)); /* 101 */ void (*tcl_DeleteCloseHandler) _ANSI_ARGS_((Tcl_Channel chan, Tcl_CloseProc * proc, ClientData clientData)); /* 102 */ - int (*tcl_DeleteCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * cmdName)); /* 103 */ + int (*tcl_DeleteCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName)); /* 103 */ int (*tcl_DeleteCommandFromToken) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command command)); /* 104 */ void (*tcl_DeleteEvents) _ANSI_ARGS_((Tcl_EventDeleteProc * proc, ClientData clientData)); /* 105 */ void (*tcl_DeleteEventSource) _ANSI_ARGS_((Tcl_EventSetupProc * setupProc, Tcl_EventCheckProc * checkProc, ClientData clientData)); /* 106 */ @@ -1442,48 +1726,48 @@ typedef struct TclStubs { void (*tcl_DStringSetLength) _ANSI_ARGS_((Tcl_DString * dsPtr, int length)); /* 124 */ void (*tcl_DStringStartSublist) _ANSI_ARGS_((Tcl_DString * dsPtr)); /* 125 */ int (*tcl_Eof) _ANSI_ARGS_((Tcl_Channel chan)); /* 126 */ - char * (*tcl_ErrnoId) _ANSI_ARGS_((void)); /* 127 */ - char * (*tcl_ErrnoMsg) _ANSI_ARGS_((int err)); /* 128 */ - int (*tcl_Eval) _ANSI_ARGS_((Tcl_Interp * interp, char * string)); /* 129 */ - int (*tcl_EvalFile) _ANSI_ARGS_((Tcl_Interp * interp, char * fileName)); /* 130 */ + CONST84_RETURN char * (*tcl_ErrnoId) _ANSI_ARGS_((void)); /* 127 */ + CONST84_RETURN char * (*tcl_ErrnoMsg) _ANSI_ARGS_((int err)); /* 128 */ + int (*tcl_Eval) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string)); /* 129 */ + int (*tcl_EvalFile) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * fileName)); /* 130 */ int (*tcl_EvalObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 131 */ void (*tcl_EventuallyFree) _ANSI_ARGS_((ClientData clientData, Tcl_FreeProc * freeProc)); /* 132 */ void (*tcl_Exit) _ANSI_ARGS_((int status)); /* 133 */ - int (*tcl_ExposeCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * hiddenCmdToken, char * cmdName)); /* 134 */ - int (*tcl_ExprBoolean) _ANSI_ARGS_((Tcl_Interp * interp, char * str, int * ptr)); /* 135 */ + int (*tcl_ExposeCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * hiddenCmdToken, CONST char * cmdName)); /* 134 */ + int (*tcl_ExprBoolean) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, int * ptr)); /* 135 */ int (*tcl_ExprBooleanObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * ptr)); /* 136 */ - int (*tcl_ExprDouble) _ANSI_ARGS_((Tcl_Interp * interp, char * str, double * ptr)); /* 137 */ + int (*tcl_ExprDouble) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, double * ptr)); /* 137 */ int (*tcl_ExprDoubleObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, double * ptr)); /* 138 */ - int (*tcl_ExprLong) _ANSI_ARGS_((Tcl_Interp * interp, char * str, long * ptr)); /* 139 */ + int (*tcl_ExprLong) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, long * ptr)); /* 139 */ int (*tcl_ExprLongObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, long * ptr)); /* 140 */ int (*tcl_ExprObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_Obj ** resultPtrPtr)); /* 141 */ - int (*tcl_ExprString) _ANSI_ARGS_((Tcl_Interp * interp, char * string)); /* 142 */ + int (*tcl_ExprString) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string)); /* 142 */ void (*tcl_Finalize) _ANSI_ARGS_((void)); /* 143 */ void (*tcl_FindExecutable) _ANSI_ARGS_((CONST char * argv0)); /* 144 */ Tcl_HashEntry * (*tcl_FirstHashEntry) _ANSI_ARGS_((Tcl_HashTable * tablePtr, Tcl_HashSearch * searchPtr)); /* 145 */ int (*tcl_Flush) _ANSI_ARGS_((Tcl_Channel chan)); /* 146 */ void (*tcl_FreeResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 147 */ - int (*tcl_GetAlias) _ANSI_ARGS_((Tcl_Interp * interp, char * slaveCmd, Tcl_Interp ** targetInterpPtr, char ** targetCmdPtr, int * argcPtr, char *** argvPtr)); /* 148 */ - int (*tcl_GetAliasObj) _ANSI_ARGS_((Tcl_Interp * interp, char * slaveCmd, Tcl_Interp ** targetInterpPtr, char ** targetCmdPtr, int * objcPtr, Tcl_Obj *** objv)); /* 149 */ - ClientData (*tcl_GetAssocData) _ANSI_ARGS_((Tcl_Interp * interp, char * name, Tcl_InterpDeleteProc ** procPtr)); /* 150 */ - Tcl_Channel (*tcl_GetChannel) _ANSI_ARGS_((Tcl_Interp * interp, char * chanName, int * modePtr)); /* 151 */ + int (*tcl_GetAlias) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * slaveCmd, Tcl_Interp ** targetInterpPtr, CONST84 char ** targetCmdPtr, int * argcPtr, CONST84 char *** argvPtr)); /* 148 */ + int (*tcl_GetAliasObj) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * slaveCmd, Tcl_Interp ** targetInterpPtr, CONST84 char ** targetCmdPtr, int * objcPtr, Tcl_Obj *** objv)); /* 149 */ + ClientData (*tcl_GetAssocData) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_InterpDeleteProc ** procPtr)); /* 150 */ + Tcl_Channel (*tcl_GetChannel) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * chanName, int * modePtr)); /* 151 */ int (*tcl_GetChannelBufferSize) _ANSI_ARGS_((Tcl_Channel chan)); /* 152 */ int (*tcl_GetChannelHandle) _ANSI_ARGS_((Tcl_Channel chan, int direction, ClientData * handlePtr)); /* 153 */ ClientData (*tcl_GetChannelInstanceData) _ANSI_ARGS_((Tcl_Channel chan)); /* 154 */ int (*tcl_GetChannelMode) _ANSI_ARGS_((Tcl_Channel chan)); /* 155 */ - char * (*tcl_GetChannelName) _ANSI_ARGS_((Tcl_Channel chan)); /* 156 */ - int (*tcl_GetChannelOption) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, char * optionName, Tcl_DString * dsPtr)); /* 157 */ + CONST84_RETURN char * (*tcl_GetChannelName) _ANSI_ARGS_((Tcl_Channel chan)); /* 156 */ + int (*tcl_GetChannelOption) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, CONST char * optionName, Tcl_DString * dsPtr)); /* 157 */ Tcl_ChannelType * (*tcl_GetChannelType) _ANSI_ARGS_((Tcl_Channel chan)); /* 158 */ - int (*tcl_GetCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, char * cmdName, Tcl_CmdInfo * infoPtr)); /* 159 */ - char * (*tcl_GetCommandName) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command command)); /* 160 */ + int (*tcl_GetCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, Tcl_CmdInfo * infoPtr)); /* 159 */ + CONST84_RETURN char * (*tcl_GetCommandName) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command command)); /* 160 */ int (*tcl_GetErrno) _ANSI_ARGS_((void)); /* 161 */ - char * (*tcl_GetHostName) _ANSI_ARGS_((void)); /* 162 */ + CONST84_RETURN char * (*tcl_GetHostName) _ANSI_ARGS_((void)); /* 162 */ int (*tcl_GetInterpPath) _ANSI_ARGS_((Tcl_Interp * askInterp, Tcl_Interp * slaveInterp)); /* 163 */ Tcl_Interp * (*tcl_GetMaster) _ANSI_ARGS_((Tcl_Interp * interp)); /* 164 */ CONST char * (*tcl_GetNameOfExecutable) _ANSI_ARGS_((void)); /* 165 */ Tcl_Obj * (*tcl_GetObjResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 166 */ #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ - int (*tcl_GetOpenFile) _ANSI_ARGS_((Tcl_Interp * interp, char * str, int forWriting, int checkUsage, ClientData * filePtr)); /* 167 */ + int (*tcl_GetOpenFile) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, int forWriting, int checkUsage, ClientData * filePtr)); /* 167 */ #endif /* UNIX */ #ifdef __WIN32__ void *reserved167; @@ -1491,51 +1775,51 @@ typedef struct TclStubs { #ifdef MAC_TCL void *reserved167; #endif /* MAC_TCL */ - Tcl_PathType (*tcl_GetPathType) _ANSI_ARGS_((char * path)); /* 168 */ + Tcl_PathType (*tcl_GetPathType) _ANSI_ARGS_((CONST char * path)); /* 168 */ int (*tcl_Gets) _ANSI_ARGS_((Tcl_Channel chan, Tcl_DString * dsPtr)); /* 169 */ int (*tcl_GetsObj) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj * objPtr)); /* 170 */ int (*tcl_GetServiceMode) _ANSI_ARGS_((void)); /* 171 */ - Tcl_Interp * (*tcl_GetSlave) _ANSI_ARGS_((Tcl_Interp * interp, char * slaveName)); /* 172 */ + Tcl_Interp * (*tcl_GetSlave) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * slaveName)); /* 172 */ Tcl_Channel (*tcl_GetStdChannel) _ANSI_ARGS_((int type)); /* 173 */ - char * (*tcl_GetStringResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 174 */ - char * (*tcl_GetVar) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, int flags)); /* 175 */ - char * (*tcl_GetVar2) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, char * part2, int flags)); /* 176 */ - int (*tcl_GlobalEval) _ANSI_ARGS_((Tcl_Interp * interp, char * command)); /* 177 */ + CONST84_RETURN char * (*tcl_GetStringResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 174 */ + CONST84_RETURN char * (*tcl_GetVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags)); /* 175 */ + CONST84_RETURN char * (*tcl_GetVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags)); /* 176 */ + int (*tcl_GlobalEval) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * command)); /* 177 */ int (*tcl_GlobalEvalObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 178 */ - int (*tcl_HideCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * cmdName, char * hiddenCmdToken)); /* 179 */ + int (*tcl_HideCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, CONST char * hiddenCmdToken)); /* 179 */ int (*tcl_Init) _ANSI_ARGS_((Tcl_Interp * interp)); /* 180 */ void (*tcl_InitHashTable) _ANSI_ARGS_((Tcl_HashTable * tablePtr, int keyType)); /* 181 */ int (*tcl_InputBlocked) _ANSI_ARGS_((Tcl_Channel chan)); /* 182 */ int (*tcl_InputBuffered) _ANSI_ARGS_((Tcl_Channel chan)); /* 183 */ int (*tcl_InterpDeleted) _ANSI_ARGS_((Tcl_Interp * interp)); /* 184 */ int (*tcl_IsSafe) _ANSI_ARGS_((Tcl_Interp * interp)); /* 185 */ - char * (*tcl_JoinPath) _ANSI_ARGS_((int argc, char ** argv, Tcl_DString * resultPtr)); /* 186 */ - int (*tcl_LinkVar) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, char * addr, int type)); /* 187 */ + char * (*tcl_JoinPath) _ANSI_ARGS_((int argc, CONST84 char * CONST * argv, Tcl_DString * resultPtr)); /* 186 */ + int (*tcl_LinkVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, char * addr, int type)); /* 187 */ void *reserved188; Tcl_Channel (*tcl_MakeFileChannel) _ANSI_ARGS_((ClientData handle, int mode)); /* 189 */ int (*tcl_MakeSafe) _ANSI_ARGS_((Tcl_Interp * interp)); /* 190 */ Tcl_Channel (*tcl_MakeTcpClientChannel) _ANSI_ARGS_((ClientData tcpSocket)); /* 191 */ - char * (*tcl_Merge) _ANSI_ARGS_((int argc, char ** argv)); /* 192 */ + char * (*tcl_Merge) _ANSI_ARGS_((int argc, CONST84 char * CONST * argv)); /* 192 */ Tcl_HashEntry * (*tcl_NextHashEntry) _ANSI_ARGS_((Tcl_HashSearch * searchPtr)); /* 193 */ void (*tcl_NotifyChannel) _ANSI_ARGS_((Tcl_Channel channel, int mask)); /* 194 */ Tcl_Obj * (*tcl_ObjGetVar2) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, int flags)); /* 195 */ Tcl_Obj * (*tcl_ObjSetVar2) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, Tcl_Obj * newValuePtr, int flags)); /* 196 */ #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ - Tcl_Channel (*tcl_OpenCommandChannel) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv, int flags)); /* 197 */ + Tcl_Channel (*tcl_OpenCommandChannel) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST84 char ** argv, int flags)); /* 197 */ #endif /* UNIX */ #ifdef __WIN32__ - Tcl_Channel (*tcl_OpenCommandChannel) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv, int flags)); /* 197 */ + Tcl_Channel (*tcl_OpenCommandChannel) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST84 char ** argv, int flags)); /* 197 */ #endif /* __WIN32__ */ #ifdef MAC_TCL void *reserved197; #endif /* MAC_TCL */ - Tcl_Channel (*tcl_OpenFileChannel) _ANSI_ARGS_((Tcl_Interp * interp, char * fileName, char * modeString, int permissions)); /* 198 */ - Tcl_Channel (*tcl_OpenTcpClient) _ANSI_ARGS_((Tcl_Interp * interp, int port, char * address, char * myaddr, int myport, int async)); /* 199 */ - Tcl_Channel (*tcl_OpenTcpServer) _ANSI_ARGS_((Tcl_Interp * interp, int port, char * host, Tcl_TcpAcceptProc * acceptProc, ClientData callbackData)); /* 200 */ + Tcl_Channel (*tcl_OpenFileChannel) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * fileName, CONST char * modeString, int permissions)); /* 198 */ + Tcl_Channel (*tcl_OpenTcpClient) _ANSI_ARGS_((Tcl_Interp * interp, int port, CONST char * address, CONST char * myaddr, int myport, int async)); /* 199 */ + Tcl_Channel (*tcl_OpenTcpServer) _ANSI_ARGS_((Tcl_Interp * interp, int port, CONST char * host, Tcl_TcpAcceptProc * acceptProc, ClientData callbackData)); /* 200 */ void (*tcl_Preserve) _ANSI_ARGS_((ClientData data)); /* 201 */ void (*tcl_PrintDouble) _ANSI_ARGS_((Tcl_Interp * interp, double value, char * dst)); /* 202 */ int (*tcl_PutEnv) _ANSI_ARGS_((CONST char * string)); /* 203 */ - char * (*tcl_PosixError) _ANSI_ARGS_((Tcl_Interp * interp)); /* 204 */ + CONST84_RETURN char * (*tcl_PosixError) _ANSI_ARGS_((Tcl_Interp * interp)); /* 204 */ void (*tcl_QueueEvent) _ANSI_ARGS_((Tcl_Event * evPtr, Tcl_QueuePosition position)); /* 205 */ int (*tcl_Read) _ANSI_ARGS_((Tcl_Channel chan, char * bufPtr, int toRead)); /* 206 */ #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ @@ -1547,25 +1831,25 @@ typedef struct TclStubs { #ifdef MAC_TCL void *reserved207; #endif /* MAC_TCL */ - int (*tcl_RecordAndEval) _ANSI_ARGS_((Tcl_Interp * interp, char * cmd, int flags)); /* 208 */ + int (*tcl_RecordAndEval) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmd, int flags)); /* 208 */ int (*tcl_RecordAndEvalObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * cmdPtr, int flags)); /* 209 */ void (*tcl_RegisterChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 210 */ void (*tcl_RegisterObjType) _ANSI_ARGS_((Tcl_ObjType * typePtr)); /* 211 */ - Tcl_RegExp (*tcl_RegExpCompile) _ANSI_ARGS_((Tcl_Interp * interp, char * string)); /* 212 */ + Tcl_RegExp (*tcl_RegExpCompile) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string)); /* 212 */ int (*tcl_RegExpExec) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_RegExp regexp, CONST char * str, CONST char * start)); /* 213 */ - int (*tcl_RegExpMatch) _ANSI_ARGS_((Tcl_Interp * interp, char * str, char * pattern)); /* 214 */ - void (*tcl_RegExpRange) _ANSI_ARGS_((Tcl_RegExp regexp, int index, char ** startPtr, char ** endPtr)); /* 215 */ + int (*tcl_RegExpMatch) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, CONST char * pattern)); /* 214 */ + void (*tcl_RegExpRange) _ANSI_ARGS_((Tcl_RegExp regexp, int index, CONST84 char ** startPtr, CONST84 char ** endPtr)); /* 215 */ void (*tcl_Release) _ANSI_ARGS_((ClientData clientData)); /* 216 */ void (*tcl_ResetResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 217 */ int (*tcl_ScanElement) _ANSI_ARGS_((CONST char * str, int * flagPtr)); /* 218 */ int (*tcl_ScanCountedElement) _ANSI_ARGS_((CONST char * str, int length, int * flagPtr)); /* 219 */ - int (*tcl_Seek) _ANSI_ARGS_((Tcl_Channel chan, int offset, int mode)); /* 220 */ + int (*tcl_SeekOld) _ANSI_ARGS_((Tcl_Channel chan, int offset, int mode)); /* 220 */ int (*tcl_ServiceAll) _ANSI_ARGS_((void)); /* 221 */ int (*tcl_ServiceEvent) _ANSI_ARGS_((int flags)); /* 222 */ - void (*tcl_SetAssocData) _ANSI_ARGS_((Tcl_Interp * interp, char * name, Tcl_InterpDeleteProc * proc, ClientData clientData)); /* 223 */ + void (*tcl_SetAssocData) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_InterpDeleteProc * proc, ClientData clientData)); /* 223 */ void (*tcl_SetChannelBufferSize) _ANSI_ARGS_((Tcl_Channel chan, int sz)); /* 224 */ - int (*tcl_SetChannelOption) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, char * optionName, char * newValue)); /* 225 */ - int (*tcl_SetCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, char * cmdName, Tcl_CmdInfo * infoPtr)); /* 226 */ + int (*tcl_SetChannelOption) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, CONST char * optionName, CONST char * newValue)); /* 225 */ + int (*tcl_SetCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, CONST Tcl_CmdInfo * infoPtr)); /* 226 */ void (*tcl_SetErrno) _ANSI_ARGS_((int err)); /* 227 */ void (*tcl_SetErrorCode) _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); /* 228 */ void (*tcl_SetMaxBlockTime) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 229 */ @@ -1576,69 +1860,61 @@ typedef struct TclStubs { void (*tcl_SetObjErrorCode) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * errorObjPtr)); /* 234 */ void (*tcl_SetObjResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * resultObjPtr)); /* 235 */ void (*tcl_SetStdChannel) _ANSI_ARGS_((Tcl_Channel channel, int type)); /* 236 */ - char * (*tcl_SetVar) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, char * newValue, int flags)); /* 237 */ - char * (*tcl_SetVar2) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, char * part2, char * newValue, int flags)); /* 238 */ - char * (*tcl_SignalId) _ANSI_ARGS_((int sig)); /* 239 */ - char * (*tcl_SignalMsg) _ANSI_ARGS_((int sig)); /* 240 */ + CONST84_RETURN char * (*tcl_SetVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, CONST char * newValue, int flags)); /* 237 */ + CONST84_RETURN char * (*tcl_SetVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, CONST char * newValue, int flags)); /* 238 */ + CONST84_RETURN char * (*tcl_SignalId) _ANSI_ARGS_((int sig)); /* 239 */ + CONST84_RETURN char * (*tcl_SignalMsg) _ANSI_ARGS_((int sig)); /* 240 */ void (*tcl_SourceRCFile) _ANSI_ARGS_((Tcl_Interp * interp)); /* 241 */ - int (*tcl_SplitList) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * listStr, int * argcPtr, char *** argvPtr)); /* 242 */ - void (*tcl_SplitPath) _ANSI_ARGS_((CONST char * path, int * argcPtr, char *** argvPtr)); /* 243 */ - void (*tcl_StaticPackage) _ANSI_ARGS_((Tcl_Interp * interp, char * pkgName, Tcl_PackageInitProc * initProc, Tcl_PackageInitProc * safeInitProc)); /* 244 */ + int (*tcl_SplitList) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * listStr, int * argcPtr, CONST84 char *** argvPtr)); /* 242 */ + void (*tcl_SplitPath) _ANSI_ARGS_((CONST char * path, int * argcPtr, CONST84 char *** argvPtr)); /* 243 */ + void (*tcl_StaticPackage) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * pkgName, Tcl_PackageInitProc * initProc, Tcl_PackageInitProc * safeInitProc)); /* 244 */ int (*tcl_StringMatch) _ANSI_ARGS_((CONST char * str, CONST char * pattern)); /* 245 */ - int (*tcl_Tell) _ANSI_ARGS_((Tcl_Channel chan)); /* 246 */ - int (*tcl_TraceVar) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 247 */ - int (*tcl_TraceVar2) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, char * part2, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 248 */ - char * (*tcl_TranslateFileName) _ANSI_ARGS_((Tcl_Interp * interp, char * name, Tcl_DString * bufferPtr)); /* 249 */ - int (*tcl_Ungets) _ANSI_ARGS_((Tcl_Channel chan, char * str, int len, int atHead)); /* 250 */ - void (*tcl_UnlinkVar) _ANSI_ARGS_((Tcl_Interp * interp, char * varName)); /* 251 */ + int (*tcl_TellOld) _ANSI_ARGS_((Tcl_Channel chan)); /* 246 */ + int (*tcl_TraceVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 247 */ + int (*tcl_TraceVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 248 */ + char * (*tcl_TranslateFileName) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_DString * bufferPtr)); /* 249 */ + int (*tcl_Ungets) _ANSI_ARGS_((Tcl_Channel chan, CONST char * str, int len, int atHead)); /* 250 */ + void (*tcl_UnlinkVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName)); /* 251 */ int (*tcl_UnregisterChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 252 */ - int (*tcl_UnsetVar) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, int flags)); /* 253 */ - int (*tcl_UnsetVar2) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, char * part2, int flags)); /* 254 */ - void (*tcl_UntraceVar) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 255 */ - void (*tcl_UntraceVar2) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, char * part2, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 256 */ - void (*tcl_UpdateLinkedVar) _ANSI_ARGS_((Tcl_Interp * interp, char * varName)); /* 257 */ - int (*tcl_UpVar) _ANSI_ARGS_((Tcl_Interp * interp, char * frameName, char * varName, char * localName, int flags)); /* 258 */ - int (*tcl_UpVar2) _ANSI_ARGS_((Tcl_Interp * interp, char * frameName, char * part1, char * part2, char * localName, int flags)); /* 259 */ + int (*tcl_UnsetVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags)); /* 253 */ + int (*tcl_UnsetVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags)); /* 254 */ + void (*tcl_UntraceVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 255 */ + void (*tcl_UntraceVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 256 */ + void (*tcl_UpdateLinkedVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName)); /* 257 */ + int (*tcl_UpVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * frameName, CONST char * varName, CONST char * localName, int flags)); /* 258 */ + int (*tcl_UpVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * frameName, CONST char * part1, CONST char * part2, CONST char * localName, int flags)); /* 259 */ int (*tcl_VarEval) _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); /* 260 */ - ClientData (*tcl_VarTraceInfo) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, int flags, Tcl_VarTraceProc * procPtr, ClientData prevClientData)); /* 261 */ - ClientData (*tcl_VarTraceInfo2) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, char * part2, int flags, Tcl_VarTraceProc * procPtr, ClientData prevClientData)); /* 262 */ - int (*tcl_Write) _ANSI_ARGS_((Tcl_Channel chan, char * s, int slen)); /* 263 */ - void (*tcl_WrongNumArgs) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], char * message)); /* 264 */ - int (*tcl_DumpActiveMemory) _ANSI_ARGS_((char * fileName)); /* 265 */ - void (*tcl_ValidateAllMemory) _ANSI_ARGS_((char * file, int line)); /* 266 */ + ClientData (*tcl_VarTraceInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_VarTraceProc * procPtr, ClientData prevClientData)); /* 261 */ + ClientData (*tcl_VarTraceInfo2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, Tcl_VarTraceProc * procPtr, ClientData prevClientData)); /* 262 */ + int (*tcl_Write) _ANSI_ARGS_((Tcl_Channel chan, CONST char * s, int slen)); /* 263 */ + void (*tcl_WrongNumArgs) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], CONST char * message)); /* 264 */ + int (*tcl_DumpActiveMemory) _ANSI_ARGS_((CONST char * fileName)); /* 265 */ + void (*tcl_ValidateAllMemory) _ANSI_ARGS_((CONST char * file, int line)); /* 266 */ void (*tcl_AppendResultVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 267 */ void (*tcl_AppendStringsToObjVA) _ANSI_ARGS_((Tcl_Obj * objPtr, va_list argList)); /* 268 */ - char * (*tcl_HashStats) _ANSI_ARGS_((Tcl_HashTable * tablePtr)); /* 269 */ - char * (*tcl_ParseVar) _ANSI_ARGS_((Tcl_Interp * interp, char * str, char ** termPtr)); /* 270 */ - char * (*tcl_PkgPresent) _ANSI_ARGS_((Tcl_Interp * interp, char * name, char * version, int exact)); /* 271 */ - char * (*tcl_PkgPresentEx) _ANSI_ARGS_((Tcl_Interp * interp, char * name, char * version, int exact, ClientData * clientDataPtr)); /* 272 */ - int (*tcl_PkgProvide) _ANSI_ARGS_((Tcl_Interp * interp, char * name, char * version)); /* 273 */ - char * (*tcl_PkgRequire) _ANSI_ARGS_((Tcl_Interp * interp, char * name, char * version, int exact)); /* 274 */ + CONST84_RETURN char * (*tcl_HashStats) _ANSI_ARGS_((Tcl_HashTable * tablePtr)); /* 269 */ + CONST84_RETURN char * (*tcl_ParseVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, CONST84 char ** termPtr)); /* 270 */ + CONST84_RETURN char * (*tcl_PkgPresent) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact)); /* 271 */ + CONST84_RETURN char * (*tcl_PkgPresentEx) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact, ClientData * clientDataPtr)); /* 272 */ + int (*tcl_PkgProvide) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version)); /* 273 */ + CONST84_RETURN char * (*tcl_PkgRequire) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact)); /* 274 */ void (*tcl_SetErrorCodeVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 275 */ int (*tcl_VarEvalVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 276 */ Tcl_Pid (*tcl_WaitPid) _ANSI_ARGS_((Tcl_Pid pid, int * statPtr, int options)); /* 277 */ -#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ - void (*tcl_PanicVA) _ANSI_ARGS_((char * format, va_list argList)); /* 278 */ -#endif /* UNIX */ -#ifdef __WIN32__ - void (*tcl_PanicVA) _ANSI_ARGS_((char * format, va_list argList)); /* 278 */ -#endif /* __WIN32__ */ -#ifdef MAC_TCL - void *reserved278; -#endif /* MAC_TCL */ + void (*tcl_PanicVA) _ANSI_ARGS_((CONST char * format, va_list argList)); /* 278 */ void (*tcl_GetVersion) _ANSI_ARGS_((int * major, int * minor, int * patchLevel, int * type)); /* 279 */ void (*tcl_InitMemory) _ANSI_ARGS_((Tcl_Interp * interp)); /* 280 */ Tcl_Channel (*tcl_StackChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_ChannelType * typePtr, ClientData instanceData, int mask, Tcl_Channel prevChan)); /* 281 */ int (*tcl_UnstackChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 282 */ Tcl_Channel (*tcl_GetStackedChannel) _ANSI_ARGS_((Tcl_Channel chan)); /* 283 */ - void *reserved284; + void (*tcl_SetMainLoop) _ANSI_ARGS_((Tcl_MainLoopProc * proc)); /* 284 */ void *reserved285; void (*tcl_AppendObjToObj) _ANSI_ARGS_((Tcl_Obj * objPtr, Tcl_Obj * appendObjPtr)); /* 286 */ Tcl_Encoding (*tcl_CreateEncoding) _ANSI_ARGS_((Tcl_EncodingType * typePtr)); /* 287 */ void (*tcl_CreateThreadExitHandler) _ANSI_ARGS_((Tcl_ExitProc * proc, ClientData clientData)); /* 288 */ void (*tcl_DeleteThreadExitHandler) _ANSI_ARGS_((Tcl_ExitProc * proc, ClientData clientData)); /* 289 */ void (*tcl_DiscardResult) _ANSI_ARGS_((Tcl_SavedResult * statePtr)); /* 290 */ - int (*tcl_EvalEx) _ANSI_ARGS_((Tcl_Interp * interp, char * script, int numBytes, int flags)); /* 291 */ + int (*tcl_EvalEx) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * script, int numBytes, int flags)); /* 291 */ int (*tcl_EvalObjv) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], int flags)); /* 292 */ int (*tcl_EvalObjEx) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int flags)); /* 293 */ void (*tcl_ExitThread) _ANSI_ARGS_((int status)); /* 294 */ @@ -1649,11 +1925,11 @@ typedef struct TclStubs { void (*tcl_FreeEncoding) _ANSI_ARGS_((Tcl_Encoding encoding)); /* 299 */ Tcl_ThreadId (*tcl_GetCurrentThread) _ANSI_ARGS_((void)); /* 300 */ Tcl_Encoding (*tcl_GetEncoding) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name)); /* 301 */ - char * (*tcl_GetEncodingName) _ANSI_ARGS_((Tcl_Encoding encoding)); /* 302 */ + CONST84_RETURN char * (*tcl_GetEncodingName) _ANSI_ARGS_((Tcl_Encoding encoding)); /* 302 */ void (*tcl_GetEncodingNames) _ANSI_ARGS_((Tcl_Interp * interp)); /* 303 */ - int (*tcl_GetIndexFromObjStruct) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, char ** tablePtr, int offset, char * msg, int flags, int * indexPtr)); /* 304 */ + int (*tcl_GetIndexFromObjStruct) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, CONST VOID * tablePtr, int offset, CONST char * msg, int flags, int * indexPtr)); /* 304 */ VOID * (*tcl_GetThreadData) _ANSI_ARGS_((Tcl_ThreadDataKey * keyPtr, int size)); /* 305 */ - Tcl_Obj * (*tcl_GetVar2Ex) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, char * part2, int flags)); /* 306 */ + Tcl_Obj * (*tcl_GetVar2Ex) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags)); /* 306 */ ClientData (*tcl_InitNotifier) _ANSI_ARGS_((void)); /* 307 */ void (*tcl_MutexLock) _ANSI_ARGS_((Tcl_Mutex * mutexPtr)); /* 308 */ void (*tcl_MutexUnlock) _ANSI_ARGS_((Tcl_Mutex * mutexPtr)); /* 309 */ @@ -1664,7 +1940,7 @@ typedef struct TclStubs { void (*tcl_RestoreResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_SavedResult * statePtr)); /* 314 */ void (*tcl_SaveResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_SavedResult * statePtr)); /* 315 */ int (*tcl_SetSystemEncoding) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name)); /* 316 */ - Tcl_Obj * (*tcl_SetVar2Ex) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, char * part2, Tcl_Obj * newValuePtr, int flags)); /* 317 */ + Tcl_Obj * (*tcl_SetVar2Ex) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, Tcl_Obj * newValuePtr, int flags)); /* 317 */ void (*tcl_ThreadAlert) _ANSI_ARGS_((Tcl_ThreadId threadId)); /* 318 */ void (*tcl_ThreadQueueEvent) _ANSI_ARGS_((Tcl_ThreadId threadId, Tcl_Event* evPtr, Tcl_QueuePosition position)); /* 319 */ Tcl_UniChar (*tcl_UniCharAtIndex) _ANSI_ARGS_((CONST char * src, int index)); /* 320 */ @@ -1672,13 +1948,13 @@ typedef struct TclStubs { Tcl_UniChar (*tcl_UniCharToTitle) _ANSI_ARGS_((int ch)); /* 322 */ Tcl_UniChar (*tcl_UniCharToUpper) _ANSI_ARGS_((int ch)); /* 323 */ int (*tcl_UniCharToUtf) _ANSI_ARGS_((int ch, char * buf)); /* 324 */ - char * (*tcl_UtfAtIndex) _ANSI_ARGS_((CONST char * src, int index)); /* 325 */ + CONST84_RETURN char * (*tcl_UtfAtIndex) _ANSI_ARGS_((CONST char * src, int index)); /* 325 */ int (*tcl_UtfCharComplete) _ANSI_ARGS_((CONST char * src, int len)); /* 326 */ int (*tcl_UtfBackslash) _ANSI_ARGS_((CONST char * src, int * readPtr, char * dst)); /* 327 */ - char * (*tcl_UtfFindFirst) _ANSI_ARGS_((CONST char * src, int ch)); /* 328 */ - char * (*tcl_UtfFindLast) _ANSI_ARGS_((CONST char * src, int ch)); /* 329 */ - char * (*tcl_UtfNext) _ANSI_ARGS_((CONST char * src)); /* 330 */ - char * (*tcl_UtfPrev) _ANSI_ARGS_((CONST char * src, CONST char * start)); /* 331 */ + CONST84_RETURN char * (*tcl_UtfFindFirst) _ANSI_ARGS_((CONST char * src, int ch)); /* 328 */ + CONST84_RETURN char * (*tcl_UtfFindLast) _ANSI_ARGS_((CONST char * src, int ch)); /* 329 */ + CONST84_RETURN char * (*tcl_UtfNext) _ANSI_ARGS_((CONST char * src)); /* 330 */ + CONST84_RETURN char * (*tcl_UtfPrev) _ANSI_ARGS_((CONST char * src, CONST char * start)); /* 331 */ int (*tcl_UtfToExternal) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Encoding encoding, CONST char * src, int srcLen, int flags, Tcl_EncodingState * statePtr, char * dst, int dstLen, int * srcReadPtr, int * dstWrotePtr, int * dstCharsPtr)); /* 332 */ char * (*tcl_UtfToExternalDString) _ANSI_ARGS_((Tcl_Encoding encoding, CONST char * src, int srcLen, Tcl_DString * dsPtr)); /* 333 */ int (*tcl_UtfToLower) _ANSI_ARGS_((char * src)); /* 334 */ @@ -1688,8 +1964,8 @@ typedef struct TclStubs { int (*tcl_WriteChars) _ANSI_ARGS_((Tcl_Channel chan, CONST char * src, int srcLen)); /* 338 */ int (*tcl_WriteObj) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj * objPtr)); /* 339 */ char * (*tcl_GetString) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 340 */ - char * (*tcl_GetDefaultEncodingDir) _ANSI_ARGS_((void)); /* 341 */ - void (*tcl_SetDefaultEncodingDir) _ANSI_ARGS_((char * path)); /* 342 */ + CONST84_RETURN char * (*tcl_GetDefaultEncodingDir) _ANSI_ARGS_((void)); /* 341 */ + void (*tcl_SetDefaultEncodingDir) _ANSI_ARGS_((CONST char * path)); /* 342 */ void (*tcl_AlertNotifier) _ANSI_ARGS_((ClientData clientData)); /* 343 */ void (*tcl_ServiceModeHook) _ANSI_ARGS_((int mode)); /* 344 */ int (*tcl_UniCharIsAlnum) _ANSI_ARGS_((int ch)); /* 345 */ @@ -1699,19 +1975,19 @@ typedef struct TclStubs { int (*tcl_UniCharIsSpace) _ANSI_ARGS_((int ch)); /* 349 */ int (*tcl_UniCharIsUpper) _ANSI_ARGS_((int ch)); /* 350 */ int (*tcl_UniCharIsWordChar) _ANSI_ARGS_((int ch)); /* 351 */ - int (*tcl_UniCharLen) _ANSI_ARGS_((Tcl_UniChar * str)); /* 352 */ + int (*tcl_UniCharLen) _ANSI_ARGS_((CONST Tcl_UniChar * str)); /* 352 */ int (*tcl_UniCharNcmp) _ANSI_ARGS_((CONST Tcl_UniChar * cs, CONST Tcl_UniChar * ct, unsigned long n)); /* 353 */ char * (*tcl_UniCharToUtfDString) _ANSI_ARGS_((CONST Tcl_UniChar * string, int numChars, Tcl_DString * dsPtr)); /* 354 */ Tcl_UniChar * (*tcl_UtfToUniCharDString) _ANSI_ARGS_((CONST char * string, int length, Tcl_DString * dsPtr)); /* 355 */ Tcl_RegExp (*tcl_GetRegExpFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * patObj, int flags)); /* 356 */ Tcl_Obj * (*tcl_EvalTokens) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Token * tokenPtr, int count)); /* 357 */ void (*tcl_FreeParse) _ANSI_ARGS_((Tcl_Parse * parsePtr)); /* 358 */ - void (*tcl_LogCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, char * script, char * command, int length)); /* 359 */ - int (*tcl_ParseBraces) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int numBytes, Tcl_Parse * parsePtr, int append, char ** termPtr)); /* 360 */ - int (*tcl_ParseCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int numBytes, int nested, Tcl_Parse * parsePtr)); /* 361 */ - int (*tcl_ParseExpr) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int numBytes, Tcl_Parse * parsePtr)); /* 362 */ - int (*tcl_ParseQuotedString) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int numBytes, Tcl_Parse * parsePtr, int append, char ** termPtr)); /* 363 */ - int (*tcl_ParseVarName) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int numBytes, Tcl_Parse * parsePtr, int append)); /* 364 */ + void (*tcl_LogCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * script, CONST char * command, int length)); /* 359 */ + int (*tcl_ParseBraces) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, Tcl_Parse * parsePtr, int append, CONST84 char ** termPtr)); /* 360 */ + int (*tcl_ParseCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, int nested, Tcl_Parse * parsePtr)); /* 361 */ + int (*tcl_ParseExpr) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, Tcl_Parse * parsePtr)); /* 362 */ + int (*tcl_ParseQuotedString) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, Tcl_Parse * parsePtr, int append, CONST84 char ** termPtr)); /* 363 */ + int (*tcl_ParseVarName) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, Tcl_Parse * parsePtr, int append)); /* 364 */ char * (*tcl_GetCwd) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * cwdPtr)); /* 365 */ int (*tcl_Chdir) _ANSI_ARGS_((CONST char * dirName)); /* 366 */ int (*tcl_Access) _ANSI_ARGS_((CONST char * path, int mode)); /* 367 */ @@ -1725,27 +2001,27 @@ typedef struct TclStubs { int (*tcl_UniCharIsPunct) _ANSI_ARGS_((int ch)); /* 375 */ int (*tcl_RegExpExecObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_RegExp regexp, Tcl_Obj * objPtr, int offset, int nmatches, int flags)); /* 376 */ void (*tcl_RegExpGetInfo) _ANSI_ARGS_((Tcl_RegExp regexp, Tcl_RegExpInfo * infoPtr)); /* 377 */ - Tcl_Obj * (*tcl_NewUnicodeObj) _ANSI_ARGS_((Tcl_UniChar * unicode, int numChars)); /* 378 */ - void (*tcl_SetUnicodeObj) _ANSI_ARGS_((Tcl_Obj * objPtr, Tcl_UniChar * unicode, int numChars)); /* 379 */ + Tcl_Obj * (*tcl_NewUnicodeObj) _ANSI_ARGS_((CONST Tcl_UniChar * unicode, int numChars)); /* 378 */ + void (*tcl_SetUnicodeObj) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST Tcl_UniChar * unicode, int numChars)); /* 379 */ int (*tcl_GetCharLength) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 380 */ Tcl_UniChar (*tcl_GetUniChar) _ANSI_ARGS_((Tcl_Obj * objPtr, int index)); /* 381 */ Tcl_UniChar * (*tcl_GetUnicode) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 382 */ Tcl_Obj * (*tcl_GetRange) _ANSI_ARGS_((Tcl_Obj * objPtr, int first, int last)); /* 383 */ - void (*tcl_AppendUnicodeToObj) _ANSI_ARGS_((Tcl_Obj * objPtr, Tcl_UniChar * unicode, int length)); /* 384 */ + void (*tcl_AppendUnicodeToObj) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST Tcl_UniChar * unicode, int length)); /* 384 */ int (*tcl_RegExpMatchObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * stringObj, Tcl_Obj * patternObj)); /* 385 */ void (*tcl_SetNotifier) _ANSI_ARGS_((Tcl_NotifierProcs * notifierProcPtr)); /* 386 */ Tcl_Mutex * (*tcl_GetAllocMutex) _ANSI_ARGS_((void)); /* 387 */ int (*tcl_GetChannelNames) _ANSI_ARGS_((Tcl_Interp * interp)); /* 388 */ - int (*tcl_GetChannelNamesEx) _ANSI_ARGS_((Tcl_Interp * interp, char * pattern)); /* 389 */ + int (*tcl_GetChannelNamesEx) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * pattern)); /* 389 */ int (*tcl_ProcObjCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 390 */ void (*tcl_ConditionFinalize) _ANSI_ARGS_((Tcl_Condition * condPtr)); /* 391 */ void (*tcl_MutexFinalize) _ANSI_ARGS_((Tcl_Mutex * mutex)); /* 392 */ int (*tcl_CreateThread) _ANSI_ARGS_((Tcl_ThreadId * idPtr, Tcl_ThreadCreateProc proc, ClientData clientData, int stackSize, int flags)); /* 393 */ int (*tcl_ReadRaw) _ANSI_ARGS_((Tcl_Channel chan, char * dst, int bytesToRead)); /* 394 */ - int (*tcl_WriteRaw) _ANSI_ARGS_((Tcl_Channel chan, char * src, int srcLen)); /* 395 */ + int (*tcl_WriteRaw) _ANSI_ARGS_((Tcl_Channel chan, CONST char * src, int srcLen)); /* 395 */ Tcl_Channel (*tcl_GetTopChannel) _ANSI_ARGS_((Tcl_Channel chan)); /* 396 */ int (*tcl_ChannelBuffered) _ANSI_ARGS_((Tcl_Channel chan)); /* 397 */ - char * (*tcl_ChannelName) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 398 */ + CONST84_RETURN char * (*tcl_ChannelName) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 398 */ Tcl_ChannelTypeVersion (*tcl_ChannelVersion) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 399 */ Tcl_DriverBlockModeProc * (*tcl_ChannelBlockModeProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 400 */ Tcl_DriverCloseProc * (*tcl_ChannelCloseProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 401 */ @@ -1759,6 +2035,88 @@ typedef struct TclStubs { Tcl_DriverGetHandleProc * (*tcl_ChannelGetHandleProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 409 */ Tcl_DriverFlushProc * (*tcl_ChannelFlushProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 410 */ Tcl_DriverHandlerProc * (*tcl_ChannelHandlerProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 411 */ + int (*tcl_JoinThread) _ANSI_ARGS_((Tcl_ThreadId id, int* result)); /* 412 */ + int (*tcl_IsChannelShared) _ANSI_ARGS_((Tcl_Channel channel)); /* 413 */ + int (*tcl_IsChannelRegistered) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Channel channel)); /* 414 */ + void (*tcl_CutChannel) _ANSI_ARGS_((Tcl_Channel channel)); /* 415 */ + void (*tcl_SpliceChannel) _ANSI_ARGS_((Tcl_Channel channel)); /* 416 */ + void (*tcl_ClearChannelHandlers) _ANSI_ARGS_((Tcl_Channel channel)); /* 417 */ + int (*tcl_IsChannelExisting) _ANSI_ARGS_((CONST char* channelName)); /* 418 */ + int (*tcl_UniCharNcasecmp) _ANSI_ARGS_((CONST Tcl_UniChar * cs, CONST Tcl_UniChar * ct, unsigned long n)); /* 419 */ + int (*tcl_UniCharCaseMatch) _ANSI_ARGS_((CONST Tcl_UniChar * ustr, CONST Tcl_UniChar * pattern, int nocase)); /* 420 */ + Tcl_HashEntry * (*tcl_FindHashEntry) _ANSI_ARGS_((Tcl_HashTable * tablePtr, CONST char * key)); /* 421 */ + Tcl_HashEntry * (*tcl_CreateHashEntry) _ANSI_ARGS_((Tcl_HashTable * tablePtr, CONST char * key, int * newPtr)); /* 422 */ + void (*tcl_InitCustomHashTable) _ANSI_ARGS_((Tcl_HashTable * tablePtr, int keyType, Tcl_HashKeyType * typePtr)); /* 423 */ + void (*tcl_InitObjHashTable) _ANSI_ARGS_((Tcl_HashTable * tablePtr)); /* 424 */ + ClientData (*tcl_CommandTraceInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_CommandTraceProc * procPtr, ClientData prevClientData)); /* 425 */ + int (*tcl_TraceCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_CommandTraceProc * proc, ClientData clientData)); /* 426 */ + void (*tcl_UntraceCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_CommandTraceProc * proc, ClientData clientData)); /* 427 */ + char * (*tcl_AttemptAlloc) _ANSI_ARGS_((unsigned int size)); /* 428 */ + char * (*tcl_AttemptDbCkalloc) _ANSI_ARGS_((unsigned int size, CONST char * file, int line)); /* 429 */ + char * (*tcl_AttemptRealloc) _ANSI_ARGS_((char * ptr, unsigned int size)); /* 430 */ + char * (*tcl_AttemptDbCkrealloc) _ANSI_ARGS_((char * ptr, unsigned int size, CONST char * file, int line)); /* 431 */ + int (*tcl_AttemptSetObjLength) _ANSI_ARGS_((Tcl_Obj * objPtr, int length)); /* 432 */ + Tcl_ThreadId (*tcl_GetChannelThread) _ANSI_ARGS_((Tcl_Channel channel)); /* 433 */ + Tcl_UniChar * (*tcl_GetUnicodeFromObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int * lengthPtr)); /* 434 */ + int (*tcl_GetMathFuncInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, int * numArgsPtr, Tcl_ValueType ** argTypesPtr, Tcl_MathProc ** procPtr, ClientData * clientDataPtr)); /* 435 */ + Tcl_Obj * (*tcl_ListMathFuncs) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * pattern)); /* 436 */ + Tcl_Obj * (*tcl_SubstObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int flags)); /* 437 */ + int (*tcl_DetachChannel) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Channel channel)); /* 438 */ + int (*tcl_IsStandardChannel) _ANSI_ARGS_((Tcl_Channel channel)); /* 439 */ + int (*tcl_FSCopyFile) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr)); /* 440 */ + int (*tcl_FSCopyDirectory) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr, Tcl_Obj ** errorPtr)); /* 441 */ + int (*tcl_FSCreateDirectory) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 442 */ + int (*tcl_FSDeleteFile) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 443 */ + int (*tcl_FSLoadFile) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * pathPtr, CONST char * sym1, CONST char * sym2, Tcl_PackageInitProc ** proc1Ptr, Tcl_PackageInitProc ** proc2Ptr, Tcl_LoadHandle * handlePtr, Tcl_FSUnloadFileProc ** unloadProcPtr)); /* 444 */ + int (*tcl_FSMatchInDirectory) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * result, Tcl_Obj * pathPtr, CONST char * pattern, Tcl_GlobTypeData * types)); /* 445 */ + Tcl_Obj * (*tcl_FSLink) _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_Obj * toPtr, int linkAction)); /* 446 */ + int (*tcl_FSRemoveDirectory) _ANSI_ARGS_((Tcl_Obj * pathPtr, int recursive, Tcl_Obj ** errorPtr)); /* 447 */ + int (*tcl_FSRenameFile) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr)); /* 448 */ + int (*tcl_FSLstat) _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_StatBuf * buf)); /* 449 */ + int (*tcl_FSUtime) _ANSI_ARGS_((Tcl_Obj * pathPtr, struct utimbuf * tval)); /* 450 */ + int (*tcl_FSFileAttrsGet) _ANSI_ARGS_((Tcl_Interp * interp, int index, Tcl_Obj * pathPtr, Tcl_Obj ** objPtrRef)); /* 451 */ + int (*tcl_FSFileAttrsSet) _ANSI_ARGS_((Tcl_Interp * interp, int index, Tcl_Obj * pathPtr, Tcl_Obj * objPtr)); /* 452 */ + CONST char ** (*tcl_FSFileAttrStrings) _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_Obj ** objPtrRef)); /* 453 */ + int (*tcl_FSStat) _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_StatBuf * buf)); /* 454 */ + int (*tcl_FSAccess) _ANSI_ARGS_((Tcl_Obj * pathPtr, int mode)); /* 455 */ + Tcl_Channel (*tcl_FSOpenFileChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * pathPtr, CONST char * modeString, int permissions)); /* 456 */ + Tcl_Obj* (*tcl_FSGetCwd) _ANSI_ARGS_((Tcl_Interp * interp)); /* 457 */ + int (*tcl_FSChdir) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 458 */ + int (*tcl_FSConvertToPathType) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * pathPtr)); /* 459 */ + Tcl_Obj* (*tcl_FSJoinPath) _ANSI_ARGS_((Tcl_Obj * listObj, int elements)); /* 460 */ + Tcl_Obj* (*tcl_FSSplitPath) _ANSI_ARGS_((Tcl_Obj* pathPtr, int * lenPtr)); /* 461 */ + int (*tcl_FSEqualPaths) _ANSI_ARGS_((Tcl_Obj* firstPtr, Tcl_Obj* secondPtr)); /* 462 */ + Tcl_Obj* (*tcl_FSGetNormalizedPath) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj* pathObjPtr)); /* 463 */ + Tcl_Obj* (*tcl_FSJoinToPath) _ANSI_ARGS_((Tcl_Obj * basePtr, int objc, Tcl_Obj *CONST objv[])); /* 464 */ + ClientData (*tcl_FSGetInternalRep) _ANSI_ARGS_((Tcl_Obj* pathObjPtr, Tcl_Filesystem * fsPtr)); /* 465 */ + Tcl_Obj* (*tcl_FSGetTranslatedPath) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj* pathPtr)); /* 466 */ + int (*tcl_FSEvalFile) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * fileName)); /* 467 */ + Tcl_Obj* (*tcl_FSNewNativePath) _ANSI_ARGS_((Tcl_Filesystem* fromFilesystem, ClientData clientData)); /* 468 */ + CONST char* (*tcl_FSGetNativePath) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 469 */ + Tcl_Obj* (*tcl_FSFileSystemInfo) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 470 */ + Tcl_Obj* (*tcl_FSPathSeparator) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 471 */ + Tcl_Obj* (*tcl_FSListVolumes) _ANSI_ARGS_((void)); /* 472 */ + int (*tcl_FSRegister) _ANSI_ARGS_((ClientData clientData, Tcl_Filesystem * fsPtr)); /* 473 */ + int (*tcl_FSUnregister) _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); /* 474 */ + ClientData (*tcl_FSData) _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); /* 475 */ + CONST char* (*tcl_FSGetTranslatedStringPath) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj* pathPtr)); /* 476 */ + Tcl_Filesystem* (*tcl_FSGetFileSystemForPath) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 477 */ + Tcl_PathType (*tcl_FSGetPathType) _ANSI_ARGS_((Tcl_Obj * pathObjPtr)); /* 478 */ + int (*tcl_OutputBuffered) _ANSI_ARGS_((Tcl_Channel chan)); /* 479 */ + void (*tcl_FSMountsChanged) _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); /* 480 */ + int (*tcl_EvalTokensStandard) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Token * tokenPtr, int count)); /* 481 */ + void (*tcl_GetTime) _ANSI_ARGS_((Tcl_Time* timeBuf)); /* 482 */ + Tcl_Trace (*tcl_CreateObjTrace) _ANSI_ARGS_((Tcl_Interp* interp, int level, int flags, Tcl_CmdObjTraceProc* objProc, ClientData clientData, Tcl_CmdObjTraceDeleteProc* delProc)); /* 483 */ + int (*tcl_GetCommandInfoFromToken) _ANSI_ARGS_((Tcl_Command token, Tcl_CmdInfo* infoPtr)); /* 484 */ + int (*tcl_SetCommandInfoFromToken) _ANSI_ARGS_((Tcl_Command token, CONST Tcl_CmdInfo* infoPtr)); /* 485 */ + Tcl_Obj * (*tcl_DbNewWideIntObj) _ANSI_ARGS_((Tcl_WideInt wideValue, CONST char * file, int line)); /* 486 */ + int (*tcl_GetWideIntFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_WideInt * widePtr)); /* 487 */ + Tcl_Obj * (*tcl_NewWideIntObj) _ANSI_ARGS_((Tcl_WideInt wideValue)); /* 488 */ + void (*tcl_SetWideIntObj) _ANSI_ARGS_((Tcl_Obj * objPtr, Tcl_WideInt wideValue)); /* 489 */ + Tcl_StatBuf * (*tcl_AllocStatBuf) _ANSI_ARGS_((void)); /* 490 */ + Tcl_WideInt (*tcl_Seek) _ANSI_ARGS_((Tcl_Channel chan, Tcl_WideInt offset, int mode)); /* 491 */ + Tcl_WideInt (*tcl_Tell) _ANSI_ARGS_((Tcl_Channel chan)); /* 492 */ + Tcl_DriverWideSeekProc * (*tcl_ChannelWideSeekProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 493 */ } TclStubs; #ifdef __cplusplus @@ -2682,9 +3040,9 @@ extern TclStubs *tclStubsPtr; #define Tcl_ScanCountedElement \ (tclStubsPtr->tcl_ScanCountedElement) /* 219 */ #endif -#ifndef Tcl_Seek -#define Tcl_Seek \ - (tclStubsPtr->tcl_Seek) /* 220 */ +#ifndef Tcl_SeekOld +#define Tcl_SeekOld \ + (tclStubsPtr->tcl_SeekOld) /* 220 */ #endif #ifndef Tcl_ServiceAll #define Tcl_ServiceAll \ @@ -2786,9 +3144,9 @@ extern TclStubs *tclStubsPtr; #define Tcl_StringMatch \ (tclStubsPtr->tcl_StringMatch) /* 245 */ #endif -#ifndef Tcl_Tell -#define Tcl_Tell \ - (tclStubsPtr->tcl_Tell) /* 246 */ +#ifndef Tcl_TellOld +#define Tcl_TellOld \ + (tclStubsPtr->tcl_TellOld) /* 246 */ #endif #ifndef Tcl_TraceVar #define Tcl_TraceVar \ @@ -2914,18 +3272,10 @@ extern TclStubs *tclStubsPtr; #define Tcl_WaitPid \ (tclStubsPtr->tcl_WaitPid) /* 277 */ #endif -#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ -#ifndef Tcl_PanicVA -#define Tcl_PanicVA \ - (tclStubsPtr->tcl_PanicVA) /* 278 */ -#endif -#endif /* UNIX */ -#ifdef __WIN32__ #ifndef Tcl_PanicVA #define Tcl_PanicVA \ (tclStubsPtr->tcl_PanicVA) /* 278 */ #endif -#endif /* __WIN32__ */ #ifndef Tcl_GetVersion #define Tcl_GetVersion \ (tclStubsPtr->tcl_GetVersion) /* 279 */ @@ -2946,7 +3296,10 @@ extern TclStubs *tclStubsPtr; #define Tcl_GetStackedChannel \ (tclStubsPtr->tcl_GetStackedChannel) /* 283 */ #endif -/* Slot 284 is reserved */ +#ifndef Tcl_SetMainLoop +#define Tcl_SetMainLoop \ + (tclStubsPtr->tcl_SetMainLoop) /* 284 */ +#endif /* Slot 285 is reserved */ #ifndef Tcl_AppendObjToObj #define Tcl_AppendObjToObj \ @@ -3452,6 +3805,334 @@ extern TclStubs *tclStubsPtr; #define Tcl_ChannelHandlerProc \ (tclStubsPtr->tcl_ChannelHandlerProc) /* 411 */ #endif +#ifndef Tcl_JoinThread +#define Tcl_JoinThread \ + (tclStubsPtr->tcl_JoinThread) /* 412 */ +#endif +#ifndef Tcl_IsChannelShared +#define Tcl_IsChannelShared \ + (tclStubsPtr->tcl_IsChannelShared) /* 413 */ +#endif +#ifndef Tcl_IsChannelRegistered +#define Tcl_IsChannelRegistered \ + (tclStubsPtr->tcl_IsChannelRegistered) /* 414 */ +#endif +#ifndef Tcl_CutChannel +#define Tcl_CutChannel \ + (tclStubsPtr->tcl_CutChannel) /* 415 */ +#endif +#ifndef Tcl_SpliceChannel +#define Tcl_SpliceChannel \ + (tclStubsPtr->tcl_SpliceChannel) /* 416 */ +#endif +#ifndef Tcl_ClearChannelHandlers +#define Tcl_ClearChannelHandlers \ + (tclStubsPtr->tcl_ClearChannelHandlers) /* 417 */ +#endif +#ifndef Tcl_IsChannelExisting +#define Tcl_IsChannelExisting \ + (tclStubsPtr->tcl_IsChannelExisting) /* 418 */ +#endif +#ifndef Tcl_UniCharNcasecmp +#define Tcl_UniCharNcasecmp \ + (tclStubsPtr->tcl_UniCharNcasecmp) /* 419 */ +#endif +#ifndef Tcl_UniCharCaseMatch +#define Tcl_UniCharCaseMatch \ + (tclStubsPtr->tcl_UniCharCaseMatch) /* 420 */ +#endif +#ifndef Tcl_FindHashEntry +#define Tcl_FindHashEntry \ + (tclStubsPtr->tcl_FindHashEntry) /* 421 */ +#endif +#ifndef Tcl_CreateHashEntry +#define Tcl_CreateHashEntry \ + (tclStubsPtr->tcl_CreateHashEntry) /* 422 */ +#endif +#ifndef Tcl_InitCustomHashTable +#define Tcl_InitCustomHashTable \ + (tclStubsPtr->tcl_InitCustomHashTable) /* 423 */ +#endif +#ifndef Tcl_InitObjHashTable +#define Tcl_InitObjHashTable \ + (tclStubsPtr->tcl_InitObjHashTable) /* 424 */ +#endif +#ifndef Tcl_CommandTraceInfo +#define Tcl_CommandTraceInfo \ + (tclStubsPtr->tcl_CommandTraceInfo) /* 425 */ +#endif +#ifndef Tcl_TraceCommand +#define Tcl_TraceCommand \ + (tclStubsPtr->tcl_TraceCommand) /* 426 */ +#endif +#ifndef Tcl_UntraceCommand +#define Tcl_UntraceCommand \ + (tclStubsPtr->tcl_UntraceCommand) /* 427 */ +#endif +#ifndef Tcl_AttemptAlloc +#define Tcl_AttemptAlloc \ + (tclStubsPtr->tcl_AttemptAlloc) /* 428 */ +#endif +#ifndef Tcl_AttemptDbCkalloc +#define Tcl_AttemptDbCkalloc \ + (tclStubsPtr->tcl_AttemptDbCkalloc) /* 429 */ +#endif +#ifndef Tcl_AttemptRealloc +#define Tcl_AttemptRealloc \ + (tclStubsPtr->tcl_AttemptRealloc) /* 430 */ +#endif +#ifndef Tcl_AttemptDbCkrealloc +#define Tcl_AttemptDbCkrealloc \ + (tclStubsPtr->tcl_AttemptDbCkrealloc) /* 431 */ +#endif +#ifndef Tcl_AttemptSetObjLength +#define Tcl_AttemptSetObjLength \ + (tclStubsPtr->tcl_AttemptSetObjLength) /* 432 */ +#endif +#ifndef Tcl_GetChannelThread +#define Tcl_GetChannelThread \ + (tclStubsPtr->tcl_GetChannelThread) /* 433 */ +#endif +#ifndef Tcl_GetUnicodeFromObj +#define Tcl_GetUnicodeFromObj \ + (tclStubsPtr->tcl_GetUnicodeFromObj) /* 434 */ +#endif +#ifndef Tcl_GetMathFuncInfo +#define Tcl_GetMathFuncInfo \ + (tclStubsPtr->tcl_GetMathFuncInfo) /* 435 */ +#endif +#ifndef Tcl_ListMathFuncs +#define Tcl_ListMathFuncs \ + (tclStubsPtr->tcl_ListMathFuncs) /* 436 */ +#endif +#ifndef Tcl_SubstObj +#define Tcl_SubstObj \ + (tclStubsPtr->tcl_SubstObj) /* 437 */ +#endif +#ifndef Tcl_DetachChannel +#define Tcl_DetachChannel \ + (tclStubsPtr->tcl_DetachChannel) /* 438 */ +#endif +#ifndef Tcl_IsStandardChannel +#define Tcl_IsStandardChannel \ + (tclStubsPtr->tcl_IsStandardChannel) /* 439 */ +#endif +#ifndef Tcl_FSCopyFile +#define Tcl_FSCopyFile \ + (tclStubsPtr->tcl_FSCopyFile) /* 440 */ +#endif +#ifndef Tcl_FSCopyDirectory +#define Tcl_FSCopyDirectory \ + (tclStubsPtr->tcl_FSCopyDirectory) /* 441 */ +#endif +#ifndef Tcl_FSCreateDirectory +#define Tcl_FSCreateDirectory \ + (tclStubsPtr->tcl_FSCreateDirectory) /* 442 */ +#endif +#ifndef Tcl_FSDeleteFile +#define Tcl_FSDeleteFile \ + (tclStubsPtr->tcl_FSDeleteFile) /* 443 */ +#endif +#ifndef Tcl_FSLoadFile +#define Tcl_FSLoadFile \ + (tclStubsPtr->tcl_FSLoadFile) /* 444 */ +#endif +#ifndef Tcl_FSMatchInDirectory +#define Tcl_FSMatchInDirectory \ + (tclStubsPtr->tcl_FSMatchInDirectory) /* 445 */ +#endif +#ifndef Tcl_FSLink +#define Tcl_FSLink \ + (tclStubsPtr->tcl_FSLink) /* 446 */ +#endif +#ifndef Tcl_FSRemoveDirectory +#define Tcl_FSRemoveDirectory \ + (tclStubsPtr->tcl_FSRemoveDirectory) /* 447 */ +#endif +#ifndef Tcl_FSRenameFile +#define Tcl_FSRenameFile \ + (tclStubsPtr->tcl_FSRenameFile) /* 448 */ +#endif +#ifndef Tcl_FSLstat +#define Tcl_FSLstat \ + (tclStubsPtr->tcl_FSLstat) /* 449 */ +#endif +#ifndef Tcl_FSUtime +#define Tcl_FSUtime \ + (tclStubsPtr->tcl_FSUtime) /* 450 */ +#endif +#ifndef Tcl_FSFileAttrsGet +#define Tcl_FSFileAttrsGet \ + (tclStubsPtr->tcl_FSFileAttrsGet) /* 451 */ +#endif +#ifndef Tcl_FSFileAttrsSet +#define Tcl_FSFileAttrsSet \ + (tclStubsPtr->tcl_FSFileAttrsSet) /* 452 */ +#endif +#ifndef Tcl_FSFileAttrStrings +#define Tcl_FSFileAttrStrings \ + (tclStubsPtr->tcl_FSFileAttrStrings) /* 453 */ +#endif +#ifndef Tcl_FSStat +#define Tcl_FSStat \ + (tclStubsPtr->tcl_FSStat) /* 454 */ +#endif +#ifndef Tcl_FSAccess +#define Tcl_FSAccess \ + (tclStubsPtr->tcl_FSAccess) /* 455 */ +#endif +#ifndef Tcl_FSOpenFileChannel +#define Tcl_FSOpenFileChannel \ + (tclStubsPtr->tcl_FSOpenFileChannel) /* 456 */ +#endif +#ifndef Tcl_FSGetCwd +#define Tcl_FSGetCwd \ + (tclStubsPtr->tcl_FSGetCwd) /* 457 */ +#endif +#ifndef Tcl_FSChdir +#define Tcl_FSChdir \ + (tclStubsPtr->tcl_FSChdir) /* 458 */ +#endif +#ifndef Tcl_FSConvertToPathType +#define Tcl_FSConvertToPathType \ + (tclStubsPtr->tcl_FSConvertToPathType) /* 459 */ +#endif +#ifndef Tcl_FSJoinPath +#define Tcl_FSJoinPath \ + (tclStubsPtr->tcl_FSJoinPath) /* 460 */ +#endif +#ifndef Tcl_FSSplitPath +#define Tcl_FSSplitPath \ + (tclStubsPtr->tcl_FSSplitPath) /* 461 */ +#endif +#ifndef Tcl_FSEqualPaths +#define Tcl_FSEqualPaths \ + (tclStubsPtr->tcl_FSEqualPaths) /* 462 */ +#endif +#ifndef Tcl_FSGetNormalizedPath +#define Tcl_FSGetNormalizedPath \ + (tclStubsPtr->tcl_FSGetNormalizedPath) /* 463 */ +#endif +#ifndef Tcl_FSJoinToPath +#define Tcl_FSJoinToPath \ + (tclStubsPtr->tcl_FSJoinToPath) /* 464 */ +#endif +#ifndef Tcl_FSGetInternalRep +#define Tcl_FSGetInternalRep \ + (tclStubsPtr->tcl_FSGetInternalRep) /* 465 */ +#endif +#ifndef Tcl_FSGetTranslatedPath +#define Tcl_FSGetTranslatedPath \ + (tclStubsPtr->tcl_FSGetTranslatedPath) /* 466 */ +#endif +#ifndef Tcl_FSEvalFile +#define Tcl_FSEvalFile \ + (tclStubsPtr->tcl_FSEvalFile) /* 467 */ +#endif +#ifndef Tcl_FSNewNativePath +#define Tcl_FSNewNativePath \ + (tclStubsPtr->tcl_FSNewNativePath) /* 468 */ +#endif +#ifndef Tcl_FSGetNativePath +#define Tcl_FSGetNativePath \ + (tclStubsPtr->tcl_FSGetNativePath) /* 469 */ +#endif +#ifndef Tcl_FSFileSystemInfo +#define Tcl_FSFileSystemInfo \ + (tclStubsPtr->tcl_FSFileSystemInfo) /* 470 */ +#endif +#ifndef Tcl_FSPathSeparator +#define Tcl_FSPathSeparator \ + (tclStubsPtr->tcl_FSPathSeparator) /* 471 */ +#endif +#ifndef Tcl_FSListVolumes +#define Tcl_FSListVolumes \ + (tclStubsPtr->tcl_FSListVolumes) /* 472 */ +#endif +#ifndef Tcl_FSRegister +#define Tcl_FSRegister \ + (tclStubsPtr->tcl_FSRegister) /* 473 */ +#endif +#ifndef Tcl_FSUnregister +#define Tcl_FSUnregister \ + (tclStubsPtr->tcl_FSUnregister) /* 474 */ +#endif +#ifndef Tcl_FSData +#define Tcl_FSData \ + (tclStubsPtr->tcl_FSData) /* 475 */ +#endif +#ifndef Tcl_FSGetTranslatedStringPath +#define Tcl_FSGetTranslatedStringPath \ + (tclStubsPtr->tcl_FSGetTranslatedStringPath) /* 476 */ +#endif +#ifndef Tcl_FSGetFileSystemForPath +#define Tcl_FSGetFileSystemForPath \ + (tclStubsPtr->tcl_FSGetFileSystemForPath) /* 477 */ +#endif +#ifndef Tcl_FSGetPathType +#define Tcl_FSGetPathType \ + (tclStubsPtr->tcl_FSGetPathType) /* 478 */ +#endif +#ifndef Tcl_OutputBuffered +#define Tcl_OutputBuffered \ + (tclStubsPtr->tcl_OutputBuffered) /* 479 */ +#endif +#ifndef Tcl_FSMountsChanged +#define Tcl_FSMountsChanged \ + (tclStubsPtr->tcl_FSMountsChanged) /* 480 */ +#endif +#ifndef Tcl_EvalTokensStandard +#define Tcl_EvalTokensStandard \ + (tclStubsPtr->tcl_EvalTokensStandard) /* 481 */ +#endif +#ifndef Tcl_GetTime +#define Tcl_GetTime \ + (tclStubsPtr->tcl_GetTime) /* 482 */ +#endif +#ifndef Tcl_CreateObjTrace +#define Tcl_CreateObjTrace \ + (tclStubsPtr->tcl_CreateObjTrace) /* 483 */ +#endif +#ifndef Tcl_GetCommandInfoFromToken +#define Tcl_GetCommandInfoFromToken \ + (tclStubsPtr->tcl_GetCommandInfoFromToken) /* 484 */ +#endif +#ifndef Tcl_SetCommandInfoFromToken +#define Tcl_SetCommandInfoFromToken \ + (tclStubsPtr->tcl_SetCommandInfoFromToken) /* 485 */ +#endif +#ifndef Tcl_DbNewWideIntObj +#define Tcl_DbNewWideIntObj \ + (tclStubsPtr->tcl_DbNewWideIntObj) /* 486 */ +#endif +#ifndef Tcl_GetWideIntFromObj +#define Tcl_GetWideIntFromObj \ + (tclStubsPtr->tcl_GetWideIntFromObj) /* 487 */ +#endif +#ifndef Tcl_NewWideIntObj +#define Tcl_NewWideIntObj \ + (tclStubsPtr->tcl_NewWideIntObj) /* 488 */ +#endif +#ifndef Tcl_SetWideIntObj +#define Tcl_SetWideIntObj \ + (tclStubsPtr->tcl_SetWideIntObj) /* 489 */ +#endif +#ifndef Tcl_AllocStatBuf +#define Tcl_AllocStatBuf \ + (tclStubsPtr->tcl_AllocStatBuf) /* 490 */ +#endif +#ifndef Tcl_Seek +#define Tcl_Seek \ + (tclStubsPtr->tcl_Seek) /* 491 */ +#endif +#ifndef Tcl_Tell +#define Tcl_Tell \ + (tclStubsPtr->tcl_Tell) /* 492 */ +#endif +#ifndef Tcl_ChannelWideSeekProc +#define Tcl_ChannelWideSeekProc \ + (tclStubsPtr->tcl_ChannelWideSeekProc) /* 493 */ +#endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ @@ -3459,4 +4140,3 @@ extern TclStubs *tclStubsPtr; #endif /* _TCLDECLS */ - diff --git a/tcl/generic/tclEncoding.c b/tcl/generic/tclEncoding.c index 8a43126c075..e97062a7eb1 100644 --- a/tcl/generic/tclEncoding.c +++ b/tcl/generic/tclEncoding.c @@ -310,18 +310,16 @@ TclFinalizeEncodingSubsystem() { Tcl_HashSearch search; Tcl_HashEntry *hPtr; - Encoding *encodingPtr; Tcl_MutexLock(&encodingMutex); encodingsInitialized = 0; hPtr = Tcl_FirstHashEntry(&encodingTable, &search); while (hPtr != NULL) { - encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr); - if (encodingPtr->freeProc != NULL) { - (*encodingPtr->freeProc)(encodingPtr->clientData); - } - ckfree((char *) encodingPtr->name); - ckfree((char *) encodingPtr); + /* + * Call FreeEncoding instead of doing it directly to handle refcounts + * like escape encodings use. [Bug #524674] + */ + FreeEncoding((Tcl_Encoding) Tcl_GetHashValue(hPtr)); hPtr = Tcl_NextHashEntry(&search); } Tcl_DeleteHashTable(&encodingTable); @@ -341,7 +339,7 @@ TclFinalizeEncodingSubsystem() *------------------------------------------------------------------------- */ -char * +CONST char * Tcl_GetDefaultEncodingDir() { return tclDefaultEncodingDir; @@ -362,7 +360,7 @@ Tcl_GetDefaultEncodingDir() void Tcl_SetDefaultEncodingDir(path) - char *path; + CONST char *path; { tclDefaultEncodingDir = (char *)ckalloc((unsigned) strlen(path) + 1); strcpy(tclDefaultEncodingDir, path); @@ -505,7 +503,7 @@ FreeEncoding(encoding) *--------------------------------------------------------------------------- */ -char * +CONST char * Tcl_GetEncodingName(encoding) Tcl_Encoding encoding; /* The encoding whose name to fetch. */ { @@ -563,20 +561,22 @@ Tcl_GetEncodingNames(interp) if (pathPtr != NULL) { int i, objc; Tcl_Obj **objv; - Tcl_DString pwdString; char globArgString[10]; - + Tcl_Obj* encodingObj = Tcl_NewStringObj("encoding",-1); + Tcl_IncrRefCount(encodingObj); + objc = 0; Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv); - Tcl_GetCwd(interp, &pwdString); - for (i = 0; i < objc; i++) { - char *string; - int j, objc2, length; - Tcl_Obj **objv2; - - string = Tcl_GetStringFromObj(objv[i], NULL); + Tcl_Obj *searchIn; + + /* + * Construct the path from the element of pathPtr, + * joined with 'encoding'. + */ + searchIn = Tcl_FSJoinToPath(objv[i],1,&encodingObj); + Tcl_IncrRefCount(searchIn); Tcl_ResetResult(interp); /* @@ -586,15 +586,22 @@ Tcl_GetEncodingNames(interp) */ strcpy(globArgString, "*.enc"); - if ((Tcl_Chdir(string) == 0) - && (Tcl_Chdir("encoding") == 0) - && (TclGlob(interp, globArgString, NULL, 0, NULL) == TCL_OK)) { - objc2 = 0; + /* + * The GLOBMODE_TAILS flag returns just the tail of each file + * which is the encoding name with a .enc extension + */ + if ((TclGlob(interp, globArgString, searchIn, + TCL_GLOBMODE_TAILS, NULL) == TCL_OK)) { + int objc2 = 0; + Tcl_Obj **objv2; + int j; Tcl_ListObjGetElements(NULL, Tcl_GetObjResult(interp), &objc2, &objv2); for (j = 0; j < objc2; j++) { + int length; + char *string; string = Tcl_GetStringFromObj(objv2[j], &length); length -= 4; if (length > 0) { @@ -604,9 +611,9 @@ Tcl_GetEncodingNames(interp) } } } - Tcl_Chdir(Tcl_DStringValue(&pwdString)); + Tcl_DecrRefCount(searchIn); } - Tcl_DStringFree(&pwdString); + Tcl_DecrRefCount(encodingObj); } /* @@ -828,7 +835,7 @@ Tcl_ExternalToUtfDString(encoding, src, srcLen, dstPtr) * * Tcl_ExternalToUtf -- * - * Convert a source buffer from the specified encoding into UTF-8, + * Convert a source buffer from the specified encoding into UTF-8. * * Results: * The return value is one of TCL_OK, TCL_CONVERT_MULTIBYTE, @@ -1271,19 +1278,25 @@ OpenEncodingFile(dir, name) CONST char *name; { - char *argv[3]; + CONST char *argv[3]; Tcl_DString pathString; - char *path; + CONST char *path; Tcl_Channel chan; + Tcl_Obj *pathPtr; - argv[0] = (char *) dir; + argv[0] = dir; argv[1] = "encoding"; - argv[2] = (char *) name; + argv[2] = name; Tcl_DStringInit(&pathString); Tcl_JoinPath(3, argv, &pathString); path = Tcl_DStringAppend(&pathString, ".enc", -1); - chan = Tcl_OpenFileChannel(NULL, path, "r", 0); + pathPtr = Tcl_NewStringObj(path,-1); + + Tcl_IncrRefCount(pathPtr); + chan = Tcl_FSOpenFileChannel(NULL, pathPtr, "r", 0); + Tcl_DecrRefCount(pathPtr); + Tcl_DStringFree(&pathString); return chan; @@ -1328,14 +1341,31 @@ LoadTableEncoding(interp, name, type, chan) TableEncodingData *dataPtr; unsigned short *pageMemPtr; Tcl_EncodingType encType; - char *hex; + + /* + * Speed over memory. Use a full 256 character table to decode hex + * sequences in the encoding files. + */ + static char staticHex[] = { - 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 0, 0, 0, 0, 0, 0, 0, - 10, 11, 12, 13, 14, 15 + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 0 ... 15 */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 16 ... 31 */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 32 ... 47 */ + 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 0, 0, 0, 0, 0, 0, /* 48 ... 63 */ + 0, 10, 11, 12, 13, 14, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 64 ... 79 */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 80 ... 95 */ + 0, 10, 11, 12, 13, 14, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 96 ... 111 */ + 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 0, 0, 0, 0, 0, 0, /* 112 ... 127 */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 128 ... 143 */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 144 ... 159 */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 160 ... 175 */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 176 ... 191 */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 192 ... 207 */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 208 ... 223 */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 224 ... 239 */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 240 ... 255 */ }; - hex = staticHex - '0'; - Tcl_DStringInit(&lineString); Tcl_Gets(chan, &lineString); line = Tcl_DStringValue(&lineString); @@ -1383,15 +1413,15 @@ LoadTableEncoding(interp, name, type, chan) Tcl_ReadChars(chan, objPtr, 3 + 16 * (16 * 4 + 1), 0); p = Tcl_GetString(objPtr); - hi = (hex[(int)p[0]] << 4) + hex[(int)p[1]]; + hi = (staticHex[(unsigned int)p[0]] << 4) + staticHex[(unsigned int)p[1]]; dataPtr->toUnicode[hi] = pageMemPtr; p += 2; for (lo = 0; lo < 256; lo++) { if ((lo & 0x0f) == 0) { p++; } - ch = (hex[(int)p[0]] << 12) + (hex[(int)p[1]] << 8) - + (hex[(int)p[2]] << 4) + hex[(int)p[3]]; + ch = (staticHex[(unsigned int)p[0]] << 12) + (staticHex[(unsigned int)p[1]] << 8) + + (staticHex[(unsigned int)p[2]] << 4) + staticHex[(unsigned int)p[3]]; if (ch != 0) { used[ch >> 8] = 1; } @@ -1510,7 +1540,6 @@ LoadTableEncoding(interp, name, type, chan) encType.nullSize = (type == ENCODING_DOUBLEBYTE) ? 2 : 1; encType.clientData = (ClientData) dataPtr; return Tcl_CreateEncoding(&encType); - } /* @@ -1553,7 +1582,7 @@ LoadEscapeEncoding(name, chan) while (1) { int argc; - char **argv; + CONST char **argv; char *line; Tcl_DString lineString; @@ -2175,6 +2204,10 @@ TableFreeProc(clientData) { TableEncodingData *dataPtr; + /* + * Make sure we aren't freeing twice on shutdown. [Bug #219314] + */ + dataPtr = (TableEncodingData *) clientData; ckfree((char *) dataPtr->toUnicode); ckfree((char *) dataPtr->fromUnicode); @@ -2460,12 +2493,14 @@ EscapeFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, dstStart = dst; dstEnd = dst + dstLen - 1; + /* + * RFC1468 states that the text starts in ASCII, and switches to Japanese + * characters, and that the text must end in ASCII. [Patch #474358] + */ + if (flags & TCL_ENCODING_START) { - unsigned int len; - state = 0; - len = dataPtr->subTables[0].sequenceLen; - if (dst + dataPtr->initLen + len > dstEnd) { + if (dst + dataPtr->initLen > dstEnd) { *srcReadPtr = 0; *dstWrotePtr = 0; return TCL_CONVERT_NOSPACE; @@ -2473,9 +2508,6 @@ EscapeFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, memcpy((VOID *) dst, (VOID *) dataPtr->init, (size_t) dataPtr->initLen); dst += dataPtr->initLen; - memcpy((VOID *) dst, (VOID *) dataPtr->subTables[0].sequence, - (size_t) len); - dst += len; } else { state = (int) *statePtr; } @@ -2530,14 +2562,28 @@ EscapeFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, tablePrefixBytes = tableDataPtr->prefixBytes; tableFromUnicode = tableDataPtr->fromUnicode; - subTablePtr = &dataPtr->subTables[state]; - if (dst + subTablePtr->sequenceLen > dstEnd) { - result = TCL_CONVERT_NOSPACE; - break; + /* + * The state variable has the value of oldState when word is 0. + * In this case, the escape sequense should not be copied to dst + * because the current character set is not changed. + */ + if (state != oldState) { + subTablePtr = &dataPtr->subTables[state]; + if ((dst + subTablePtr->sequenceLen) > dstEnd) { + /* + * If there is no space to write the escape sequence, the + * state variable must be changed to the value of oldState + * variable because this escape sequence must be written + * in the next conversion. + */ + state = oldState; + result = TCL_CONVERT_NOSPACE; + break; + } + memcpy((VOID *) dst, (VOID *) subTablePtr->sequence, + (size_t) subTablePtr->sequenceLen); + dst += subTablePtr->sequenceLen; } - memcpy((VOID *) dst, (VOID *) subTablePtr->sequence, - (size_t) subTablePtr->sequenceLen); - dst += subTablePtr->sequenceLen; } if (tablePrefixBytes[(word >> 8)] != 0) { @@ -2560,9 +2606,15 @@ EscapeFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, } if ((result == TCL_OK) && (flags & TCL_ENCODING_END)) { - if (dst + dataPtr->finalLen > dstEnd) { + unsigned int len = dataPtr->subTables[0].sequenceLen; + if (dst + dataPtr->finalLen + (state?len:0) > dstEnd) { result = TCL_CONVERT_NOSPACE; } else { + if (state) { + memcpy((VOID *) dst, (VOID *) dataPtr->subTables[0].sequence, + (size_t) len); + dst += len; + } memcpy((VOID *) dst, (VOID *) dataPtr->final, (size_t) dataPtr->finalLen); dst += dataPtr->finalLen; diff --git a/tcl/generic/tclEnv.c b/tcl/generic/tclEnv.c index 994bc292dbd..cc609bda6fe 100644 --- a/tcl/generic/tclEnv.c +++ b/tcl/generic/tclEnv.c @@ -20,28 +20,6 @@ TCL_DECLARE_MUTEX(envMutex) /* To serialize access to environ */ -/* CYGNUS LOCAL */ -#ifdef __CYGWIN32__ - -/* On cygwin32, the environment is imported from the cygwin32 DLL. */ - -__declspec(dllimport) extern char **__cygwin_environ; - -#define environ (__cygwin_environ) - -/* We need to use a special putenv function to handle PATH. */ -#ifndef USE_PUTENV -#define USE_PUTENV -#endif -#define putenv TclCygwin32Putenv -#endif -/* END CYGNUS LOCAL */ - -#ifdef TCL_THREADS - -static Tcl_Mutex envMutex; /* To serialize access to environ */ -#endif - static int cacheSize = 0; /* Number of env strings in environCache. */ static char **environCache = NULL; /* Array containing all of the environment @@ -68,18 +46,14 @@ char **environ = NULL; */ static char * EnvTraceProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, char *name1, char *name2, - int flags)); + Tcl_Interp *interp, CONST char *name1, + CONST char *name2, int flags)); static void ReplaceString _ANSI_ARGS_((CONST char *oldStr, char *newStr)); void TclSetEnv _ANSI_ARGS_((CONST char *name, CONST char *value)); void TclUnsetEnv _ANSI_ARGS_((CONST char *name)); -/* CYGNUS LOCAL */ -#ifdef __CYGWIN32__ -static void TclCygwin32Putenv _ANSI_ARGS_((CONST char *string)); -#endif /* *---------------------------------------------------------------------- @@ -200,7 +174,8 @@ TclSetEnv(name, value) { Tcl_DString envString; int index, length, nameLength; - char *p, *p2, *oldValue; + char *p, *oldValue; + CONST char *p2; /* * Figure out where the entry is going to go. If the name doesn't @@ -218,12 +193,6 @@ TclSetEnv(name, value) newEnviron = (char **) ckalloc((unsigned) ((length + 5) * sizeof(char *))); - - /* CYGNUS LOCAL: Added to avoid an error from Purify, - although I don't personally see where the error would - occur--ian. */ - memset((VOID *) newEnviron, 0, (length+5) * sizeof(char *)); - memcpy((VOID *) newEnviron, (VOID *) environ, length*sizeof(char *)); if (environSize != 0) { @@ -231,6 +200,12 @@ TclSetEnv(name, value) } environ = newEnviron; environSize = length + 5; +#if defined(__APPLE__) && defined(__DYNAMIC__) + { + char ***e = _NSGetEnviron(); + *e = environ; + } +#endif } index = length; environ[index + 1] = NULL; @@ -238,7 +213,7 @@ TclSetEnv(name, value) oldValue = NULL; nameLength = strlen(name); } else { - char *env; + CONST char *env; /* * Compare the new value to the existing value. If they're @@ -300,9 +275,23 @@ TclSetEnv(name, value) if ((index != -1) && (environ[index] == p)) { ReplaceString(oldValue, p); +#ifdef HAVE_PUTENV_THAT_COPIES + } else { + /* This putenv() copies instead of taking ownership */ + ckfree(p); +#endif } Tcl_MutexUnlock(&envMutex); + + if (!strcmp(name, "HOME")) { + /* + * If the user's home directory has changed, we must invalidate + * the filesystem cache, because '~' expansions will now be + * incorrect. + */ + Tcl_FSMountsChanged(NULL); + } } /* @@ -335,7 +324,8 @@ Tcl_PutEnv(string) { Tcl_DString nameString; int nameLength; - char *name, *value; + CONST char *name; + char *value; if (string == NULL) { return 0; @@ -388,7 +378,7 @@ TclUnsetEnv(name) CONST char *name; /* Name of variable to remove (UTF-8). */ { char *oldValue; - unsigned int length; + int length; int index; #ifdef USE_PUTENV Tcl_DString envString; @@ -475,7 +465,7 @@ TclUnsetEnv(name) *---------------------------------------------------------------------- */ -char * +CONST char * TclGetEnv(name, valuePtr) CONST char *name; /* Name of environment variable to find * (UTF-8). */ @@ -484,7 +474,7 @@ TclGetEnv(name, valuePtr) * stored. */ { int length, index; - char *result; + CONST char *result; Tcl_MutexLock(&envMutex); index = TclpFindVariable(name, &length); @@ -535,8 +525,8 @@ EnvTraceProc(clientData, interp, name1, name2, flags) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Interpreter whose "env" variable is * being modified. */ - char *name1; /* Better be "env". */ - char *name2; /* Name of variable being modified, or NULL + CONST char *name1; /* Better be "env". */ + CONST char *name2; /* Name of variable being modified, or NULL * if whole array is being deleted (UTF-8). */ int flags; /* Indicates what's happening. */ { @@ -562,7 +552,7 @@ EnvTraceProc(clientData, interp, name1, name2, flags) */ if (flags & TCL_TRACE_WRITES) { - char *value; + CONST char *value; value = Tcl_GetVar2(interp, "env", name2, TCL_GLOBAL_ONLY); TclSetEnv(name2, value); @@ -574,7 +564,7 @@ EnvTraceProc(clientData, interp, name1, name2, flags) if (flags & TCL_TRACE_READS) { Tcl_DString valueString; - char *value; + CONST char *value; value = TclGetEnv(name2, &valueString); if (value == NULL) { @@ -665,7 +655,7 @@ ReplaceString(oldStr, newStr) ckfree((char *) environCache); } environCache = newCache; - environCache[cacheSize] = (char *) newStr; + environCache[cacheSize] = newStr; environCache[cacheSize+1] = NULL; cacheSize += 5; } @@ -709,86 +699,3 @@ TclFinalizeEnvironment() #endif } } - -/* CYGNUS LOCAL */ -#ifdef __CYGWIN32__ - -/* When using cygwin32, when an environment variable changes, we need - to synch with both the cygwin32 environment (in case the - application C code calls fork) and the Windows environment (in case - the application TCL code calls exec, which calls the Windows - CreateProcess function). */ - -static void -TclCygwin32Putenv(str) - const char *str; -{ - char *name, *value; - - /* Get the name and value, so that we can change the environment - variable for Windows. */ - name = (char *) alloca (strlen (str) + 1); - strcpy (name, str); - for (value = name; *value != '=' && *value != '\0'; ++value) - ; - if (*value == '\0') - { - /* Can't happen. */ - return; - } - *value = '\0'; - ++value; - if (*value == '\0') - value = NULL; - - /* Set the cygwin32 environment variable. */ -#undef putenv - if (value == NULL) - unsetenv (name); - else - putenv(str); - - /* Before changing the environment variable in Windows, if this is - PATH, we need to convert the value back to a Windows style path. - - FIXME: The calling program may now it is running under windows, - and may have set the path to a Windows path, or, worse, appended - or prepended a Windows path to PATH. */ - if (strcmp (name, "PATH") != 0) - { - /* If this is Path, eliminate any PATH variable, to prevent any - confusion. */ - if (strcmp (name, "Path") == 0) - { - SetEnvironmentVariable ("PATH", (char *) NULL); - unsetenv ("PATH"); - } - - SetEnvironmentVariable (name, value); - } - else - { - char *buf; - - /* Eliminate any Path variable, to prevent any confusion. */ - SetEnvironmentVariable ("Path", (char *) NULL); - unsetenv ("Path"); - - if (value == NULL) - buf = NULL; - else - { - int size; - - size = cygwin32_posix_to_win32_path_list_buf_size (value); - buf = (char *) alloca (size + 1); - cygwin32_posix_to_win32_path_list (value, buf); - } - - SetEnvironmentVariable (name, buf); - } -} - -#endif /* __CYGWIN32__ */ -/* END CYGNUS LOCAL */ - diff --git a/tcl/generic/tclEvent.c b/tcl/generic/tclEvent.c index c4b16abdfce..d3351856489 100644 --- a/tcl/generic/tclEvent.c +++ b/tcl/generic/tclEvent.c @@ -99,6 +99,11 @@ typedef struct ThreadSpecificData { static Tcl_ThreadDataKey dataKey; /* + * Common string for the library path for sharing across threads. + */ +char *tclLibraryPathStr; + +/* * Prototypes for procedures referenced only in this file: */ @@ -106,8 +111,8 @@ static void BgErrorDeleteProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp)); static void HandleBgErrors _ANSI_ARGS_((ClientData clientData)); static char * VwaitVarProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, char *name1, char *name2, - int flags)); + Tcl_Interp *interp, CONST char *name1, + CONST char *name2, int flags)); /* *---------------------------------------------------------------------- @@ -135,7 +140,7 @@ Tcl_BackgroundError(interp) * occurred. */ { BgError *errPtr; - char *errResult, *varValue; + CONST char *errResult, *varValue; ErrAssocData *assocPtr; int length; @@ -217,7 +222,7 @@ HandleBgErrors(clientData) ClientData clientData; /* Pointer to ErrAssocData structure. */ { Tcl_Interp *interp; - char *argv[2]; + CONST char *argv[2]; int code; BgError *errPtr; ErrAssocData *assocPtr = (ErrAssocData *) clientData; @@ -285,7 +290,7 @@ HandleBgErrors(clientData) int len; string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &len); - if (strcmp(string, "\"bgerror\" is an invalid command name or ambiguous abbreviation") == 0) { + if (Tcl_FindCommand(interp, "bgerror", NULL, TCL_GLOBAL_ONLY) == NULL) { Tcl_WriteChars(errChannel, assocPtr->firstBgPtr->errorInfo, -1); Tcl_WriteChars(errChannel, "\n", -1); } else { @@ -596,6 +601,12 @@ TclSetLibraryPath(pathPtr) Tcl_DecrRefCount(tsdPtr->tclLibraryPath); } tsdPtr->tclLibraryPath = pathPtr; + + /* + * No mutex locking is needed here as up the stack we're within + * TclpInitLock(). + */ + tclLibraryPathStr = Tcl_GetStringFromObj(pathPtr, NULL); } /* @@ -619,6 +630,17 @@ Tcl_Obj * TclGetLibraryPath() { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + if (tsdPtr->tclLibraryPath == NULL) { + /* + * Grab the shared string and place it into a new thread specific + * Tcl_Obj. + */ + tsdPtr->tclLibraryPath = Tcl_NewStringObj(tclLibraryPathStr, -1); + + /* take ownership */ + Tcl_IncrRefCount(tsdPtr->tclLibraryPath); + } return tsdPtr->tclLibraryPath; } @@ -744,10 +766,11 @@ Tcl_Finalize() ThreadSpecificData *tsdPtr; TclpInitLock(); - tsdPtr = TCL_TSD_INIT(&dataKey); if (subsystemsInitialized != 0) { subsystemsInitialized = 0; + tsdPtr = TCL_TSD_INIT(&dataKey); + /* * Invoke exit handlers first. */ @@ -772,15 +795,6 @@ Tcl_Finalize() Tcl_MutexUnlock(&exitMutex); /* - * Clean up the library path now, before we invalidate thread-local - * storage. - */ - if (tsdPtr->tclLibraryPath != NULL) { - Tcl_DecrRefCount(tsdPtr->tclLibraryPath); - tsdPtr->tclLibraryPath = NULL; - } - - /* * Clean up after the current thread now, after exit handlers. * In particular, the testexithandler command sets up something * that writes to standard output, which gets closed. @@ -822,13 +836,12 @@ Tcl_Finalize() TclFinalizeSynchronization(); - /* - * We defer unloading of packages until very late - * to avoid memory access issues. Both exit callbacks and - * synchronization variables may be stored in packages. + /** + * Finalizing the filesystem must come after anything which + * might conceivably interact with the 'Tcl_FS' API. This + * will also unload any extensions which have been loaded. */ - - TclFinalizeLoad(); + TclFinalizeFilesystem(); /* * There shouldn't be any malloc'ed memory after this. @@ -870,6 +883,17 @@ Tcl_FinalizeThread() */ tsdPtr->inExit = 1; + + /* + * Clean up the library path now, before we invalidate thread-local + * storage or calling thread exit handlers. + */ + + if (tsdPtr->tclLibraryPath != NULL) { + Tcl_DecrRefCount(tsdPtr->tclLibraryPath); + tsdPtr->tclLibraryPath = NULL; + } + for (exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL; exitPtr = tsdPtr->firstExitPtr) { /* @@ -884,6 +908,7 @@ Tcl_FinalizeThread() } TclFinalizeIOSubsystem(); TclFinalizeNotifier(); + TclFinalizeAsync(); /* * Blow away all thread local storage blocks. @@ -912,8 +937,13 @@ Tcl_FinalizeThread() int TclInExit() { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - return tsdPtr->inExit; + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) + TclThreadDataKeyGet(&dataKey); + if (tsdPtr == NULL) { + return inFinalize; + } else { + return tsdPtr->inExit; + } } /* @@ -982,8 +1012,8 @@ static char * VwaitVarProc(clientData, interp, name1, name2, flags) ClientData clientData; /* Pointer to integer to set to 1. */ Tcl_Interp *interp; /* Interpreter containing variable. */ - char *name1; /* Name of variable. */ - char *name2; /* Second part of variable name. */ + CONST char *name1; /* Name of variable. */ + CONST char *name2; /* Second part of variable name. */ int flags; /* Information about what happened. */ { int *donePtr = (int *) clientData; @@ -1019,7 +1049,7 @@ Tcl_UpdateObjCmd(clientData, interp, objc, objv) { int optionIndex; int flags = 0; /* Initialized to avoid compiler warning. */ - static char *updateOptions[] = {"idletasks", (char *) NULL}; + static CONST char *updateOptions[] = {"idletasks", (char *) NULL}; enum updateOptions {REGEXP_IDLETASKS}; if (objc == 1) { @@ -1055,4 +1085,3 @@ Tcl_UpdateObjCmd(clientData, interp, objc, objv) Tcl_ResetResult(interp); return TCL_OK; } - diff --git a/tcl/generic/tclExecute.c b/tcl/generic/tclExecute.c index 95c0c9e04d5..d86a7c1e9c5 100644 --- a/tcl/generic/tclExecute.c +++ b/tcl/generic/tclExecute.c @@ -5,6 +5,8 @@ * 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. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -15,13 +17,8 @@ #include "tclInt.h" #include "tclCompile.h" -#ifdef NO_FLOAT_H -# include "../compat/float.h" -#else -# include <float.h> -#endif #ifndef TCL_NO_MATH -#include "tclMath.h" +# include "tclMath.h" #endif /* @@ -31,18 +28,40 @@ */ #ifndef TCL_GENERIC_ONLY -#include "tclPort.h" -#else -#define NO_ERRNO_H -#endif +# include "tclPort.h" +#else /* TCL_GENERIC_ONLY */ +# ifndef NO_FLOAT_H +# include <float.h> +# else /* NO_FLOAT_H */ +# ifndef NO_VALUES_H +# include <values.h> +# endif /* !NO_VALUES_H */ +# endif /* !NO_FLOAT_H */ +# define NO_ERRNO_H +#endif /* !TCL_GENERIC_ONLY */ #ifdef NO_ERRNO_H int errno; -#define EDOM 33 -#define ERANGE 34 +# define EDOM 33 +# define ERANGE 34 #endif /* + * Need DBL_MAX for IS_INF() macro... + */ +#ifndef DBL_MAX +# ifdef MAXDOUBLE +# define DBL_MAX MAXDOUBLE +# else /* !MAXDOUBLE */ +/* + * This value is from the Solaris headers, but doubles seem to be the + * same size everywhere. Long doubles aren't, but we don't use those. + */ +# define DBL_MAX 1.79769313486231570e+308 +# endif /* MAXDOUBLE */ +#endif /* !DBL_MAX */ + +/* * Boolean flag indicating whether the Tcl bytecode interpreter has been * initialized. */ @@ -50,6 +69,7 @@ int errno; static int execInitialized = 0; TCL_DECLARE_MUTEX(execMutex) +#ifdef TCL_COMPILE_DEBUG /* * Variable that controls whether execution tracing is enabled and, if so, * what level of tracing is desired: @@ -61,32 +81,6 @@ TCL_DECLARE_MUTEX(execMutex) */ int tclTraceExec = 0; - -typedef struct ThreadSpecificData { - /* - * The following global variable is use to signal matherr that Tcl - * is responsible for the arithmetic, so errors can be handled in a - * fashion appropriate for Tcl. Zero means no Tcl math is in - * progress; non-zero means Tcl is doing math. - */ - - int mathInProgress; - -} ThreadSpecificData; - -static Tcl_ThreadDataKey dataKey; - -/* - * The variable below serves no useful purpose except to generate - * a reference to matherr, so that the Tcl version of matherr is - * linked in rather than the system version. Without this reference - * the need for matherr won't be discovered during linking until after - * libtcl.a has been processed, so Tcl's version won't be used. - */ - -#ifdef NEED_MATHERR -extern int matherr(); -int (*tclMatherrPtr)() = matherr; #endif /* @@ -98,9 +92,10 @@ int (*tclMatherrPtr)() = matherr; static char *operatorStrings[] = { "||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>", "+", "-", "*", "/", "%", "+", "-", "~", "!", - "BUILTIN FUNCTION", "FUNCTION" + "BUILTIN FUNCTION", "FUNCTION", + "", "", "", "", "", "", "", "", "eq", "ne", }; - + /* * Mapping from Tcl result codes to strings; used for error and debugging * messages. @@ -113,26 +108,82 @@ static char *resultStrings[] = { #endif /* + * These are used by evalstats to monitor object usage in Tcl. + */ + +#ifdef TCL_COMPILE_STATS +long tclObjsAlloced = 0; +long tclObjsFreed = 0; +#define TCL_MAX_SHARED_OBJ_STATS 5 +long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; +#endif /* TCL_COMPILE_STATS */ + +/* * Macros for testing floating-point values for certain special cases. Test * for not-a-number by comparing a value against itself; test for infinity * by comparing against the largest floating-point value. */ #define IS_NAN(v) ((v) != (v)) -#ifdef DBL_MAX -# define IS_INF(v) (((v) > DBL_MAX) || ((v) < -DBL_MAX)) -#else -# define IS_INF(v) 0 -#endif +#define IS_INF(v) (((v) > DBL_MAX) || ((v) < -DBL_MAX)) /* - * Macro to adjust the program counter and restart the instruction execution - * loop after each instruction is executed. + * The new macro for ending an instruction; note that a + * reasonable C-optimiser will resolve all branches + * at compile time. (result) is always a constant; the macro + * NEXT_INST_F handles constant (nCleanup), NEXT_INST_V is + * resolved at runtime for variable (nCleanup). + * + * ARGUMENTS: + * pcAdjustment: how much to increment pc + * nCleanup: how many objects to remove from the stack + * result: 0 indicates no object should be pushed on the + * stack; otherwise, push objResultPtr. If (result < 0), + * objResultPtr already has the correct reference count. */ -#define ADJUST_PC(instBytes) \ - pc += (instBytes); \ - continue +#define NEXT_INST_F(pcAdjustment, nCleanup, result) \ + if (nCleanup == 0) {\ + if (result != 0) {\ + if ((result) > 0) {\ + PUSH_OBJECT(objResultPtr);\ + } else {\ + stackPtr[++stackTop] = objResultPtr;\ + }\ + } \ + pc += (pcAdjustment);\ + goto cleanup0;\ + } else if (result != 0) {\ + if ((result) > 0) {\ + Tcl_IncrRefCount(objResultPtr);\ + }\ + pc += (pcAdjustment);\ + switch (nCleanup) {\ + case 1: goto cleanup1_pushObjResultPtr;\ + case 2: goto cleanup2_pushObjResultPtr;\ + default: panic("ERROR: bad usage of macro NEXT_INST_F");\ + }\ + } else {\ + pc += (pcAdjustment);\ + switch (nCleanup) {\ + case 1: goto cleanup1;\ + case 2: goto cleanup2;\ + default: panic("ERROR: bad usage of macro NEXT_INST_F");\ + }\ + } + +#define NEXT_INST_V(pcAdjustment, nCleanup, result) \ + pc += (pcAdjustment);\ + cleanup = (nCleanup);\ + if (result) {\ + if ((result) > 0) {\ + Tcl_IncrRefCount(objResultPtr);\ + }\ + goto cleanupV_pushObjResultPtr;\ + } else {\ + goto cleanupV;\ + } + /* * Macros used to cache often-referenced Tcl evaluation stack information @@ -149,6 +200,7 @@ static char *resultStrings[] = { #define DECACHE_STACK_INFO() \ eePtr->stackTop = stackTop + /* * Macros used to access items on the Tcl evaluation stack. PUSH_OBJECT * increments the object's ref count since it makes the stack have another @@ -177,40 +229,130 @@ static char *resultStrings[] = { */ #ifdef TCL_COMPILE_DEBUG -#define TRACE(a) \ +# define TRACE(a) \ if (traceInstructions) { \ fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \ (unsigned int)(pc - codePtr->codeStart), \ GetOpcodeName(pc)); \ printf a; \ } -#define TRACE_WITH_OBJ(a, objPtr) \ +# define TRACE_APPEND(a) \ + if (traceInstructions) { \ + printf a; \ + } +# define TRACE_WITH_OBJ(a, objPtr) \ if (traceInstructions) { \ fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \ (unsigned int)(pc - codePtr->codeStart), \ GetOpcodeName(pc)); \ printf a; \ - TclPrintObject(stdout, (objPtr), 30); \ + TclPrintObject(stdout, objPtr, 30); \ fprintf(stdout, "\n"); \ } -#define O2S(objPtr) \ - Tcl_GetString(objPtr) -#else -#define TRACE(a) -#define TRACE_WITH_OBJ(a, objPtr) -#define O2S(objPtr) +# define O2S(objPtr) \ + (objPtr ? TclGetString(objPtr) : "") +#else /* !TCL_COMPILE_DEBUG */ +# define TRACE(a) +# define TRACE_APPEND(a) +# define TRACE_WITH_OBJ(a, objPtr) +# define O2S(objPtr) #endif /* TCL_COMPILE_DEBUG */ + +/* + * Most of the code to support working with wide values is factored + * out here because it greatly reduces the number of conditionals + * through the rest of the file. Note that this needs to be + * conditional because we do not want to alter Tcl's behaviour on + * native-64bit platforms... + */ + +#ifndef TCL_WIDE_INT_IS_LONG +#define W0 Tcl_LongAsWide(0) + +/* + * Macro to read a string containing either a wide or an int and + * decide which it is while decoding it at the same time. This + * enforces the policy that integer constants between LONG_MIN and + * LONG_MAX (inclusive) are represented by normal longs, and integer + * constants outside that range are represented by wide ints. + * + * GET_WIDE_OR_INT is the same as REQUIRE_WIDE_OR_INT except it never + * generates an error message. + */ +#define REQUIRE_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar) \ + (resultVar) = Tcl_GetWideIntFromObj(interp, (objPtr), &(wideVar)); \ + if ((resultVar) == TCL_OK && (wideVar) >= Tcl_LongAsWide(LONG_MIN) \ + && (wideVar) <= Tcl_LongAsWide(LONG_MAX)) { \ + (objPtr)->typePtr = &tclIntType; \ + (objPtr)->internalRep.longValue = (longVar) \ + = Tcl_WideAsLong(wideVar); \ + } +#define GET_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar) \ + (resultVar) = Tcl_GetWideIntFromObj((Tcl_Interp *) NULL, (objPtr), \ + &(wideVar)); \ + if ((resultVar) == TCL_OK && (wideVar) >= Tcl_LongAsWide(LONG_MIN) \ + && (wideVar) <= Tcl_LongAsWide(LONG_MAX)) { \ + (objPtr)->typePtr = &tclIntType; \ + (objPtr)->internalRep.longValue = (longVar) \ + = Tcl_WideAsLong(wideVar); \ + } +#define IS_INTEGER_TYPE(typePtr) \ + ((typePtr) == &tclIntType || (typePtr) == &tclWideIntType) +/* + * Extract a double value from a general numeric object. + */ +#define GET_DOUBLE_VALUE(doubleVar, objPtr, typePtr) \ + if ((typePtr) == &tclIntType) { \ + (doubleVar) = (double) (objPtr)->internalRep.longValue; \ + } else if ((typePtr) == &tclWideIntType) { \ + (doubleVar) = Tcl_WideAsDouble((objPtr)->internalRep.wideValue);\ + } else { \ + (doubleVar) = (objPtr)->internalRep.doubleValue; \ + } +/* + * Combined with REQUIRE_WIDE_OR_INT, this gets a long value from + * an obj. + */ +#define FORCE_LONG(objPtr, longVar, wideVar) \ + if ((objPtr)->typePtr == &tclWideIntType) { \ + (longVar) = Tcl_WideAsLong(wideVar); \ + } +/* + * For tracing that uses wide values. + */ +#define LLTRACE(a) TRACE(a) +#define LLTRACE_WITH_OBJ(a,b) TRACE_WITH_OBJ(a,b) +#define LLD "%" TCL_LL_MODIFIER "d" +#else /* TCL_WIDE_INT_IS_LONG */ +/* + * Versions of the above that do not use wide values. + */ +#define REQUIRE_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar) \ + (resultVar) = Tcl_GetLongFromObj(interp, (objPtr), &(longVar)); +#define GET_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar) \ + (resultVar) = Tcl_GetLongFromObj((Tcl_Interp *) NULL, (objPtr), \ + &(longVar)); +#define IS_INTEGER_TYPE(typePtr) ((typePtr) == &tclIntType) +#define GET_DOUBLE_VALUE(doubleVar, objPtr, typePtr) \ + if ((typePtr) == &tclIntType) { \ + (doubleVar) = (double) (objPtr)->internalRep.longValue; \ + } else { \ + (doubleVar) = (objPtr)->internalRep.doubleValue; \ + } +#define FORCE_LONG(objPtr, longVar, wideVar) +#define LLTRACE(a) +#define LLTRACE_WITH_OBJ(a,b) +#endif /* TCL_WIDE_INT_IS_LONG */ +#define IS_NUMERIC_TYPE(typePtr) \ + (IS_INTEGER_TYPE(typePtr) || (typePtr) == &tclDoubleType) + /* * Declarations for local procedures to this file: */ -static void CallTraceProcedure _ANSI_ARGS_((Tcl_Interp *interp, - Trace *tracePtr, Command *cmdPtr, - char *command, int numChars, - int objc, Tcl_Obj *objv[])); -static void DupCmdNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr, - Tcl_Obj *copyPtr)); +static int TclExecuteByteCode _ANSI_ARGS_((Tcl_Interp *interp, + ByteCode *codePtr)); static int ExprAbsFunc _ANSI_ARGS_((Tcl_Interp *interp, ExecEnv *eePtr, ClientData clientData)); static int ExprBinaryFunc _ANSI_ARGS_((Tcl_Interp *interp, @@ -229,12 +371,14 @@ static int ExprSrandFunc _ANSI_ARGS_((Tcl_Interp *interp, ExecEnv *eePtr, ClientData clientData)); static int ExprUnaryFunc _ANSI_ARGS_((Tcl_Interp *interp, ExecEnv *eePtr, ClientData clientData)); +#ifndef TCL_WIDE_INT_IS_LONG +static int ExprWideFunc _ANSI_ARGS_((Tcl_Interp *interp, + ExecEnv *eePtr, ClientData clientData)); +#endif #ifdef TCL_COMPILE_STATS static int EvalStatsCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); #endif -static void FreeCmdNameInternalRep _ANSI_ARGS_(( - Tcl_Obj *objPtr)); #ifdef TCL_COMPILE_DEBUG static char * GetOpcodeName _ANSI_ARGS_((unsigned char *pc)); #endif @@ -250,15 +394,10 @@ static void InitByteCodeExecution _ANSI_ARGS_(( Tcl_Interp *interp)); #ifdef TCL_COMPILE_DEBUG static void PrintByteCodeInfo _ANSI_ARGS_((ByteCode *codePtr)); -#endif -static int SetCmdNameFromAny _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr)); -#ifdef TCL_COMPILE_DEBUG static char * StringForResultCode _ANSI_ARGS_((int result)); static void ValidatePcAndStackTop _ANSI_ARGS_(( ByteCode *codePtr, unsigned char *pc, - int stackTop, int stackLowerBound, - int stackUpperBound)); + int stackTop, int stackLowerBound)); #endif static int VerifyExprObjType _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); @@ -269,7 +408,7 @@ static int VerifyExprObjType _ANSI_ARGS_((Tcl_Interp *interp, * operand byte. */ -BuiltinFunc builtinFuncTable[] = { +BuiltinFunc tclBuiltinFuncTable[] = { #ifndef TCL_NO_MATH {"acos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) acos}, {"asin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) asin}, @@ -297,24 +436,13 @@ BuiltinFunc builtinFuncTable[] = { {"rand", 0, {TCL_EITHER}, ExprRandFunc, 0}, /* NOTE: rand takes no args. */ {"round", 1, {TCL_EITHER}, ExprRoundFunc, 0}, {"srand", 1, {TCL_INT}, ExprSrandFunc, 0}, +#ifdef TCL_WIDE_INT_IS_LONG + {"wide", 1, {TCL_EITHER}, ExprIntFunc, 0}, +#else + {"wide", 1, {TCL_EITHER}, ExprWideFunc, 0}, +#endif /* TCL_WIDE_INT_IS_LONG */ {0}, }; - -/* - * The structure below defines the command name Tcl object type by means of - * procedures that can be invoked by generic object code. Objects of this - * type cache the Command pointer that results from looking up command names - * in the command hashtable. Such objects appear as the zeroth ("command - * name") argument in a Tcl command. - */ - -Tcl_ObjType tclCmdNameType = { - "cmdName", /* name */ - FreeCmdNameInternalRep, /* freeIntRepProc */ - DupCmdNameInternalRep, /* dupIntRepProc */ - (Tcl_UpdateStringProc *) NULL, /* updateStringProc */ - SetCmdNameFromAny /* setFromAnyProc */ -}; /* *---------------------------------------------------------------------- @@ -331,9 +459,8 @@ Tcl_ObjType tclCmdNameType = { * This procedure initializes the array of instruction names. If * compiling with the TCL_COMPILE_STATS flag, it initializes the * array that counts the executions of each instruction and it - * creates the "evalstats" command. It also registers the command name - * Tcl_ObjType. It also establishes the link between the Tcl - * "tcl_traceExec" and C "tclTraceExec" variables. + * creates the "evalstats" command. It also establishes the link + * between the Tcl "tcl_traceExec" and C "tclTraceExec" variables. * *---------------------------------------------------------------------- */ @@ -344,12 +471,12 @@ InitByteCodeExecution(interp) * "tcl_traceExec" is linked to control * instruction tracing. */ { - Tcl_RegisterObjType(&tclCmdNameType); +#ifdef TCL_COMPILE_DEBUG if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec, TCL_LINK_INT) != TCL_OK) { panic("InitByteCodeExecution: can't create link for tcl_traceExec variable"); } - +#endif #ifdef TCL_COMPILE_STATS Tcl_CreateCommand(interp, "evalstats", EvalStatsCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); @@ -386,11 +513,28 @@ TclCreateExecEnv(interp) * environment is being created. */ { ExecEnv *eePtr = (ExecEnv *) ckalloc(sizeof(ExecEnv)); + Tcl_Obj **stackPtr; + + stackPtr = (Tcl_Obj **) + ckalloc((size_t) (TCL_STACK_INITIAL_SIZE * sizeof(Tcl_Obj *))); + + /* + * Use the bottom pointer to keep a reference count; the + * execution environment holds a reference. + */ + + stackPtr++; + eePtr->stackPtr = stackPtr; + stackPtr[-1] = (Tcl_Obj *) ((char *) 1); - eePtr->stackPtr = (Tcl_Obj **) - ckalloc((unsigned) (TCL_STACK_INITIAL_SIZE * sizeof(Tcl_Obj *))); eePtr->stackTop = -1; - eePtr->stackEnd = (TCL_STACK_INITIAL_SIZE - 1); + eePtr->stackEnd = (TCL_STACK_INITIAL_SIZE - 2); + + eePtr->errorInfo = Tcl_NewStringObj("::errorInfo", -1); + Tcl_IncrRefCount(eePtr->errorInfo); + + eePtr->errorCode = Tcl_NewStringObj("::errorCode", -1); + Tcl_IncrRefCount(eePtr->errorCode); Tcl_MutexLock(&execMutex); if (!execInitialized) { @@ -425,7 +569,13 @@ void TclDeleteExecEnv(eePtr) ExecEnv *eePtr; /* Execution environment to free. */ { - ckfree((char *) eePtr->stackPtr); + if (eePtr->stackPtr[-1] == (Tcl_Obj *) ((char *) 1)) { + ckfree((char *) (eePtr->stackPtr-1)); + } else { + panic("ERROR: freeing an execEnv whose stack is still in use.\n"); + } + TclDecrRefCount(eePtr->errorInfo); + TclDecrRefCount(eePtr->errorCode); ckfree((char *) eePtr); } @@ -487,17 +637,416 @@ GrowEvaluationStack(eePtr) int currBytes = currElems * sizeof(Tcl_Obj *); int newBytes = 2*currBytes; Tcl_Obj **newStackPtr = (Tcl_Obj **) ckalloc((unsigned) newBytes); + Tcl_Obj **oldStackPtr = eePtr->stackPtr; + + /* + * We keep the stack reference count as a (char *), as that + * works nicely as a portable pointer-sized counter. + */ + + char *refCount = (char *) oldStackPtr[-1]; /* * Copy the existing stack items to the new stack space, free the old - * storage if appropriate, and mark new space as malloc'ed. + * storage if appropriate, and record the refCount of the new stack + * held by the environment. */ - memcpy((VOID *) newStackPtr, (VOID *) eePtr->stackPtr, + newStackPtr++; + memcpy((VOID *) newStackPtr, (VOID *) oldStackPtr, (size_t) currBytes); - ckfree((char *) eePtr->stackPtr); + + if (refCount == (char *) 1) { + ckfree((VOID *) (oldStackPtr-1)); + } else { + /* + * Remove the reference corresponding to the + * environment pointer. + */ + + oldStackPtr[-1] = (Tcl_Obj *) (refCount-1); + } + eePtr->stackPtr = newStackPtr; - eePtr->stackEnd = (newElems - 1); /* i.e. index of last usable item */ + eePtr->stackEnd = (newElems - 2); /* index of last usable item */ + newStackPtr[-1] = (Tcl_Obj *) ((char *) 1); +} + +/* + *-------------------------------------------------------------- + * + * Tcl_ExprObj -- + * + * Evaluate an expression in a Tcl_Obj. + * + * Results: + * A standard Tcl object result. If the result is other than TCL_OK, + * then the interpreter's result contains an error message. If the + * result is TCL_OK, then a pointer to the expression's result value + * object is stored in resultPtrPtr. In that case, the object's ref + * count is incremented to reflect the reference returned to the + * caller; the caller is then responsible for the resulting object + * and must, for example, decrement the ref count when it is finished + * with the object. + * + * Side effects: + * Any side effects caused by subcommands in the expression, if any. + * The interpreter result is not modified unless there is an error. + * + *-------------------------------------------------------------- + */ + +int +Tcl_ExprObj(interp, objPtr, resultPtrPtr) + Tcl_Interp *interp; /* Context in which to evaluate the + * expression. */ + register 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. */ +{ + Interp *iPtr = (Interp *) interp; + CompileEnv compEnv; /* Compilation environment structure + * allocated in frame. */ + LiteralTable *localTablePtr = &(compEnv.localLitTable); + register ByteCode *codePtr = NULL; + /* Tcl Internal type of bytecode. + * Initialized to avoid compiler warning. */ + AuxData *auxDataPtr; + LiteralEntry *entryPtr; + Tcl_Obj *saveObjPtr; + char *string; + int length, i, result; + + /* + * First handle some common expressions specially. + */ + + string = Tcl_GetStringFromObj(objPtr, &length); + if (length == 1) { + if (*string == '0') { + *resultPtrPtr = Tcl_NewLongObj(0); + Tcl_IncrRefCount(*resultPtrPtr); + return TCL_OK; + } else if (*string == '1') { + *resultPtrPtr = Tcl_NewLongObj(1); + Tcl_IncrRefCount(*resultPtrPtr); + return TCL_OK; + } + } else if ((length == 2) && (*string == '!')) { + if (*(string+1) == '0') { + *resultPtrPtr = Tcl_NewLongObj(1); + Tcl_IncrRefCount(*resultPtrPtr); + return TCL_OK; + } else if (*(string+1) == '1') { + *resultPtrPtr = Tcl_NewLongObj(0); + Tcl_IncrRefCount(*resultPtrPtr); + return TCL_OK; + } + } + + /* + * Get the ByteCode from the object. If it exists, make sure it hasn't + * been invalidated by, e.g., someone redefining a command with a + * compile procedure (this might make the compiled code wrong). If + * necessary, convert the object to be a ByteCode object and compile it. + * Also, if the code was compiled in/for a different interpreter, we + * recompile it. + * + * Precompiled expressions, however, are immutable and therefore + * they are not recompiled, even if the epoch has changed. + * + */ + + if (objPtr->typePtr == &tclByteCodeType) { + codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + if (((Interp *) *codePtr->interpHandle != iPtr) + || (codePtr->compileEpoch != iPtr->compileEpoch)) { + if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { + if ((Interp *) *codePtr->interpHandle != iPtr) { + panic("Tcl_ExprObj: compiled expression jumped interps"); + } + codePtr->compileEpoch = iPtr->compileEpoch; + } else { + (*tclByteCodeType.freeIntRepProc)(objPtr); + objPtr->typePtr = (Tcl_ObjType *) NULL; + } + } + } + if (objPtr->typePtr != &tclByteCodeType) { + TclInitCompileEnv(interp, &compEnv, string, length); + result = TclCompileExpr(interp, string, length, &compEnv); + + /* + * Free the compilation environment's literal table bucket array if + * it was dynamically allocated. + */ + + if (localTablePtr->buckets != localTablePtr->staticBuckets) { + ckfree((char *) localTablePtr->buckets); + } + + if (result != TCL_OK) { + /* + * Compilation errors. Free storage allocated for compilation. + */ + +#ifdef TCL_COMPILE_DEBUG + TclVerifyLocalLiteralTable(&compEnv); +#endif /*TCL_COMPILE_DEBUG*/ + entryPtr = compEnv.literalArrayPtr; + for (i = 0; i < compEnv.literalArrayNext; i++) { + TclReleaseLiteral(interp, entryPtr->objPtr); + entryPtr++; + } +#ifdef TCL_COMPILE_DEBUG + TclVerifyGlobalLiteralTable(iPtr); +#endif /*TCL_COMPILE_DEBUG*/ + + auxDataPtr = compEnv.auxDataArrayPtr; + for (i = 0; i < compEnv.auxDataArrayNext; i++) { + if (auxDataPtr->type->freeProc != NULL) { + auxDataPtr->type->freeProc(auxDataPtr->clientData); + } + auxDataPtr++; + } + TclFreeCompileEnv(&compEnv); + return result; + } + + /* + * Successful compilation. If the expression yielded no + * instructions, push an zero object as the expression's result. + */ + + if (compEnv.codeNext == compEnv.codeStart) { + TclEmitPush(TclRegisterLiteral(&compEnv, "0", 1, /*onHeap*/ 0), + &compEnv); + } + + /* + * Add a "done" instruction as the last instruction and change the + * object into a ByteCode object. Ownership of the literal objects + * and aux data items is given to the ByteCode object. + */ + + compEnv.numSrcBytes = iPtr->termOffset; + TclEmitOpcode(INST_DONE, &compEnv); + TclInitByteCodeObj(objPtr, &compEnv); + TclFreeCompileEnv(&compEnv); + codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; +#ifdef TCL_COMPILE_DEBUG + if (tclTraceCompile == 2) { + TclPrintByteCodeObj(interp, objPtr); + } +#endif /* TCL_COMPILE_DEBUG */ + } + + /* + * Execute the expression after first saving the interpreter's result. + */ + + saveObjPtr = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(saveObjPtr); + Tcl_ResetResult(interp); + + /* + * Increment the code's ref count while it is being executed. If + * afterwards no references to it remain, free the code. + */ + + codePtr->refCount++; + result = TclExecuteByteCode(interp, codePtr); + codePtr->refCount--; + if (codePtr->refCount <= 0) { + TclCleanupByteCode(codePtr); + objPtr->typePtr = NULL; + objPtr->internalRep.otherValuePtr = NULL; + } + + /* + * If the expression evaluated successfully, store a pointer to its + * value object in resultPtrPtr then restore the old interpreter result. + * We increment the object's ref count to reflect the reference that we + * are returning to the caller. We also decrement the ref count of the + * interpreter's result object after calling Tcl_SetResult since we + * next store into that field directly. + */ + + if (result == TCL_OK) { + *resultPtrPtr = iPtr->objResultPtr; + Tcl_IncrRefCount(iPtr->objResultPtr); + + Tcl_SetObjResult(interp, saveObjPtr); + } + TclDecrRefCount(saveObjPtr); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompEvalObj -- + * + * This procedure evaluates the script contained in a Tcl_Obj by + * first compiling it and then passing it to TclExecuteByteCode. + * + * Results: + * The return value is one of the return codes defined in tcl.h + * (such as TCL_OK), and interp->objResultPtr refers to a Tcl object + * that either contains the result of executing the code or an + * error message. + * + * Side effects: + * Almost certainly, depending on the ByteCode's instructions. + * + *---------------------------------------------------------------------- + */ + +int +TclCompEvalObj(interp, objPtr) + Tcl_Interp *interp; + Tcl_Obj *objPtr; +{ + register Interp *iPtr = (Interp *) interp; + register ByteCode* codePtr; /* Tcl Internal type of bytecode. */ + int oldCount = iPtr->cmdCount; /* Used to tell whether any commands + * at all were executed. */ + char *script; + int numSrcBytes; + int result; + Namespace *namespacePtr; + + + /* + * Check that the interpreter is ready to execute scripts + */ + + if (TclInterpReady(interp) == TCL_ERROR) { + return TCL_ERROR; + } + + if (iPtr->varFramePtr != NULL) { + namespacePtr = iPtr->varFramePtr->nsPtr; + } else { + namespacePtr = iPtr->globalNsPtr; + } + + /* + * If the object is not already of tclByteCodeType, compile it (and + * reset the compilation flags in the interpreter; this should be + * done after any compilation). + * Otherwise, check that it is "fresh" enough. + */ + + if (objPtr->typePtr != &tclByteCodeType) { + recompileObj: + iPtr->errorLine = 1; + result = tclByteCodeType.setFromAnyProc(interp, objPtr); + if (result != TCL_OK) { + return result; + } + iPtr->evalFlags = 0; + codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + } else { + /* + * Make sure the Bytecode hasn't been invalidated by, e.g., someone + * redefining a command with a compile procedure (this might make the + * compiled code wrong). + * The object needs to be recompiled if it was compiled in/for a + * different interpreter, or for a different namespace, or for the + * same namespace but with different name resolution rules. + * Precompiled objects, however, are immutable and therefore + * they are not recompiled, even if the epoch has changed. + * + * To be pedantically correct, we should also check that the + * originating procPtr is the same as the current context procPtr + * (assuming one exists at all - none for global level). This + * code is #def'ed out because [info body] was changed to never + * return a bytecode type object, which should obviate us from + * the extra checks here. + */ + codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + if (((Interp *) *codePtr->interpHandle != iPtr) + || (codePtr->compileEpoch != iPtr->compileEpoch) +#ifdef CHECK_PROC_ORIGINATION /* [Bug: 3412 Pedantic] */ + || (codePtr->procPtr != NULL && !(iPtr->varFramePtr && + iPtr->varFramePtr->procPtr == codePtr->procPtr)) +#endif + || (codePtr->nsPtr != namespacePtr) + || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) { + if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { + if ((Interp *) *codePtr->interpHandle != iPtr) { + panic("Tcl_EvalObj: compiled script jumped interps"); + } + codePtr->compileEpoch = iPtr->compileEpoch; + } else { + /* + * This byteCode is invalid: free it and recompile + */ + tclByteCodeType.freeIntRepProc(objPtr); + goto recompileObj; + } + } + } + + /* + * Execute the commands. If the code was compiled from an empty string, + * don't bother executing the code. + */ + + numSrcBytes = codePtr->numSrcBytes; + if ((numSrcBytes > 0) || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { + /* + * Increment the code's ref count while it is being executed. If + * afterwards no references to it remain, free the code. + */ + + codePtr->refCount++; + iPtr->numLevels++; + result = TclExecuteByteCode(interp, codePtr); + iPtr->numLevels--; + codePtr->refCount--; + if (codePtr->refCount <= 0) { + TclCleanupByteCode(codePtr); + } + } else { + result = TCL_OK; + } + + /* + * If no commands at all were executed, check for asynchronous + * handlers so that they at least get one change to execute. + * This is needed to handle event loops written in Tcl with + * empty bodies. + */ + + if ((oldCount == iPtr->cmdCount) && Tcl_AsyncReady()) { + result = Tcl_AsyncInvoke(interp, result); + + + /* + * If an error occurred, record information about what was being + * executed when the error occurred. + */ + + if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + Tcl_LogCommandInfo(interp, script, script, numSrcBytes); + } + } + + /* + * Set the interpreter's termOffset member to the offset of the + * character just after the last one executed. We approximate the offset + * of the last character executed by using the number of characters + * compiled. + */ + + iPtr->termOffset = numSrcBytes; + iPtr->flags &= ~ERR_ALREADY_LOGGED; + + return result; } /* @@ -519,8 +1068,8 @@ GrowEvaluationStack(eePtr) * *---------------------------------------------------------------------- */ - -int + +static int TclExecuteByteCode(interp, codePtr) Tcl_Interp *interp; /* Token for command interpreter. */ ByteCode *codePtr; /* The bytecode sequence to interpret. */ @@ -534,7 +1083,7 @@ TclExecuteByteCode(interp, codePtr) /* Cached top index of evaluation stack. */ register unsigned char *pc = codePtr->codeStart; /* The current program counter. */ - int opnd; /* Current instruction's operand byte. */ + int opnd; /* Current instruction's operand byte(s). */ int pcAdjustment; /* Hold pc adjustment after instruction. */ int initStackTop = stackTop;/* Stack top at start of execution. */ ExceptionRange *rangePtr; /* Points to closest loop or catch exception @@ -542,11 +1091,23 @@ TclExecuteByteCode(interp, codePtr) * instructions and processCatch to * process break, continue, and errors. */ int result = TCL_OK; /* Return code returned after execution. */ - int traceInstructions = (tclTraceExec == 3); + int storeFlags; Tcl_Obj *valuePtr, *value2Ptr, *objPtr; char *bytes; int length; - long i; + long i = 0; /* Init. avoids compiler warning. */ +#ifndef TCL_WIDE_INT_IS_LONG + Tcl_WideInt w; +#endif + register int cleanup; + Tcl_Obj *objResultPtr; + char *part1, *part2; + Var *varPtr, *arrayPtr; + CallFrame *varFramePtr = iPtr->varFramePtr; +#ifdef TCL_COMPILE_DEBUG + int traceInstructions = (tclTraceExec == 3); + char cmdNameBuf[21]; +#endif /* * This procedure uses a stack to hold information about catch commands. @@ -566,6 +1127,7 @@ TclExecuteByteCode(interp, codePtr) fprintf(stdout, " Starting stack top=%d\n", eePtr->stackTop); fflush(stdout); } + opnd = 0; /* Init. avoids compiler warning. */ #endif #ifdef TCL_COMPILE_STATS @@ -593,2324 +1155,3059 @@ TclExecuteByteCode(interp, codePtr) } /* - * Loop executing instructions until a "done" instruction, a TCL_RETURN, - * or some error. + * Loop executing instructions until a "done" instruction, a + * TCL_RETURN, or some error. */ - for (;;) { + goto cleanup0; + + + /* + * Targets for standard instruction endings; unrolled + * for speed in the most frequent cases (instructions that + * consume up to two stack elements). + * + * This used to be a "for(;;)" loop, with each instruction doing + * its own cleanup. + */ + + cleanupV_pushObjResultPtr: + switch (cleanup) { + case 0: + stackPtr[++stackTop] = (objResultPtr); + goto cleanup0; + default: + cleanup -= 2; + while (cleanup--) { + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); + } + case 2: + cleanup2_pushObjResultPtr: + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); + case 1: + cleanup1_pushObjResultPtr: + valuePtr = stackPtr[stackTop]; + TclDecrRefCount(valuePtr); + } + stackPtr[stackTop] = objResultPtr; + goto cleanup0; + + cleanupV: + switch (cleanup) { + default: + cleanup -= 2; + while (cleanup--) { + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); + } + case 2: + cleanup2: + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); + case 1: + cleanup1: + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); + case 0: + /* + * We really want to do nothing now, but this is needed + * for some compilers (SunPro CC) + */ + break; + } + + cleanup0: + #ifdef TCL_COMPILE_DEBUG - ValidatePcAndStackTop(codePtr, pc, stackTop, initStackTop, - eePtr->stackEnd); -#else /* not TCL_COMPILE_DEBUG */ - if (traceInstructions) { - fprintf(stdout, "%2d: %2d ", iPtr->numLevels, stackTop); - TclPrintInstruction(codePtr, pc); - fflush(stdout); - } + ValidatePcAndStackTop(codePtr, pc, stackTop, initStackTop); + if (traceInstructions) { + fprintf(stdout, "%2d: %2d ", iPtr->numLevels, stackTop); + TclPrintInstruction(codePtr, pc); + fflush(stdout); + } #endif /* TCL_COMPILE_DEBUG */ - + #ifdef TCL_COMPILE_STATS - iPtr->stats.instructionCount[*pc]++; + iPtr->stats.instructionCount[*pc]++; #endif - switch (*pc) { - case INST_DONE: - /* - * Pop the topmost object from the stack, set the interpreter's - * object result to point to it, and return. - */ - valuePtr = POP_OBJECT(); - Tcl_SetObjResult(interp, valuePtr); - TclDecrRefCount(valuePtr); - if (stackTop != initStackTop) { - fprintf(stderr, "\nTclExecuteByteCode: done instruction at pc %u: stack top %d != entry stack top %d\n", - (unsigned int)(pc - codePtr->codeStart), - (unsigned int) stackTop, - (unsigned int) initStackTop); - panic("TclExecuteByteCode execution failure: end stack top != start stack top"); - } - TRACE_WITH_OBJ(("=> return code=%d, result=", result), - iPtr->objResultPtr); + switch (*pc) { + case INST_DONE: + if (stackTop <= initStackTop) { + stackTop--; + goto abnormalReturn; + } + + /* + * Set the interpreter's object result to point to the + * topmost object from the stack, and check for a possible + * [catch]. The stackTop's level and refCount will be handled + * by "processCatch" or "abnormalReturn". + */ + + valuePtr = stackPtr[stackTop]; + Tcl_SetObjResult(interp, valuePtr); #ifdef TCL_COMPILE_DEBUG - if (traceInstructions) { - fprintf(stdout, "\n"); - } + TRACE_WITH_OBJ(("=> return code=%d, result=", result), + iPtr->objResultPtr); + if (traceInstructions) { + fprintf(stdout, "\n"); + } #endif - goto done; - - case INST_PUSH1: -#ifdef TCL_COMPILE_DEBUG - valuePtr = codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]; - PUSH_OBJECT(valuePtr); - TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), valuePtr); -#else - PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]); -#endif /* TCL_COMPILE_DEBUG */ - ADJUST_PC(2); - - case INST_PUSH4: - valuePtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)]; - PUSH_OBJECT(valuePtr); - TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), valuePtr); - ADJUST_PC(5); + goto checkForCatch; + + case INST_PUSH1: + objResultPtr = codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]; + TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), objResultPtr); + NEXT_INST_F(2, 0, 1); + + case INST_PUSH4: + objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)]; + TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), objResultPtr); + NEXT_INST_F(5, 0, 1); + + case INST_POP: + TRACE_WITH_OBJ(("=> discarding "), stackPtr[stackTop]); + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); + NEXT_INST_F(1, 0, 0); + + case INST_DUP: + objResultPtr = stackPtr[stackTop]; + TRACE_WITH_OBJ(("=> "), objResultPtr); + NEXT_INST_F(1, 0, 1); + + case INST_OVER: + opnd = TclGetUInt4AtPtr( pc+1 ); + objResultPtr = stackPtr[ stackTop - opnd ]; + TRACE_WITH_OBJ(("=> "), objResultPtr); + NEXT_INST_F(5, 0, 1); + + case INST_CONCAT1: + opnd = TclGetUInt1AtPtr(pc+1); + { + int totalLen = 0; - case INST_POP: - valuePtr = POP_OBJECT(); - TRACE_WITH_OBJ(("=> discarding "), valuePtr); - TclDecrRefCount(valuePtr); /* finished with pop'ed object. */ - ADJUST_PC(1); - - case INST_DUP: - valuePtr = stackPtr[stackTop]; - PUSH_OBJECT(Tcl_DuplicateObj(valuePtr)); - TRACE_WITH_OBJ(("=> "), valuePtr); - ADJUST_PC(1); + /* + * Concatenate strings (with no separators) from the top + * opnd items on the stack starting with the deepest item. + * First, determine how many characters are needed. + */ - case INST_CONCAT1: - opnd = TclGetUInt1AtPtr(pc+1); - { - Tcl_Obj *concatObjPtr; - int totalLen = 0; + for (i = (stackTop - (opnd-1)); i <= stackTop; i++) { + bytes = Tcl_GetStringFromObj(stackPtr[i], &length); + if (bytes != NULL) { + totalLen += length; + } + } - /* - * Concatenate strings (with no separators) from the top - * opnd items on the stack starting with the deepest item. - * First, determine how many characters are needed. - */ + /* + * Initialize the new append string object by appending the + * strings of the opnd stack objects. Also pop the objects. + */ + TclNewObj(objResultPtr); + if (totalLen > 0) { + char *p = (char *) ckalloc((unsigned) (totalLen + 1)); + objResultPtr->bytes = p; + objResultPtr->length = totalLen; for (i = (stackTop - (opnd-1)); i <= stackTop; i++) { - bytes = Tcl_GetStringFromObj(stackPtr[i], &length); + valuePtr = stackPtr[i]; + bytes = Tcl_GetStringFromObj(valuePtr, &length); if (bytes != NULL) { - totalLen += length; - } - } - - /* - * Initialize the new append string object by appending the - * strings of the opnd stack objects. Also pop the objects. - */ - - TclNewObj(concatObjPtr); - if (totalLen > 0) { - char *p = (char *) ckalloc((unsigned) (totalLen + 1)); - concatObjPtr->bytes = p; - concatObjPtr->length = totalLen; - for (i = (stackTop - (opnd-1)); i <= stackTop; i++) { - valuePtr = stackPtr[i]; - bytes = Tcl_GetStringFromObj(valuePtr, &length); - if (bytes != NULL) { - memcpy((VOID *) p, (VOID *) bytes, - (size_t) length); - p += length; - } - TclDecrRefCount(valuePtr); - } - *p = '\0'; - } else { - for (i = (stackTop - (opnd-1)); i <= stackTop; i++) { - Tcl_DecrRefCount(stackPtr[i]); + memcpy((VOID *) p, (VOID *) bytes, + (size_t) length); + p += length; } } - stackTop -= opnd; + *p = '\0'; + } - PUSH_OBJECT(concatObjPtr); - TRACE_WITH_OBJ(("%u => ", opnd), concatObjPtr); - ADJUST_PC(2); - } + TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); + NEXT_INST_V(2, opnd, 1); + } - case INST_INVOKE_STK4: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - goto doInvocation; - - case INST_INVOKE_STK1: - opnd = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; + case INST_INVOKE_STK4: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + goto doInvocation; + + case INST_INVOKE_STK1: + opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; - doInvocation: - { - int objc = opnd; /* The number of arguments. */ - Tcl_Obj **objv; /* The array of argument objects. */ - Command *cmdPtr; /* Points to command's Command struct. */ - int newPcOffset; /* New inst offset for break, continue. */ -#ifdef TCL_COMPILE_DEBUG - int isUnknownCmd = 0; - char cmdNameBuf[21]; -#endif /* TCL_COMPILE_DEBUG */ - - /* - * If the interpreter was deleted, return an error. - */ - - if (iPtr->flags & DELETED) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "attempt to call eval in deleted interpreter", -1); - Tcl_SetErrorCode(interp, "CORE", "IDELETE", - "attempt to call eval in deleted interpreter", - (char *) NULL); - result = TCL_ERROR; - goto checkForCatch; - } - - /* - * Find the procedure to execute this command. If the - * command is not found, handle it with the "unknown" proc. - */ + doInvocation: + { + int objc = opnd; /* The number of arguments. */ + Tcl_Obj **objv; /* The array of argument objects. */ - objv = &(stackPtr[stackTop - (objc-1)]); - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); - if (cmdPtr == NULL) { - cmdPtr = (Command *) Tcl_FindCommand(interp, "unknown", - (Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY); - if (cmdPtr == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "invalid command name \"", - Tcl_GetString(objv[0]), "\"", - (char *) NULL); - TRACE(("%u => unknown proc not found: ", objc)); - result = TCL_ERROR; - goto checkForCatch; - } -#ifdef TCL_COMPILE_DEBUG - isUnknownCmd = 1; -#endif /*TCL_COMPILE_DEBUG*/ - stackTop++; /* need room for new inserted objv[0] */ - for (i = objc-1; i >= 0; i--) { - objv[i+1] = objv[i]; - } - objc++; - objv[0] = Tcl_NewStringObj("unknown", -1); - Tcl_IncrRefCount(objv[0]); - } - - /* - * Call any trace procedures. - */ - - if (iPtr->tracePtr != NULL) { - Trace *tracePtr, *nextTracePtr; - - for (tracePtr = iPtr->tracePtr; tracePtr != NULL; - tracePtr = nextTracePtr) { - nextTracePtr = tracePtr->nextPtr; - if (iPtr->numLevels <= tracePtr->level) { - int numChars; - char *cmd = GetSrcInfoForPc(pc, codePtr, - &numChars); - if (cmd != NULL) { - DECACHE_STACK_INFO(); - CallTraceProcedure(interp, tracePtr, cmdPtr, - cmd, numChars, objc, objv); - CACHE_STACK_INFO(); - } - } - } - } - - /* - * Finally, invoke the command's Tcl_ObjCmdProc. First reset - * the interpreter's string and object results to their - * default empty values since they could have gotten changed - * by earlier invocations. - */ - - Tcl_ResetResult(interp); - if (tclTraceExec >= 2) { -#ifdef TCL_COMPILE_DEBUG - if (traceInstructions) { - strncpy(cmdNameBuf, Tcl_GetString(objv[0]), 20); - TRACE(("%u => call ", (isUnknownCmd? objc-1:objc))); - } else { - fprintf(stdout, "%d: (%u) invoking ", - iPtr->numLevels, - (unsigned int)(pc - codePtr->codeStart)); - } - for (i = 0; i < objc; i++) { - TclPrintObject(stdout, objv[i], 15); - fprintf(stdout, " "); - } - fprintf(stdout, "\n"); - fflush(stdout); -#else /* TCL_COMPILE_DEBUG */ - fprintf(stdout, "%d: (%u) invoking %s\n", - iPtr->numLevels, - (unsigned int)(pc - codePtr->codeStart), - Tcl_GetString(objv[0])); -#endif /*TCL_COMPILE_DEBUG*/ - } + /* + * We keep the stack reference count as a (char *), as that + * works nicely as a portable pointer-sized counter. + */ - iPtr->cmdCount++; - DECACHE_STACK_INFO(); - result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, - objc, objv); - if (Tcl_AsyncReady()) { - result = Tcl_AsyncInvoke(interp, result); - } - CACHE_STACK_INFO(); + char **preservedStackRefCountPtr; + + /* + * Reference to memory block containing + * objv array (must be kept live throughout + * trace and command invokations.) + */ - /* - * If the interpreter has a non-empty string result, the - * result object is either empty or stale because some - * procedure set interp->result directly. If so, move the - * string result to the result object, then reset the - * string result. - */ + objv = &(stackPtr[stackTop - (objc-1)]); - if (*(iPtr->result) != 0) { - (void) Tcl_GetObjResult(interp); +#ifdef TCL_COMPILE_DEBUG + if (tclTraceExec >= 2) { + if (traceInstructions) { + strncpy(cmdNameBuf, TclGetString(objv[0]), 20); + TRACE(("%u => call ", objc)); + } else { + fprintf(stdout, "%d: (%u) invoking ", + iPtr->numLevels, + (unsigned int)(pc - codePtr->codeStart)); } - - /* - * Pop the objc top stack elements and decrement their ref - * counts. - */ - for (i = 0; i < objc; i++) { - valuePtr = stackPtr[stackTop]; - TclDecrRefCount(valuePtr); - stackTop--; + TclPrintObject(stdout, objv[i], 15); + fprintf(stdout, " "); } + fprintf(stdout, "\n"); + fflush(stdout); + } +#endif /*TCL_COMPILE_DEBUG*/ - /* - * Process the result of the Tcl_ObjCmdProc call. - */ - - switch (result) { - case TCL_OK: - /* - * Push the call's object result and continue execution - * with the next instruction. - */ - PUSH_OBJECT(Tcl_GetObjResult(interp)); - TRACE_WITH_OBJ(("%u => ...after \"%.20s\", result=", - objc, cmdNameBuf), Tcl_GetObjResult(interp)); - ADJUST_PC(pcAdjustment); + /* + * If trace procedures will be called, we need a + * command string to pass to TclEvalObjvInternal; note + * that a copy of the string will be made there to + * include the ending \0. + */ + + bytes = NULL; + length = 0; + if (iPtr->tracePtr != NULL) { + Trace *tracePtr, *nextTracePtr; - case TCL_BREAK: - case TCL_CONTINUE: - /* - * The invoked command requested a break or continue. - * Find the closest enclosing loop or catch exception - * range, if any. If a loop is found, terminate its - * execution or skip to its next iteration. If the - * closest is a catch exception range, jump to its - * catchOffset. If no enclosing range is found, stop - * execution and return the TCL_BREAK or TCL_CONTINUE. - */ - rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, - codePtr); - if (rangePtr == NULL) { - TRACE(("%u => ... after \"%.20s\", no encl. loop or catch, returning %s\n", - objc, cmdNameBuf, - StringForResultCode(result))); - goto abnormalReturn; /* no catch exists to check */ - } - newPcOffset = 0; - switch (rangePtr->type) { - case LOOP_EXCEPTION_RANGE: - if (result == TCL_BREAK) { - newPcOffset = rangePtr->breakOffset; - } else if (rangePtr->continueOffset == -1) { - TRACE(("%u => ... after \"%.20s\", %s, loop w/o continue, checking for catch\n", - objc, cmdNameBuf, - StringForResultCode(result))); - goto checkForCatch; - } else { - newPcOffset = rangePtr->continueOffset; - } - TRACE(("%u => ... after \"%.20s\", %s, range at %d, new pc %d\n", - objc, cmdNameBuf, - StringForResultCode(result), - rangePtr->codeOffset, newPcOffset)); + for (tracePtr = iPtr->tracePtr; tracePtr != NULL; + tracePtr = nextTracePtr) { + nextTracePtr = tracePtr->nextPtr; + if (tracePtr->level == 0 || + iPtr->numLevels <= tracePtr->level) { + /* + * Traces will be called: get command string + */ + + bytes = GetSrcInfoForPc(pc, codePtr, &length); break; - case CATCH_EXCEPTION_RANGE: - TRACE(("%u => ... after \"%.20s\", %s...\n", - objc, cmdNameBuf, - StringForResultCode(result))); - goto processCatch; /* it will use rangePtr */ - default: - panic("TclExecuteByteCode: bad ExceptionRange type\n"); } - result = TCL_OK; - pc = (codePtr->codeStart + newPcOffset); - continue; /* restart outer instruction loop at pc */ - - case TCL_ERROR: - /* - * The invoked command returned an error. Look for an - * enclosing catch exception range, if any. - */ - TRACE_WITH_OBJ(("%u => ... after \"%.20s\", TCL_ERROR ", - objc, cmdNameBuf), Tcl_GetObjResult(interp)); - goto checkForCatch; + } + } else { + Command *cmdPtr; + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); + if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { + bytes = GetSrcInfoForPc(pc, codePtr, &length); + } + } - case TCL_RETURN: - /* - * The invoked command requested that the current - * procedure stop execution and return. First check - * for an enclosing catch exception range, if any. - */ - TRACE(("%u => ... after \"%.20s\", TCL_RETURN\n", - objc, cmdNameBuf)); - goto checkForCatch; + /* + * A reference to part of the stack vector itself + * escapes our control: increase its refCount + * to stop it from being deallocated by a recursive + * call to ourselves. The extra variable is needed + * because all others are liable to change due to the + * trace procedures. + */ - default: - TRACE_WITH_OBJ(("%u => ... after \"%.20s\", OTHER RETURN CODE %d ", - objc, cmdNameBuf, result), - Tcl_GetObjResult(interp)); - goto checkForCatch; - } - } - - case INST_EVAL_STK: - objPtr = POP_OBJECT(); + preservedStackRefCountPtr = (char **) (stackPtr-1); + ++*preservedStackRefCountPtr; + + /* + * Finally, let TclEvalObjvInternal handle the command. + */ + + Tcl_ResetResult(interp); DECACHE_STACK_INFO(); - result = Tcl_EvalObjEx(interp, objPtr, 0); + result = TclEvalObjvInternal(interp, objc, objv, bytes, length, 0); CACHE_STACK_INFO(); + + /* + * If the old stack is going to be released, it is + * safe to do so now, since no references to objv are + * going to be used from now on. + */ + + --*preservedStackRefCountPtr; + if (*preservedStackRefCountPtr == (char *) 0) { + ckfree((VOID *) preservedStackRefCountPtr); + } + if (result == TCL_OK) { /* - * Normal return; push the eval's object result. - */ - PUSH_OBJECT(Tcl_GetObjResult(interp)); - TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), - Tcl_GetObjResult(interp)); - TclDecrRefCount(objPtr); - ADJUST_PC(1); - } else if ((result == TCL_BREAK) || (result == TCL_CONTINUE)) { - /* - * Find the closest enclosing loop or catch exception range, - * if any. If a loop is found, terminate its execution or - * skip to its next iteration. If the closest is a catch - * exception range, jump to its catchOffset. If no enclosing - * range is found, stop execution and return that same - * TCL_BREAK or TCL_CONTINUE. + * Push the call's object result and continue execution + * with the next instruction. */ - int newPcOffset = 0; /* Pc offset computed during break, - * continue, error processing. Init. - * to avoid compiler warning. */ - - rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, - codePtr); - if (rangePtr == NULL) { - TRACE(("\"%.30s\" => no encl. loop or catch, returning %s\n", - O2S(objPtr), StringForResultCode(result))); - Tcl_DecrRefCount(objPtr); - goto abnormalReturn; /* no catch exists to check */ - } - switch (rangePtr->type) { - case LOOP_EXCEPTION_RANGE: - if (result == TCL_BREAK) { - newPcOffset = rangePtr->breakOffset; - } else if (rangePtr->continueOffset == -1) { - TRACE(("\"%.30s\" => %s, loop w/o continue, checking for catch\n", - O2S(objPtr), StringForResultCode(result))); - Tcl_DecrRefCount(objPtr); - goto checkForCatch; - } else { - newPcOffset = rangePtr->continueOffset; - } - result = TCL_OK; - TRACE_WITH_OBJ(("\"%.30s\" => %s, range at %d, new pc %d ", - O2S(objPtr), StringForResultCode(result), - rangePtr->codeOffset, newPcOffset), valuePtr); - break; - case CATCH_EXCEPTION_RANGE: - TRACE_WITH_OBJ(("\"%.30s\" => %s ", - O2S(objPtr), StringForResultCode(result)), - valuePtr); - Tcl_DecrRefCount(objPtr); - goto processCatch; /* it will use rangePtr */ - default: - panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type); - } - Tcl_DecrRefCount(objPtr); - pc = (codePtr->codeStart + newPcOffset); - continue; /* restart outer instruction loop at pc */ - } else { /* eval returned TCL_ERROR, TCL_RETURN, unknown code */ - TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)), - Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(objPtr); - goto checkForCatch; - } + TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=", + objc, cmdNameBuf), Tcl_GetObjResult(interp)); - case INST_EXPR_STK: - objPtr = POP_OBJECT(); - Tcl_ResetResult(interp); - DECACHE_STACK_INFO(); - result = Tcl_ExprObj(interp, objPtr, &valuePtr); - CACHE_STACK_INFO(); - if (result != TCL_OK) { - TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", - O2S(objPtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(objPtr); - goto checkForCatch; + objResultPtr = Tcl_GetObjResult(interp); + NEXT_INST_V(pcAdjustment, opnd, 1); + } else { + cleanup = opnd; + goto processExceptionReturn; } - stackPtr[++stackTop] = valuePtr; /* already has right refct */ - TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr); - TclDecrRefCount(objPtr); - ADJUST_PC(1); + } - case INST_LOAD_SCALAR1: -#ifdef TCL_COMPILE_DEBUG - opnd = TclGetUInt1AtPtr(pc+1); - DECACHE_STACK_INFO(); - valuePtr = TclGetIndexedScalar(interp, opnd, - /*leaveErrorMsg*/ 1); - CACHE_STACK_INFO(); - if (valuePtr == NULL) { - TRACE_WITH_OBJ(("%u => ERROR: ", opnd), - Tcl_GetObjResult(interp)); - result = TCL_ERROR; - goto checkForCatch; - } - PUSH_OBJECT(valuePtr); - TRACE_WITH_OBJ(("%u => ", opnd), valuePtr); -#else /* TCL_COMPILE_DEBUG */ - DECACHE_STACK_INFO(); - opnd = TclGetUInt1AtPtr(pc+1); - valuePtr = TclGetIndexedScalar(interp, opnd, /*leaveErrorMsg*/ 1); - CACHE_STACK_INFO(); - if (valuePtr == NULL) { - result = TCL_ERROR; - goto checkForCatch; - } - PUSH_OBJECT(valuePtr); -#endif /* TCL_COMPILE_DEBUG */ - ADJUST_PC(2); + case INST_EVAL_STK: + /* + * Note to maintainers: it is important that INST_EVAL_STK + * pop its argument from the stack before jumping to + * checkForCatch! DO NOT OPTIMISE! + */ - case INST_LOAD_SCALAR4: - opnd = TclGetUInt4AtPtr(pc+1); - DECACHE_STACK_INFO(); - valuePtr = TclGetIndexedScalar(interp, opnd, - /*leaveErrorMsg*/ 1); - CACHE_STACK_INFO(); - if (valuePtr == NULL) { - TRACE_WITH_OBJ(("%u => ERROR: ", opnd), - Tcl_GetObjResult(interp)); - result = TCL_ERROR; - goto checkForCatch; - } - PUSH_OBJECT(valuePtr); - TRACE_WITH_OBJ(("%u => ", opnd), valuePtr); - ADJUST_PC(5); + objPtr = stackPtr[stackTop]; + DECACHE_STACK_INFO(); + result = TclCompEvalObj(interp, objPtr); + CACHE_STACK_INFO(); + if (result == TCL_OK) { + /* + * Normal return; push the eval's object result. + */ - case INST_LOAD_SCALAR_STK: - objPtr = POP_OBJECT(); /* scalar name */ - DECACHE_STACK_INFO(); - valuePtr = Tcl_ObjGetVar2(interp, objPtr, NULL, TCL_LEAVE_ERR_MSG); - CACHE_STACK_INFO(); - if (valuePtr == NULL) { - TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)), - Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(objPtr); - result = TCL_ERROR; - goto checkForCatch; - } - PUSH_OBJECT(valuePtr); - TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr); - TclDecrRefCount(objPtr); - ADJUST_PC(1); - - case INST_LOAD_ARRAY4: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - goto doLoadArray; - - case INST_LOAD_ARRAY1: - opnd = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; - - doLoadArray: - { - Tcl_Obj *elemPtr = POP_OBJECT(); - - DECACHE_STACK_INFO(); - valuePtr = TclGetElementOfIndexedArray(interp, opnd, - elemPtr, /*leaveErrorMsg*/ 1); - CACHE_STACK_INFO(); - if (valuePtr == NULL) { - TRACE_WITH_OBJ(("%u \"%.30s\" => ERROR: ", - opnd, O2S(elemPtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(elemPtr); - result = TCL_ERROR; - goto checkForCatch; - } - PUSH_OBJECT(valuePtr); - TRACE_WITH_OBJ(("%u \"%.30s\" => ", - opnd, O2S(elemPtr)),valuePtr); - TclDecrRefCount(elemPtr); - } - ADJUST_PC(pcAdjustment); + objResultPtr = Tcl_GetObjResult(interp); + TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), + Tcl_GetObjResult(interp)); + NEXT_INST_F(1, 1, 1); + } else { + cleanup = 1; + goto processExceptionReturn; + } - case INST_LOAD_ARRAY_STK: - { - Tcl_Obj *elemPtr = POP_OBJECT(); - - objPtr = POP_OBJECT(); /* array name */ - DECACHE_STACK_INFO(); - valuePtr = Tcl_ObjGetVar2(interp, objPtr, elemPtr, - TCL_LEAVE_ERR_MSG); - CACHE_STACK_INFO(); - if (valuePtr == NULL) { - TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ERROR: ", - O2S(objPtr), O2S(elemPtr)), - Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(objPtr); - Tcl_DecrRefCount(elemPtr); - result = TCL_ERROR; - goto checkForCatch; - } - PUSH_OBJECT(valuePtr); - TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ", - O2S(objPtr), O2S(elemPtr)), valuePtr); - TclDecrRefCount(objPtr); - TclDecrRefCount(elemPtr); - } - ADJUST_PC(1); + case INST_EXPR_STK: + objPtr = stackPtr[stackTop]; + Tcl_ResetResult(interp); + DECACHE_STACK_INFO(); + result = Tcl_ExprObj(interp, objPtr, &valuePtr); + CACHE_STACK_INFO(); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", + O2S(objPtr)), Tcl_GetObjResult(interp)); + goto checkForCatch; + } + objResultPtr = valuePtr; + TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr); + NEXT_INST_F(1, 1, -1); /* already has right refct */ - case INST_LOAD_STK: - objPtr = POP_OBJECT(); /* variable name */ - DECACHE_STACK_INFO(); - valuePtr = Tcl_ObjGetVar2(interp, objPtr, NULL, TCL_LEAVE_ERR_MSG); - CACHE_STACK_INFO(); - if (valuePtr == NULL) { - TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", - O2S(objPtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(objPtr); - result = TCL_ERROR; - goto checkForCatch; - } - PUSH_OBJECT(valuePtr); - TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr); - TclDecrRefCount(objPtr); - ADJUST_PC(1); - - case INST_STORE_SCALAR4: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - goto doStoreScalar; - - case INST_STORE_SCALAR1: - opnd = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; - - doStoreScalar: - valuePtr = POP_OBJECT(); - DECACHE_STACK_INFO(); - value2Ptr = TclSetIndexedScalar(interp, opnd, valuePtr, - /*leaveErrorMsg*/ 1); - CACHE_STACK_INFO(); - if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("%u <- \"%.30s\" => ERROR: ", - opnd, O2S(valuePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(valuePtr); - result = TCL_ERROR; - goto checkForCatch; - } - PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("%u <- \"%.30s\" => ", - opnd, O2S(valuePtr)), value2Ptr); - TclDecrRefCount(valuePtr); - ADJUST_PC(pcAdjustment); + /* + * --------------------------------------------------------- + * Start of INST_LOAD instructions. + * + * WARNING: more 'goto' here than your doctor recommended! + * The different instructions set the value of some variables + * and then jump to somme common execution code. + */ - case INST_STORE_SCALAR_STK: - valuePtr = POP_OBJECT(); - objPtr = POP_OBJECT(); /* scalar name */ - DECACHE_STACK_INFO(); - value2Ptr = Tcl_ObjSetVar2(interp, objPtr, NULL, valuePtr, - TCL_LEAVE_ERR_MSG); - CACHE_STACK_INFO(); - if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ERROR: ", - O2S(objPtr), O2S(valuePtr)), - Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(objPtr); - Tcl_DecrRefCount(valuePtr); - result = TCL_ERROR; - goto checkForCatch; - } - PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ", - O2S(objPtr), O2S(valuePtr)), value2Ptr); - TclDecrRefCount(objPtr); - TclDecrRefCount(valuePtr); - ADJUST_PC(1); + case INST_LOAD_SCALAR1: + opnd = TclGetUInt1AtPtr(pc+1); + varPtr = &(varFramePtr->compiledLocals[opnd]); + part1 = varPtr->name; + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + TRACE(("%u => ", opnd)); + if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr) + && (varPtr->tracePtr == NULL)) { + /* + * No errors, no traces: just get the value. + */ + objResultPtr = varPtr->value.objPtr; + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(2, 0, 1); + } + pcAdjustment = 2; + cleanup = 0; + arrayPtr = NULL; + part2 = NULL; + goto doCallPtrGetVar; + + case INST_LOAD_SCALAR4: + opnd = TclGetUInt4AtPtr(pc+1); + varPtr = &(varFramePtr->compiledLocals[opnd]); + part1 = varPtr->name; + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + TRACE(("%u => ", opnd)); + if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr) + && (varPtr->tracePtr == NULL)) { + /* + * No errors, no traces: just get the value. + */ + objResultPtr = varPtr->value.objPtr; + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(5, 0, 1); + } + pcAdjustment = 5; + cleanup = 0; + arrayPtr = NULL; + part2 = NULL; + goto doCallPtrGetVar; + + case INST_LOAD_ARRAY_STK: + cleanup = 2; + part2 = Tcl_GetString(stackPtr[stackTop]); /* element name */ + objPtr = stackPtr[stackTop-1]; /* array name */ + TRACE(("\"%.30s(%.30s)\" => ", O2S(objPtr), part2)); + goto doLoadStk; + + case INST_LOAD_STK: + case INST_LOAD_SCALAR_STK: + cleanup = 1; + part2 = NULL; + objPtr = stackPtr[stackTop]; /* variable name */ + TRACE(("\"%.30s\" => ", O2S(objPtr))); + + doLoadStk: + part1 = TclGetString(objPtr); + varPtr = TclObjLookupVar(interp, objPtr, part2, + TCL_LEAVE_ERR_MSG, "read", + /*createPart1*/ 0, + /*createPart2*/ 1, &arrayPtr); + if (varPtr == NULL) { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; + goto checkForCatch; + } + if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr) + && (varPtr->tracePtr == NULL) + && ((arrayPtr == NULL) + || (arrayPtr->tracePtr == NULL))) { + /* + * No errors, no traces: just get the value. + */ + objResultPtr = varPtr->value.objPtr; + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(1, cleanup, 1); + } + pcAdjustment = 1; + goto doCallPtrGetVar; - case INST_STORE_ARRAY4: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - goto doStoreArray; + case INST_LOAD_ARRAY4: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + goto doLoadArray; - case INST_STORE_ARRAY1: - opnd = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; - - doStoreArray: - { - Tcl_Obj *elemPtr; + case INST_LOAD_ARRAY1: + opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + + doLoadArray: + part2 = TclGetString(stackPtr[stackTop]); + arrayPtr = &(varFramePtr->compiledLocals[opnd]); + part1 = arrayPtr->name; + while (TclIsVarLink(arrayPtr)) { + arrayPtr = arrayPtr->value.linkPtr; + } + TRACE(("%u \"%.30s\" => ", opnd, part2)); + varPtr = TclLookupArrayElement(interp, part1, part2, + TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr); + if (varPtr == NULL) { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; + goto checkForCatch; + } + if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr) + && (varPtr->tracePtr == NULL) + && ((arrayPtr == NULL) + || (arrayPtr->tracePtr == NULL))) { + /* + * No errors, no traces: just get the value. + */ + objResultPtr = varPtr->value.objPtr; + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_F(pcAdjustment, 1, 1); + } + cleanup = 1; + goto doCallPtrGetVar; - valuePtr = POP_OBJECT(); - elemPtr = POP_OBJECT(); - DECACHE_STACK_INFO(); - value2Ptr = TclSetElementOfIndexedArray(interp, opnd, - elemPtr, valuePtr, TCL_LEAVE_ERR_MSG); - CACHE_STACK_INFO(); - if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ERROR: ", - opnd, O2S(elemPtr), O2S(valuePtr)), - Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(elemPtr); - Tcl_DecrRefCount(valuePtr); - result = TCL_ERROR; - goto checkForCatch; - } - PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ", - opnd, O2S(elemPtr), O2S(valuePtr)), value2Ptr); - TclDecrRefCount(elemPtr); - TclDecrRefCount(valuePtr); - } - ADJUST_PC(pcAdjustment); + doCallPtrGetVar: + /* + * There are either errors or the variable is traced: + * call TclPtrGetVar to process fully. + */ - case INST_STORE_ARRAY_STK: - { - Tcl_Obj *elemPtr; + DECACHE_STACK_INFO(); + objResultPtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, + part2, TCL_LEAVE_ERR_MSG); + CACHE_STACK_INFO(); + if (objResultPtr == NULL) { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; + goto checkForCatch; + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(pcAdjustment, cleanup, 1); - valuePtr = POP_OBJECT(); - elemPtr = POP_OBJECT(); - objPtr = POP_OBJECT(); /* array name */ - DECACHE_STACK_INFO(); - value2Ptr = Tcl_ObjSetVar2(interp, objPtr, elemPtr, valuePtr, - TCL_LEAVE_ERR_MSG); - CACHE_STACK_INFO(); - if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ", - O2S(objPtr), O2S(elemPtr), O2S(valuePtr)), - Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(objPtr); - Tcl_DecrRefCount(elemPtr); - Tcl_DecrRefCount(valuePtr); - result = TCL_ERROR; - goto checkForCatch; - } - PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ", - O2S(objPtr), O2S(elemPtr), O2S(valuePtr)), - value2Ptr); - TclDecrRefCount(objPtr); - TclDecrRefCount(elemPtr); - TclDecrRefCount(valuePtr); - } - ADJUST_PC(1); + /* + * End of INST_LOAD instructions. + * --------------------------------------------------------- + */ - case INST_STORE_STK: - valuePtr = POP_OBJECT(); - objPtr = POP_OBJECT(); /* variable name */ - DECACHE_STACK_INFO(); - value2Ptr = Tcl_ObjSetVar2(interp, objPtr, NULL, valuePtr, - TCL_LEAVE_ERR_MSG); - CACHE_STACK_INFO(); - if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ERROR: ", - O2S(objPtr), O2S(valuePtr)), - Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(objPtr); - Tcl_DecrRefCount(valuePtr); - result = TCL_ERROR; - goto checkForCatch; - } - PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ", - O2S(objPtr), O2S(valuePtr)), value2Ptr); - TclDecrRefCount(objPtr); - TclDecrRefCount(valuePtr); - ADJUST_PC(1); + /* + * --------------------------------------------------------- + * Start of INST_STORE and related instructions. + * + * WARNING: more 'goto' here than your doctor recommended! + * The different instructions set the value of some variables + * and then jump to somme common execution code. + */ - case INST_INCR_SCALAR1: - opnd = TclGetUInt1AtPtr(pc+1); - valuePtr = POP_OBJECT(); - if (valuePtr->typePtr != &tclIntType) { - result = tclIntType.setFromAnyProc(interp, valuePtr); - if (result != TCL_OK) { - TRACE_WITH_OBJ(("%u (by %s) => ERROR converting increment amount to int: ", - opnd, O2S(valuePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(valuePtr); - goto checkForCatch; + case INST_LAPPEND_STK: + valuePtr = stackPtr[stackTop]; /* value to append */ + part2 = NULL; + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE + | TCL_LIST_ELEMENT | TCL_TRACE_READS); + goto doStoreStk; + + case INST_LAPPEND_ARRAY_STK: + valuePtr = stackPtr[stackTop]; /* value to append */ + part2 = TclGetString(stackPtr[stackTop - 1]); + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE + | TCL_LIST_ELEMENT | TCL_TRACE_READS); + goto doStoreStk; + + case INST_APPEND_STK: + valuePtr = stackPtr[stackTop]; /* value to append */ + part2 = NULL; + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); + goto doStoreStk; + + case INST_APPEND_ARRAY_STK: + valuePtr = stackPtr[stackTop]; /* value to append */ + part2 = TclGetString(stackPtr[stackTop - 1]); + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); + goto doStoreStk; + + case INST_STORE_ARRAY_STK: + valuePtr = stackPtr[stackTop]; + part2 = TclGetString(stackPtr[stackTop - 1]); + storeFlags = TCL_LEAVE_ERR_MSG; + goto doStoreStk; + + case INST_STORE_STK: + case INST_STORE_SCALAR_STK: + valuePtr = stackPtr[stackTop]; + part2 = NULL; + storeFlags = TCL_LEAVE_ERR_MSG; + + doStoreStk: + objPtr = stackPtr[stackTop - 1 - (part2 != NULL)]; /* variable name */ + part1 = TclGetString(objPtr); +#ifdef TCL_COMPILE_DEBUG + if (part2 == NULL) { + TRACE(("\"%.30s\" <- \"%.30s\" =>", + part1, O2S(valuePtr))); + } else { + TRACE(("\"%.30s(%.30s)\" <- \"%.30s\" => ", + part1, part2, O2S(valuePtr))); + } +#endif + varPtr = TclObjLookupVar(interp, objPtr, part2, + TCL_LEAVE_ERR_MSG, "set", + /*createPart1*/ 1, + /*createPart2*/ 1, &arrayPtr); + if (varPtr == NULL) { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; + goto checkForCatch; + } + cleanup = ((part2 == NULL)? 2 : 3); + pcAdjustment = 1; + goto doCallPtrSetVar; + + case INST_LAPPEND_ARRAY4: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE + | TCL_LIST_ELEMENT | TCL_TRACE_READS); + goto doStoreArray; + + case INST_LAPPEND_ARRAY1: + opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE + | TCL_LIST_ELEMENT | TCL_TRACE_READS); + goto doStoreArray; + + case INST_APPEND_ARRAY4: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); + goto doStoreArray; + + case INST_APPEND_ARRAY1: + opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); + goto doStoreArray; + + case INST_STORE_ARRAY4: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + storeFlags = TCL_LEAVE_ERR_MSG; + goto doStoreArray; + + case INST_STORE_ARRAY1: + opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + storeFlags = TCL_LEAVE_ERR_MSG; + + doStoreArray: + valuePtr = stackPtr[stackTop]; + part2 = TclGetString(stackPtr[stackTop - 1]); + arrayPtr = &(varFramePtr->compiledLocals[opnd]); + part1 = arrayPtr->name; + TRACE(("%u \"%.30s\" <- \"%.30s\" => ", + opnd, part2, O2S(valuePtr))); + while (TclIsVarLink(arrayPtr)) { + arrayPtr = arrayPtr->value.linkPtr; + } + varPtr = TclLookupArrayElement(interp, part1, part2, + TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr); + if (varPtr == NULL) { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; + goto checkForCatch; + } + cleanup = 2; + goto doCallPtrSetVar; + + case INST_LAPPEND_SCALAR4: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE + | TCL_LIST_ELEMENT | TCL_TRACE_READS); + goto doStoreScalar; + + case INST_LAPPEND_SCALAR1: + opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE + | TCL_LIST_ELEMENT | TCL_TRACE_READS); + goto doStoreScalar; + + case INST_APPEND_SCALAR4: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); + goto doStoreScalar; + + case INST_APPEND_SCALAR1: + opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); + goto doStoreScalar; + + case INST_STORE_SCALAR4: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + storeFlags = TCL_LEAVE_ERR_MSG; + goto doStoreScalar; + + case INST_STORE_SCALAR1: + opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + storeFlags = TCL_LEAVE_ERR_MSG; + + doStoreScalar: + valuePtr = stackPtr[stackTop]; + varPtr = &(varFramePtr->compiledLocals[opnd]); + part1 = varPtr->name; + TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr))); + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + cleanup = 1; + arrayPtr = NULL; + part2 = NULL; + + doCallPtrSetVar: + if ((storeFlags == TCL_LEAVE_ERR_MSG) + && !((varPtr->flags & VAR_IN_HASHTABLE) + && (varPtr->hPtr == NULL)) + && (varPtr->tracePtr == NULL) + && (TclIsVarScalar(varPtr) + || TclIsVarUndefined(varPtr)) + && ((arrayPtr == NULL) + || (arrayPtr->tracePtr == NULL))) { + /* + * No traces, no errors, plain 'set': we can safely inline. + * The value *will* be set to what's requested, so that + * the stack top remains pointing to the same Tcl_Obj. + */ + valuePtr = varPtr->value.objPtr; + objResultPtr = stackPtr[stackTop]; + if (valuePtr != objResultPtr) { + if (valuePtr != NULL) { + TclDecrRefCount(valuePtr); + } else { + TclSetVarScalar(varPtr); + TclClearVarUndefined(varPtr); } + varPtr->value.objPtr = objResultPtr; + Tcl_IncrRefCount(objResultPtr); } - i = valuePtr->internalRep.longValue; +#ifndef TCL_COMPILE_DEBUG + if (*(pc+pcAdjustment) == INST_POP) { + NEXT_INST_V((pcAdjustment+1), cleanup, 0); + } +#else + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); +#endif + NEXT_INST_V(pcAdjustment, cleanup, 1); + } else { DECACHE_STACK_INFO(); - value2Ptr = TclIncrIndexedScalar(interp, opnd, i); + objResultPtr = TclPtrSetVar(interp, varPtr, arrayPtr, + part1, part2, valuePtr, storeFlags); CACHE_STACK_INFO(); - if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("%u (by %ld) => ERROR: ", opnd, i), - Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(valuePtr); + if (objResultPtr == NULL) { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); result = TCL_ERROR; goto checkForCatch; } - PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("%u (by %ld) => ", opnd, i), value2Ptr); - TclDecrRefCount(valuePtr); - ADJUST_PC(2); + } +#ifndef TCL_COMPILE_DEBUG + if (*(pc+pcAdjustment) == INST_POP) { + NEXT_INST_V((pcAdjustment+1), cleanup, 0); + } +#endif + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(pcAdjustment, cleanup, 1); - case INST_INCR_SCALAR_STK: - case INST_INCR_STK: - valuePtr = POP_OBJECT(); - objPtr = POP_OBJECT(); /* scalar name */ - if (valuePtr->typePtr != &tclIntType) { - result = tclIntType.setFromAnyProc(interp, valuePtr); - if (result != TCL_OK) { - TRACE_WITH_OBJ(("\"%.30s\" (by %s) => ERROR converting increment amount to int: ", - O2S(objPtr), O2S(valuePtr)), - Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(objPtr); - Tcl_DecrRefCount(valuePtr); - goto checkForCatch; - } - } + + /* + * End of INST_STORE and related instructions. + * --------------------------------------------------------- + */ + + /* + * --------------------------------------------------------- + * Start of INST_INCR instructions. + * + * WARNING: more 'goto' here than your doctor recommended! + * The different instructions set the value of some variables + * and then jump to somme common execution code. + */ + + case INST_INCR_SCALAR1: + case INST_INCR_ARRAY1: + case INST_INCR_ARRAY_STK: + case INST_INCR_SCALAR_STK: + case INST_INCR_STK: + opnd = TclGetUInt1AtPtr(pc+1); + valuePtr = stackPtr[stackTop]; + if (valuePtr->typePtr == &tclIntType) { i = valuePtr->internalRep.longValue; - DECACHE_STACK_INFO(); - value2Ptr = TclIncrVar2(interp, objPtr, (Tcl_Obj *) NULL, i, - TCL_LEAVE_ERR_MSG); - CACHE_STACK_INFO(); - if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("\"%.30s\" (by %ld) => ERROR: ", - O2S(objPtr), i), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(objPtr); - Tcl_DecrRefCount(valuePtr); - result = TCL_ERROR; +#ifndef TCL_WIDE_INT_IS_LONG + } else if (valuePtr->typePtr == &tclWideIntType) { + i = Tcl_WideAsLong(valuePtr->internalRep.wideValue); +#endif /* TCL_WIDE_INT_IS_LONG */ + } else { + REQUIRE_WIDE_OR_INT(result, valuePtr, i, w); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("%u (by %s) => ERROR converting increment amount to int: ", + opnd, O2S(valuePtr)), Tcl_GetObjResult(interp)); goto checkForCatch; } - PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("\"%.30s\" (by %ld) => ", O2S(objPtr), i), - value2Ptr); - Tcl_DecrRefCount(objPtr); - Tcl_DecrRefCount(valuePtr); - ADJUST_PC(1); - - case INST_INCR_ARRAY1: - { - Tcl_Obj *elemPtr; - - opnd = TclGetUInt1AtPtr(pc+1); - valuePtr = POP_OBJECT(); - elemPtr = POP_OBJECT(); - if (valuePtr->typePtr != &tclIntType) { - result = tclIntType.setFromAnyProc(interp, valuePtr); - if (result != TCL_OK) { - TRACE_WITH_OBJ(("%u \"%.30s\" (by %s) => ERROR converting increment amount to int: ", - opnd, O2S(elemPtr), O2S(valuePtr)), - Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(elemPtr); - Tcl_DecrRefCount(valuePtr); - goto checkForCatch; - } - } - i = valuePtr->internalRep.longValue; - DECACHE_STACK_INFO(); - value2Ptr = TclIncrElementOfIndexedArray(interp, opnd, - elemPtr, i); - CACHE_STACK_INFO(); - if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ", - opnd, O2S(elemPtr), i), - Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(elemPtr); - Tcl_DecrRefCount(valuePtr); - result = TCL_ERROR; - goto checkForCatch; - } - PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ", - opnd, O2S(elemPtr), i), value2Ptr); - Tcl_DecrRefCount(elemPtr); - Tcl_DecrRefCount(valuePtr); - } - ADJUST_PC(2); - - case INST_INCR_ARRAY_STK: - { - Tcl_Obj *elemPtr; + FORCE_LONG(valuePtr, i, w); + } + stackTop--; + TclDecrRefCount(valuePtr); + switch (*pc) { + case INST_INCR_SCALAR1: + pcAdjustment = 2; + goto doIncrScalar; + case INST_INCR_ARRAY1: + pcAdjustment = 2; + goto doIncrArray; + default: + pcAdjustment = 1; + goto doIncrStk; + } - valuePtr = POP_OBJECT(); - elemPtr = POP_OBJECT(); - objPtr = POP_OBJECT(); /* array name */ - if (valuePtr->typePtr != &tclIntType) { - result = tclIntType.setFromAnyProc(interp, valuePtr); - if (result != TCL_OK) { - TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %s) => ERROR converting increment amount to int: ", - O2S(objPtr), O2S(elemPtr), O2S(valuePtr)), - Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(objPtr); - Tcl_DecrRefCount(elemPtr); - Tcl_DecrRefCount(valuePtr); - goto checkForCatch; - } - } - i = valuePtr->internalRep.longValue; - DECACHE_STACK_INFO(); - value2Ptr = TclIncrVar2(interp, objPtr, elemPtr, i, - TCL_LEAVE_ERR_MSG); - CACHE_STACK_INFO(); - if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ", - O2S(objPtr), O2S(elemPtr), i), - Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(objPtr); - Tcl_DecrRefCount(elemPtr); - Tcl_DecrRefCount(valuePtr); - result = TCL_ERROR; - goto checkForCatch; - } - PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ", - O2S(objPtr), O2S(elemPtr), i), value2Ptr); - Tcl_DecrRefCount(objPtr); - Tcl_DecrRefCount(elemPtr); - Tcl_DecrRefCount(valuePtr); - } - ADJUST_PC(1); + case INST_INCR_ARRAY_STK_IMM: + case INST_INCR_SCALAR_STK_IMM: + case INST_INCR_STK_IMM: + i = TclGetInt1AtPtr(pc+1); + pcAdjustment = 2; - case INST_INCR_SCALAR1_IMM: - opnd = TclGetUInt1AtPtr(pc+1); - i = TclGetInt1AtPtr(pc+2); - DECACHE_STACK_INFO(); - value2Ptr = TclIncrIndexedScalar(interp, opnd, i); - CACHE_STACK_INFO(); - if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("%u %ld => ERROR: ", opnd, i), - Tcl_GetObjResult(interp)); - result = TCL_ERROR; - goto checkForCatch; + doIncrStk: + if ((*pc == INST_INCR_ARRAY_STK_IMM) + || (*pc == INST_INCR_ARRAY_STK)) { + part2 = TclGetString(stackPtr[stackTop]); + objPtr = stackPtr[stackTop - 1]; + TRACE(("\"%.30s(%.30s)\" (by %ld) => ", + O2S(objPtr), part2, i)); + } else { + part2 = NULL; + objPtr = stackPtr[stackTop]; + TRACE(("\"%.30s\" (by %ld) => ", O2S(objPtr), i)); + } + part1 = TclGetString(objPtr); + + varPtr = TclObjLookupVar(interp, objPtr, part2, + TCL_LEAVE_ERR_MSG, "read", 0, 1, &arrayPtr); + if (varPtr == NULL) { + Tcl_AddObjErrorInfo(interp, + "\n (reading value of variable to increment)", -1); + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; + goto checkForCatch; + } + cleanup = ((part2 == NULL)? 1 : 2); + goto doIncrVar; + + case INST_INCR_ARRAY1_IMM: + opnd = TclGetUInt1AtPtr(pc+1); + i = TclGetInt1AtPtr(pc+2); + pcAdjustment = 3; + + doIncrArray: + part2 = TclGetString(stackPtr[stackTop]); + arrayPtr = &(varFramePtr->compiledLocals[opnd]); + part1 = arrayPtr->name; + while (TclIsVarLink(arrayPtr)) { + arrayPtr = arrayPtr->value.linkPtr; + } + TRACE(("%u \"%.30s\" (by %ld) => ", + opnd, part2, i)); + varPtr = TclLookupArrayElement(interp, part1, part2, + TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr); + if (varPtr == NULL) { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + result = TCL_ERROR; + goto checkForCatch; + } + cleanup = 1; + goto doIncrVar; + + case INST_INCR_SCALAR1_IMM: + opnd = TclGetUInt1AtPtr(pc+1); + i = TclGetInt1AtPtr(pc+2); + pcAdjustment = 3; + + doIncrScalar: + varPtr = &(varFramePtr->compiledLocals[opnd]); + part1 = varPtr->name; + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + arrayPtr = NULL; + part2 = NULL; + cleanup = 0; + TRACE(("%u %ld => ", opnd, i)); + + + doIncrVar: + objPtr = varPtr->value.objPtr; + if (TclIsVarScalar(varPtr) + && !TclIsVarUndefined(varPtr) + && (varPtr->tracePtr == NULL) + && ((arrayPtr == NULL) + || (arrayPtr->tracePtr == NULL)) + && (objPtr->typePtr == &tclIntType)) { + /* + * No errors, no traces, the variable already has an + * integer value: inline processing. + */ + + i += objPtr->internalRep.longValue; + if (Tcl_IsShared(objPtr)) { + objResultPtr = Tcl_NewLongObj(i); + TclDecrRefCount(objPtr); + Tcl_IncrRefCount(objResultPtr); + varPtr->value.objPtr = objResultPtr; + } else { + Tcl_SetLongObj(objPtr, i); + objResultPtr = objPtr; } - PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("%u %ld => ", opnd, i), value2Ptr); - ADJUST_PC(3); - - case INST_INCR_SCALAR_STK_IMM: - case INST_INCR_STK_IMM: - objPtr = POP_OBJECT(); /* variable name */ - i = TclGetInt1AtPtr(pc+1); + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + } else { DECACHE_STACK_INFO(); - value2Ptr = TclIncrVar2(interp, objPtr, (Tcl_Obj *) NULL, i, - TCL_LEAVE_ERR_MSG); + objResultPtr = TclPtrIncrVar(interp, varPtr, arrayPtr, part1, + part2, i, TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); - if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("\"%.30s\" %ld => ERROR: ", - O2S(objPtr), i), Tcl_GetObjResult(interp)); + if (objResultPtr == NULL) { + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); result = TCL_ERROR; - Tcl_DecrRefCount(objPtr); goto checkForCatch; } - PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("\"%.30s\" %ld => ", O2S(objPtr), i), - value2Ptr); - TclDecrRefCount(objPtr); - ADJUST_PC(2); - - case INST_INCR_ARRAY1_IMM: - { - Tcl_Obj *elemPtr; - - opnd = TclGetUInt1AtPtr(pc+1); - i = TclGetInt1AtPtr(pc+2); - elemPtr = POP_OBJECT(); - DECACHE_STACK_INFO(); - value2Ptr = TclIncrElementOfIndexedArray(interp, opnd, - elemPtr, i); - CACHE_STACK_INFO(); - if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ", - opnd, O2S(elemPtr), i), - Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(elemPtr); - result = TCL_ERROR; - goto checkForCatch; - } - PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ", - opnd, O2S(elemPtr), i), value2Ptr); - Tcl_DecrRefCount(elemPtr); - } - ADJUST_PC(3); + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); +#ifndef TCL_COMPILE_DEBUG + if (*(pc+pcAdjustment) == INST_POP) { + NEXT_INST_V((pcAdjustment+1), cleanup, 0); + } +#endif + NEXT_INST_V(pcAdjustment, cleanup, 1); + + /* + * End of INST_INCR instructions. + * --------------------------------------------------------- + */ + + + case INST_JUMP1: + opnd = TclGetInt1AtPtr(pc+1); + TRACE(("%d => new pc %u\n", opnd, + (unsigned int)(pc + opnd - codePtr->codeStart))); + NEXT_INST_F(opnd, 0, 0); + + case INST_JUMP4: + opnd = TclGetInt4AtPtr(pc+1); + TRACE(("%d => new pc %u\n", opnd, + (unsigned int)(pc + opnd - codePtr->codeStart))); + NEXT_INST_F(opnd, 0, 0); + + case INST_JUMP_FALSE4: + opnd = 5; /* TRUE */ + pcAdjustment = TclGetInt4AtPtr(pc+1); /* FALSE */ + goto doJumpTrue; + + case INST_JUMP_TRUE4: + opnd = TclGetInt4AtPtr(pc+1); /* TRUE */ + pcAdjustment = 5; /* FALSE */ + goto doJumpTrue; + + case INST_JUMP_FALSE1: + opnd = 2; /* TRUE */ + pcAdjustment = TclGetInt1AtPtr(pc+1); /* FALSE */ + goto doJumpTrue; + + case INST_JUMP_TRUE1: + opnd = TclGetInt1AtPtr(pc+1); /* TRUE */ + pcAdjustment = 2; /* FALSE */ - case INST_INCR_ARRAY_STK_IMM: - { - Tcl_Obj *elemPtr; - - i = TclGetInt1AtPtr(pc+1); - elemPtr = POP_OBJECT(); - objPtr = POP_OBJECT(); /* array name */ - DECACHE_STACK_INFO(); - value2Ptr = TclIncrVar2(interp, objPtr, elemPtr, i, - TCL_LEAVE_ERR_MSG); - CACHE_STACK_INFO(); - if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ", - O2S(objPtr), O2S(elemPtr), i), - Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(objPtr); - Tcl_DecrRefCount(elemPtr); - result = TCL_ERROR; + doJumpTrue: + { + int b; + + valuePtr = stackPtr[stackTop]; + if (valuePtr->typePtr == &tclIntType) { + b = (valuePtr->internalRep.longValue != 0); + } else if (valuePtr->typePtr == &tclDoubleType) { + b = (valuePtr->internalRep.doubleValue != 0.0); +#ifndef TCL_WIDE_INT_IS_LONG + } else if (valuePtr->typePtr == &tclWideIntType) { + b = (valuePtr->internalRep.wideValue != W0); +#endif /* TCL_WIDE_INT_IS_LONG */ + } else { + result = Tcl_GetBooleanFromObj(interp, valuePtr, &b); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp)); goto checkForCatch; } - PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ", - O2S(objPtr), O2S(elemPtr), i), value2Ptr); - Tcl_DecrRefCount(objPtr); - Tcl_DecrRefCount(elemPtr); } - ADJUST_PC(2); - - case INST_JUMP1: -#ifdef TCL_COMPILE_DEBUG - opnd = TclGetInt1AtPtr(pc+1); - TRACE(("%d => new pc %u\n", opnd, - (unsigned int)(pc + opnd - codePtr->codeStart))); - pc += opnd; +#ifndef TCL_COMPILE_DEBUG + NEXT_INST_F((b? opnd : pcAdjustment), 1, 0); #else - pc += TclGetInt1AtPtr(pc+1); -#endif /* TCL_COMPILE_DEBUG */ - continue; - - case INST_JUMP4: - opnd = TclGetInt4AtPtr(pc+1); - TRACE(("%d => new pc %u\n", opnd, - (unsigned int)(pc + opnd - codePtr->codeStart))); - ADJUST_PC(opnd); - - case INST_JUMP_TRUE4: - opnd = TclGetInt4AtPtr(pc+1); - pcAdjustment = 5; - goto doJumpTrue; - - case INST_JUMP_TRUE1: - opnd = TclGetInt1AtPtr(pc+1); - pcAdjustment = 2; - - doJumpTrue: - { - int b; - - valuePtr = POP_OBJECT(); - if (valuePtr->typePtr == &tclIntType) { - b = (valuePtr->internalRep.longValue != 0); - } else if (valuePtr->typePtr == &tclDoubleType) { - b = (valuePtr->internalRep.doubleValue != 0.0); - } else { - result = Tcl_GetBooleanFromObj(interp, valuePtr, &b); - if (result != TCL_OK) { - TRACE_WITH_OBJ(("%d => ERROR: ", opnd), - Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(valuePtr); - goto checkForCatch; - } - } - if (b) { - TRACE(("%d => %.20s true, new pc %u\n", - opnd, O2S(valuePtr), + if (b) { + if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE1)) { + TRACE(("%d => %.20s true, new pc %u\n", opnd, O2S(valuePtr), (unsigned int)(pc+opnd - codePtr->codeStart))); - TclDecrRefCount(valuePtr); - ADJUST_PC(opnd); } else { + TRACE(("%d => %.20s true\n", pcAdjustment, O2S(valuePtr))); + } + NEXT_INST_F(opnd, 1, 0); + } else { + if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE1)) { TRACE(("%d => %.20s false\n", opnd, O2S(valuePtr))); - TclDecrRefCount(valuePtr); - ADJUST_PC(pcAdjustment); + } else { + opnd = pcAdjustment; + TRACE(("%d => %.20s false, new pc %u\n", opnd, O2S(valuePtr), + (unsigned int)(pc + opnd - codePtr->codeStart))); } + NEXT_INST_F(pcAdjustment, 1, 0); } - - case INST_JUMP_FALSE4: - opnd = TclGetInt4AtPtr(pc+1); - pcAdjustment = 5; - goto doJumpFalse; - - case INST_JUMP_FALSE1: - opnd = TclGetInt1AtPtr(pc+1); - pcAdjustment = 2; - - doJumpFalse: - { - int b; +#endif + } + + case INST_LOR: + case INST_LAND: + { + /* + * Operands must be boolean or numeric. No int->double + * conversions are performed. + */ - valuePtr = POP_OBJECT(); + int i1, i2; + int iResult; + char *s; + Tcl_ObjType *t1Ptr, *t2Ptr; + + value2Ptr = stackPtr[stackTop]; + valuePtr = stackPtr[stackTop - 1];; + t1Ptr = valuePtr->typePtr; + t2Ptr = value2Ptr->typePtr; + + if ((t1Ptr == &tclIntType) || (t1Ptr == &tclBooleanType)) { + i1 = (valuePtr->internalRep.longValue != 0); +#ifndef TCL_WIDE_INT_IS_LONG + } else if (t1Ptr == &tclWideIntType) { + i1 = (valuePtr->internalRep.wideValue != W0); +#endif /* TCL_WIDE_INT_IS_LONG */ + } else if (t1Ptr == &tclDoubleType) { + i1 = (valuePtr->internalRep.doubleValue != 0.0); + } else { + s = Tcl_GetStringFromObj(valuePtr, &length); + if (TclLooksLikeInt(s, length)) { +#ifdef TCL_WIDE_INT_IS_LONG + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, + valuePtr, &i); + i1 = (i != 0); +#else /* !TCL_WIDE_INT_IS_LONG */ + GET_WIDE_OR_INT(result, valuePtr, i, w); if (valuePtr->typePtr == &tclIntType) { - b = (valuePtr->internalRep.longValue != 0); - } else if (valuePtr->typePtr == &tclDoubleType) { - b = (valuePtr->internalRep.doubleValue != 0.0); + i1 = (i != 0); } else { - result = Tcl_GetBooleanFromObj(interp, valuePtr, &b); - if (result != TCL_OK) { - TRACE_WITH_OBJ(("%d => ERROR: ", opnd), - Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(valuePtr); - goto checkForCatch; - } - } - if (b) { - TRACE(("%d => %.20s true\n", opnd, O2S(valuePtr))); - TclDecrRefCount(valuePtr); - ADJUST_PC(pcAdjustment); - } else { - TRACE(("%d => %.20s false, new pc %u\n", - opnd, O2S(valuePtr), - (unsigned int)(pc + opnd - codePtr->codeStart))); - TclDecrRefCount(valuePtr); - ADJUST_PC(opnd); + i1 = (w != W0); } +#endif /* TCL_WIDE_INT_IS_LONG */ + } else { + result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL, + valuePtr, &i1); + i1 = (i1 != 0); } - - case INST_LOR: - case INST_LAND: - { - /* - * Operands must be boolean or numeric. No int->double - * conversions are performed. - */ - - int i1, i2; - int iResult; - char *s; - Tcl_ObjType *t1Ptr, *t2Ptr; - - value2Ptr = POP_OBJECT(); - valuePtr = POP_OBJECT(); - t1Ptr = valuePtr->typePtr; - t2Ptr = value2Ptr->typePtr; - - if ((t1Ptr == &tclIntType) || (t1Ptr == &tclBooleanType)) { - i1 = (valuePtr->internalRep.longValue != 0); - } else if (t1Ptr == &tclDoubleType) { - i1 = (valuePtr->internalRep.doubleValue != 0.0); - } else { - s = Tcl_GetStringFromObj(valuePtr, &length); - if (TclLooksLikeInt(s, length)) { - result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, - valuePtr, &i); - i1 = (i != 0); - } else { - result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL, - valuePtr, &i1); - i1 = (i1 != 0); - } - if (result != TCL_OK) { - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", - O2S(valuePtr), - (t1Ptr? t1Ptr->name : "null"))); - IllegalExprOperandType(interp, pc, valuePtr); - Tcl_DecrRefCount(valuePtr); - Tcl_DecrRefCount(value2Ptr); - goto checkForCatch; - } - } + if (result != TCL_OK) { + TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), + (t1Ptr? t1Ptr->name : "null"))); + IllegalExprOperandType(interp, pc, valuePtr); + goto checkForCatch; + } + } - if ((t2Ptr == &tclIntType) || (t2Ptr == &tclBooleanType)) { - i2 = (value2Ptr->internalRep.longValue != 0); - } else if (t2Ptr == &tclDoubleType) { - i2 = (value2Ptr->internalRep.doubleValue != 0.0); + if ((t2Ptr == &tclIntType) || (t2Ptr == &tclBooleanType)) { + i2 = (value2Ptr->internalRep.longValue != 0); +#ifndef TCL_WIDE_INT_IS_LONG + } else if (t2Ptr == &tclWideIntType) { + i2 = (value2Ptr->internalRep.wideValue != W0); +#endif /* TCL_WIDE_INT_IS_LONG */ + } else if (t2Ptr == &tclDoubleType) { + i2 = (value2Ptr->internalRep.doubleValue != 0.0); + } else { + s = Tcl_GetStringFromObj(value2Ptr, &length); + if (TclLooksLikeInt(s, length)) { +#ifdef TCL_WIDE_INT_IS_LONG + result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, + value2Ptr, &i); + i2 = (i != 0); +#else /* !TCL_WIDE_INT_IS_LONG */ + GET_WIDE_OR_INT(result, value2Ptr, i, w); + if (value2Ptr->typePtr == &tclIntType) { + i2 = (i != 0); } else { - s = Tcl_GetStringFromObj(value2Ptr, &length); - if (TclLooksLikeInt(s, length)) { - result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, - value2Ptr, &i); - i2 = (i != 0); - } else { - result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL, - value2Ptr, &i2); - } - if (result != TCL_OK) { - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", - O2S(value2Ptr), - (t2Ptr? t2Ptr->name : "null"))); - IllegalExprOperandType(interp, pc, value2Ptr); - Tcl_DecrRefCount(valuePtr); - Tcl_DecrRefCount(value2Ptr); - goto checkForCatch; - } + i2 = (w != W0); } +#endif /* TCL_WIDE_INT_IS_LONG */ + } else { + result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL, value2Ptr, &i2); + } + if (result != TCL_OK) { + TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr), + (t2Ptr? t2Ptr->name : "null"))); + IllegalExprOperandType(interp, pc, value2Ptr); + goto checkForCatch; + } + } + + /* + * Reuse the valuePtr object already on stack if possible. + */ + + if (*pc == INST_LOR) { + iResult = (i1 || i2); + } else { + iResult = (i1 && i2); + } + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewLongObj(iResult); + TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult)); + NEXT_INST_F(1, 2, 1); + } else { /* reuse the valuePtr object */ + TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult)); + Tcl_SetLongObj(valuePtr, iResult); + NEXT_INST_F(1, 1, 0); + } + } + + /* + * --------------------------------------------------------- + * Start of INST_LIST and related instructions. + */ + + case INST_LIST: + /* + * Pop the opnd (objc) top stack elements into a new list obj + * and then decrement their ref counts. + */ + + opnd = TclGetUInt4AtPtr(pc+1); + objResultPtr = Tcl_NewListObj(opnd, &(stackPtr[stackTop - (opnd-1)])); + TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); + NEXT_INST_V(5, opnd, 1); + + case INST_LIST_LENGTH: + valuePtr = stackPtr[stackTop]; + + result = Tcl_ListObjLength(interp, valuePtr, &length); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)), + Tcl_GetObjResult(interp)); + goto checkForCatch; + } + objResultPtr = Tcl_NewIntObj(length); + TRACE(("%.20s => %d\n", O2S(valuePtr), length)); + NEXT_INST_F(1, 1, 1); + + case INST_LIST_INDEX: + /*** lindex with objc == 3 ***/ + /* + * Pop the two operands + */ + value2Ptr = stackPtr[stackTop]; + valuePtr = stackPtr[stackTop- 1]; + + /* + * Extract the desired list element + */ + objResultPtr = TclLindexList(interp, valuePtr, value2Ptr); + if (objResultPtr == NULL) { + TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", O2S(valuePtr), O2S(value2Ptr)), + Tcl_GetObjResult(interp)); + result = TCL_ERROR; + goto checkForCatch; + } + + /* + * Stash the list element on the stack + */ + TRACE(("%.20s %.20s => %s\n", + O2S(valuePtr), O2S(value2Ptr), O2S(objResultPtr))); + NEXT_INST_F(1, 2, -1); /* already has the correct refCount */ + + case INST_LIST_INDEX_MULTI: + { + /* + * 'lindex' with multiple index args: + * + * Determine the count of index args. + */ + + int numIdx; + + opnd = TclGetUInt4AtPtr(pc+1); + numIdx = opnd-1; + + /* + * Do the 'lindex' operation. + */ + objResultPtr = TclLindexFlat(interp, stackPtr[stackTop - numIdx], + numIdx, stackPtr + stackTop - numIdx + 1); + + /* + * Check for errors + */ + if (objResultPtr == NULL) { + TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp)); + result = TCL_ERROR; + goto checkForCatch; + } + + /* + * Set result + */ + TRACE(("%d => %s\n", opnd, O2S(objResultPtr))); + NEXT_INST_V(5, opnd, -1); + } + + case INST_LSET_FLAT: + { + /* + * Lset with 3, 5, or more args. Get the number + * of index args. + */ + int numIdx; + + opnd = TclGetUInt4AtPtr( pc + 1 ); + numIdx = opnd - 2; + + /* + * Get the old value of variable, and remove the stack ref. + * This is safe because the variable still references the + * object; the ref count will never go zero here. + */ + value2Ptr = POP_OBJECT(); + TclDecrRefCount(value2Ptr); /* This one should be done here */ + + /* + * Get the new element value. + */ + valuePtr = stackPtr[stackTop]; + + /* + * Compute the new variable value + */ + objResultPtr = TclLsetFlat(interp, value2Ptr, numIdx, + stackPtr + stackTop - numIdx, valuePtr); + + + /* + * Check for errors + */ + if (objResultPtr == NULL) { + TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp)); + result = TCL_ERROR; + goto checkForCatch; + } + + /* + * Set result + */ + TRACE(("%d => %s\n", opnd, O2S(objResultPtr))); + NEXT_INST_V(5, (numIdx+1), -1); + } + + case INST_LSET_LIST: + /* + * 'lset' with 4 args. + * + * Get the old value of variable, and remove the stack ref. + * This is safe because the variable still references the + * object; the ref count will never go zero here. + */ + objPtr = POP_OBJECT(); + TclDecrRefCount(objPtr); /* This one should be done here */ + + /* + * Get the new element value, and the index list + */ + valuePtr = stackPtr[stackTop]; + value2Ptr = stackPtr[stackTop - 1]; + + /* + * Compute the new variable value + */ + objResultPtr = TclLsetList(interp, objPtr, value2Ptr, valuePtr); + + /* + * Check for errors + */ + if (objResultPtr == NULL) { + TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(value2Ptr)), + Tcl_GetObjResult(interp)); + result = TCL_ERROR; + goto checkForCatch; + } + + /* + * Set result + */ + TRACE(("=> %s\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, -1); + + /* + * End of INST_LIST and related instructions. + * --------------------------------------------------------- + */ + + case INST_STR_EQ: + case INST_STR_NEQ: + { + /* + * String (in)equality check + */ + int iResult; + + value2Ptr = stackPtr[stackTop]; + valuePtr = stackPtr[stackTop - 1]; + + if (valuePtr == value2Ptr) { + /* + * On the off-chance that the objects are the same, + * we don't really have to think hard about equality. + */ + iResult = (*pc == INST_STR_EQ); + } else { + char *s1, *s2; + int s1len, s2len; + + s1 = Tcl_GetStringFromObj(valuePtr, &s1len); + s2 = Tcl_GetStringFromObj(value2Ptr, &s2len); + if (s1len == s2len) { /* - * Reuse the valuePtr object already on stack if possible. + * We only need to check (in)equality when + * we have equal length strings. */ - - if (*pc == INST_LOR) { - iResult = (i1 || i2); + if (*pc == INST_STR_NEQ) { + iResult = (strcmp(s1, s2) != 0); } else { - iResult = (i1 && i2); + /* INST_STR_EQ */ + iResult = (strcmp(s1, s2) == 0); } - if (Tcl_IsShared(valuePtr)) { - PUSH_OBJECT(Tcl_NewLongObj(iResult)); - TRACE(("%.20s %.20s => %d\n", - O2S(valuePtr), O2S(value2Ptr), iResult)); - TclDecrRefCount(valuePtr); - } else { /* reuse the valuePtr object */ - TRACE(("%.20s %.20s => %d\n", - O2S(valuePtr), O2S(value2Ptr), iResult)); - Tcl_SetLongObj(valuePtr, iResult); - ++stackTop; /* valuePtr now on stk top has right r.c. */ - } - TclDecrRefCount(value2Ptr); + } else { + iResult = (*pc == INST_STR_NEQ); } - ADJUST_PC(1); - - case INST_EQ: - case INST_NEQ: - case INST_LT: - case INST_GT: - case INST_LE: - case INST_GE: - { + } + + TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult)); + + /* + * Peep-hole optimisation: if you're about to jump, do jump + * from here. + */ + + pc++; +#ifndef TCL_COMPILE_DEBUG + switch (*pc) { + case INST_JUMP_FALSE1: + NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); + case INST_JUMP_TRUE1: + NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0); + case INST_JUMP_FALSE4: + NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); + case INST_JUMP_TRUE4: + NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0); + } +#endif + objResultPtr = Tcl_NewIntObj(iResult); + NEXT_INST_F(0, 2, 1); + } + + case INST_STR_CMP: + { + /* + * String compare + */ + CONST char *s1, *s2; + int s1len, s2len, iResult; + + value2Ptr = stackPtr[stackTop]; + valuePtr = stackPtr[stackTop - 1]; + + /* + * The comparison function should compare up to the + * minimum byte length only. + */ + if (valuePtr == value2Ptr) { + /* + * In the pure equality case, set lengths too for + * the checks below (or we could goto beyond it). + */ + iResult = s1len = s2len = 0; + } else if ((valuePtr->typePtr == &tclByteArrayType) + && (value2Ptr->typePtr == &tclByteArrayType)) { + s1 = (char *) Tcl_GetByteArrayFromObj(valuePtr, &s1len); + s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len); + iResult = memcmp(s1, s2, + (size_t) ((s1len < s2len) ? s1len : s2len)); + } else if (((valuePtr->typePtr == &tclStringType) + && (value2Ptr->typePtr == &tclStringType))) { + /* + * Do a unicode-specific comparison if both of the args + * are of String type. In benchmark testing this proved + * the most efficient check between the unicode and + * string comparison operations. + */ + Tcl_UniChar *uni1, *uni2; + uni1 = Tcl_GetUnicodeFromObj(valuePtr, &s1len); + uni2 = Tcl_GetUnicodeFromObj(value2Ptr, &s2len); + iResult = TclUniCharNcmp(uni1, uni2, + (unsigned) ((s1len < s2len) ? s1len : s2len)); + } else { + /* + * We can't do a simple memcmp in order to handle the + * special Tcl \xC0\x80 null encoding for utf-8. + */ + s1 = Tcl_GetStringFromObj(valuePtr, &s1len); + s2 = Tcl_GetStringFromObj(value2Ptr, &s2len); + iResult = TclpUtfNcmp2(s1, s2, + (size_t) ((s1len < s2len) ? s1len : s2len)); + } + + /* + * Make sure only -1,0,1 is returned + */ + if (iResult == 0) { + iResult = s1len - s2len; + } + if (iResult < 0) { + iResult = -1; + } else if (iResult > 0) { + iResult = 1; + } + + objResultPtr = Tcl_NewIntObj(iResult); + TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult)); + NEXT_INST_F(1, 2, 1); + } + + case INST_STR_LEN: + { + int length1; + + valuePtr = stackPtr[stackTop]; + + if (valuePtr->typePtr == &tclByteArrayType) { + (void) Tcl_GetByteArrayFromObj(valuePtr, &length1); + } else { + length1 = Tcl_GetCharLength(valuePtr); + } + objResultPtr = Tcl_NewIntObj(length1); + TRACE(("%.20s => %d\n", O2S(valuePtr), length1)); + NEXT_INST_F(1, 1, 1); + } + + case INST_STR_INDEX: + { + /* + * String compare + */ + int index; + bytes = NULL; /* lint */ + + value2Ptr = stackPtr[stackTop]; + valuePtr = stackPtr[stackTop - 1]; + + /* + * If we have a ByteArray object, avoid indexing in the + * Utf string since the byte array contains one byte per + * character. Otherwise, use the Unicode string rep to + * get the index'th char. + */ + + if (valuePtr->typePtr == &tclByteArrayType) { + bytes = (char *)Tcl_GetByteArrayFromObj(valuePtr, &length); + } else { + /* + * Get Unicode char length to calulate what 'end' means. + */ + length = Tcl_GetCharLength(valuePtr); + } + + result = TclGetIntForIndex(interp, value2Ptr, length - 1, &index); + if (result != TCL_OK) { + goto checkForCatch; + } + + if ((index >= 0) && (index < length)) { + if (valuePtr->typePtr == &tclByteArrayType) { + objResultPtr = Tcl_NewByteArrayObj((unsigned char *) + (&bytes[index]), 1); + } else { + char buf[TCL_UTF_MAX]; + Tcl_UniChar ch; + + ch = Tcl_GetUniChar(valuePtr, index); /* - * Any type is allowed but the two operands must have the - * same type. We will compute value op value2. + * This could be: + * Tcl_NewUnicodeObj((CONST Tcl_UniChar *)&ch, 1) + * but creating the object as a string seems to be + * faster in practical use. */ + length = Tcl_UniCharToUtf(ch, buf); + objResultPtr = Tcl_NewStringObj(buf, length); + } + } else { + TclNewObj(objResultPtr); + } + + TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr), + O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } + + case INST_STR_MATCH: + { + int nocase, match; + + nocase = TclGetInt1AtPtr(pc+1); + valuePtr = stackPtr[stackTop]; /* String */ + value2Ptr = stackPtr[stackTop - 1]; /* Pattern */ + + /* + * Check that at least one of the objects is Unicode before + * promoting both. + */ + if ((valuePtr->typePtr == &tclStringType) + || (value2Ptr->typePtr == &tclStringType)) { + match = Tcl_UniCharCaseMatch(Tcl_GetUnicode(valuePtr), + Tcl_GetUnicode(value2Ptr), nocase); + } else { + match = Tcl_StringCaseMatch(TclGetString(valuePtr), + TclGetString(value2Ptr), nocase); + } + + /* + * Reuse value2Ptr object already on stack if possible. + * Adjustment is 2 due to the nocase byte + */ + + TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match)); + if (Tcl_IsShared(value2Ptr)) { + objResultPtr = Tcl_NewIntObj(match); + NEXT_INST_F(2, 2, 1); + } else { /* reuse the valuePtr object */ + Tcl_SetIntObj(value2Ptr, match); + NEXT_INST_F(2, 1, 0); + } + } + + case INST_EQ: + case INST_NEQ: + case INST_LT: + case INST_GT: + case INST_LE: + case INST_GE: + { + /* + * Any type is allowed but the two operands must have the + * same type. We will compute value op value2. + */ - Tcl_ObjType *t1Ptr, *t2Ptr; - char *s1 = NULL; /* Init. avoids compiler warning. */ - char *s2 = NULL; /* Init. avoids compiler warning. */ - long i2 = 0; /* Init. avoids compiler warning. */ - double d1 = 0.0; /* Init. avoids compiler warning. */ - double d2 = 0.0; /* Init. avoids compiler warning. */ - long iResult = 0; /* Init. avoids compiler warning. */ + Tcl_ObjType *t1Ptr, *t2Ptr; + char *s1 = NULL; /* Init. avoids compiler warning. */ + char *s2 = NULL; /* Init. avoids compiler warning. */ + long i2 = 0; /* Init. avoids compiler warning. */ + double d1 = 0.0; /* Init. avoids compiler warning. */ + double d2 = 0.0; /* Init. avoids compiler warning. */ + long iResult = 0; /* Init. avoids compiler warning. */ - value2Ptr = POP_OBJECT(); - valuePtr = POP_OBJECT(); + value2Ptr = stackPtr[stackTop]; + valuePtr = stackPtr[stackTop - 1]; + + if (valuePtr == value2Ptr) { + /* + * Optimize the equal object case. + */ + switch (*pc) { + case INST_EQ: + case INST_LE: + case INST_GE: + iResult = 1; + break; + case INST_NEQ: + case INST_LT: + case INST_GT: + iResult = 0; + break; + } + goto foundResult; + } + + t1Ptr = valuePtr->typePtr; + t2Ptr = value2Ptr->typePtr; + + /* + * We only want to coerce numeric validation if neither type + * is NULL. A NULL type means the arg is essentially an empty + * object ("", {} or [list]). + */ + if (!( (!t1Ptr && !valuePtr->bytes) + || (valuePtr->bytes && !valuePtr->length) + || (!t2Ptr && !value2Ptr->bytes) + || (value2Ptr->bytes && !value2Ptr->length))) { + if (!IS_NUMERIC_TYPE(t1Ptr)) { + s1 = Tcl_GetStringFromObj(valuePtr, &length); + if (TclLooksLikeInt(s1, length)) { + GET_WIDE_OR_INT(iResult, valuePtr, i, w); + } else { + (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, + valuePtr, &d1); + } t1Ptr = valuePtr->typePtr; + } + if (!IS_NUMERIC_TYPE(t2Ptr)) { + s2 = Tcl_GetStringFromObj(value2Ptr, &length); + if (TclLooksLikeInt(s2, length)) { + GET_WIDE_OR_INT(iResult, value2Ptr, i2, w); + } else { + (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, + value2Ptr, &d2); + } t2Ptr = value2Ptr->typePtr; - - /* - * We only want to coerce numeric validation if - * neither type is NULL. A NULL type means the arg is - * essentially an empty object ("", {} or [list]). - */ - if (!((((t1Ptr == NULL) && (valuePtr->bytes == NULL)) - || (valuePtr->bytes && (valuePtr->length == 0))) - || (((t2Ptr == NULL) && (value2Ptr->bytes == NULL)) - || (value2Ptr->bytes && (value2Ptr->length == 0))))) { - if ((t1Ptr != &tclIntType) && (t1Ptr != &tclDoubleType)) { - s1 = Tcl_GetStringFromObj(valuePtr, &length); - if (TclLooksLikeInt(s1, length)) { - (void) Tcl_GetLongFromObj((Tcl_Interp *) NULL, - valuePtr, &i); - } else { - (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, - valuePtr, &d1); - } - t1Ptr = valuePtr->typePtr; + } + } + if (!IS_NUMERIC_TYPE(t1Ptr) || !IS_NUMERIC_TYPE(t2Ptr)) { + /* + * One operand is not numeric. Compare as strings. NOTE: + * strcmp is not correct for \x00 < \x01, but that is + * unlikely to occur here. We could use the TclUtfNCmp2 + * to handle this. + */ + int s1len, s2len; + s1 = Tcl_GetStringFromObj(valuePtr, &s1len); + s2 = Tcl_GetStringFromObj(value2Ptr, &s2len); + switch (*pc) { + case INST_EQ: + if (s1len == s2len) { + iResult = (strcmp(s1, s2) == 0); + } else { + iResult = 0; } - if ((t2Ptr != &tclIntType) && (t2Ptr != &tclDoubleType)) { - s2 = Tcl_GetStringFromObj(value2Ptr, &length); - if (TclLooksLikeInt(s2, length)) { - (void) Tcl_GetLongFromObj((Tcl_Interp *) NULL, - value2Ptr, &i2); - } else { - (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, - value2Ptr, &d2); - } - t2Ptr = value2Ptr->typePtr; + break; + case INST_NEQ: + if (s1len == s2len) { + iResult = (strcmp(s1, s2) != 0); + } else { + iResult = 1; } + break; + case INST_LT: + iResult = (strcmp(s1, s2) < 0); + break; + case INST_GT: + iResult = (strcmp(s1, s2) > 0); + break; + case INST_LE: + iResult = (strcmp(s1, s2) <= 0); + break; + case INST_GE: + iResult = (strcmp(s1, s2) >= 0); + break; + } + } else if ((t1Ptr == &tclDoubleType) + || (t2Ptr == &tclDoubleType)) { + /* + * Compare as doubles. + */ + if (t1Ptr == &tclDoubleType) { + d1 = valuePtr->internalRep.doubleValue; + GET_DOUBLE_VALUE(d2, value2Ptr, t2Ptr); + } else { /* t1Ptr is integer, t2Ptr is double */ + GET_DOUBLE_VALUE(d1, valuePtr, t1Ptr); + d2 = value2Ptr->internalRep.doubleValue; + } + switch (*pc) { + case INST_EQ: + iResult = d1 == d2; + break; + case INST_NEQ: + iResult = d1 != d2; + break; + case INST_LT: + iResult = d1 < d2; + break; + case INST_GT: + iResult = d1 > d2; + break; + case INST_LE: + iResult = d1 <= d2; + break; + case INST_GE: + iResult = d1 >= d2; + break; + } +#ifndef TCL_WIDE_INT_IS_LONG + } else if ((t1Ptr == &tclWideIntType) + || (t2Ptr == &tclWideIntType)) { + Tcl_WideInt w2; + /* + * Compare as wide ints (neither are doubles) + */ + if (t1Ptr == &tclIntType) { + w = Tcl_LongAsWide(valuePtr->internalRep.longValue); + w2 = value2Ptr->internalRep.wideValue; + } else if (t2Ptr == &tclIntType) { + w = valuePtr->internalRep.wideValue; + w2 = Tcl_LongAsWide(value2Ptr->internalRep.longValue); + } else { + w = valuePtr->internalRep.wideValue; + w2 = value2Ptr->internalRep.wideValue; + } + switch (*pc) { + case INST_EQ: + iResult = w == w2; + break; + case INST_NEQ: + iResult = w != w2; + break; + case INST_LT: + iResult = w < w2; + break; + case INST_GT: + iResult = w > w2; + break; + case INST_LE: + iResult = w <= w2; + break; + case INST_GE: + iResult = w >= w2; + break; + } +#endif /* TCL_WIDE_INT_IS_LONG */ + } else { + /* + * Compare as ints. + */ + i = valuePtr->internalRep.longValue; + i2 = value2Ptr->internalRep.longValue; + switch (*pc) { + case INST_EQ: + iResult = i == i2; + break; + case INST_NEQ: + iResult = i != i2; + break; + case INST_LT: + iResult = i < i2; + break; + case INST_GT: + iResult = i > i2; + break; + case INST_LE: + iResult = i <= i2; + break; + case INST_GE: + iResult = i >= i2; + break; + } + } + + foundResult: + TRACE(("%.20s %.20s => %ld\n", O2S(valuePtr), O2S(value2Ptr), iResult)); + + /* + * Peep-hole optimisation: if you're about to jump, do jump + * from here. + */ + + pc++; +#ifndef TCL_COMPILE_DEBUG + switch (*pc) { + case INST_JUMP_FALSE1: + NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); + case INST_JUMP_TRUE1: + NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0); + case INST_JUMP_FALSE4: + NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); + case INST_JUMP_TRUE4: + NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0); + } +#endif + objResultPtr = Tcl_NewIntObj(iResult); + NEXT_INST_F(0, 2, 1); + } + + case INST_MOD: + case INST_LSHIFT: + case INST_RSHIFT: + case INST_BITOR: + case INST_BITXOR: + case INST_BITAND: + { + /* + * Only integers are allowed. We compute value op value2. + */ + + long i2 = 0, rem, negative; + long iResult = 0; /* Init. avoids compiler warning. */ +#ifndef TCL_WIDE_INT_IS_LONG + Tcl_WideInt w2, wResult = W0; + int doWide = 0; +#endif /* TCL_WIDE_INT_IS_LONG */ + + value2Ptr = stackPtr[stackTop]; + valuePtr = stackPtr[stackTop - 1]; + if (valuePtr->typePtr == &tclIntType) { + i = valuePtr->internalRep.longValue; +#ifndef TCL_WIDE_INT_IS_LONG + } else if (valuePtr->typePtr == &tclWideIntType) { + w = valuePtr->internalRep.wideValue; +#endif /* TCL_WIDE_INT_IS_LONG */ + } else { /* try to convert to int */ + REQUIRE_WIDE_OR_INT(result, valuePtr, i, w); + if (result != TCL_OK) { + TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", + O2S(valuePtr), O2S(value2Ptr), + (valuePtr->typePtr? + valuePtr->typePtr->name : "null"))); + IllegalExprOperandType(interp, pc, valuePtr); + goto checkForCatch; + } + } + if (value2Ptr->typePtr == &tclIntType) { + i2 = value2Ptr->internalRep.longValue; +#ifndef TCL_WIDE_INT_IS_LONG + } else if (value2Ptr->typePtr == &tclWideIntType) { + w2 = value2Ptr->internalRep.wideValue; +#endif /* TCL_WIDE_INT_IS_LONG */ + } else { + REQUIRE_WIDE_OR_INT(result, value2Ptr, i2, w2); + if (result != TCL_OK) { + TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", + O2S(valuePtr), O2S(value2Ptr), + (value2Ptr->typePtr? + value2Ptr->typePtr->name : "null"))); + IllegalExprOperandType(interp, pc, value2Ptr); + goto checkForCatch; + } + } + + switch (*pc) { + case INST_MOD: + /* + * This code is tricky: C doesn't guarantee much about + * the quotient or remainder, but Tcl does. The + * remainder always has the same sign as the divisor and + * a smaller absolute value. + */ +#ifdef TCL_WIDE_INT_IS_LONG + if (i2 == 0) { + TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2)); + goto divideByZero; + } +#else /* !TCL_WIDE_INT_IS_LONG */ + if (value2Ptr->typePtr == &tclWideIntType && w2 == W0) { + if (valuePtr->typePtr == &tclIntType) { + LLTRACE(("%ld "LLD" => DIVIDE BY ZERO\n", i, w2)); + } else { + LLTRACE((LLD" "LLD" => DIVIDE BY ZERO\n", w, w2)); } - if (((t1Ptr != &tclIntType) && (t1Ptr != &tclDoubleType)) - || ((t2Ptr != &tclIntType) && (t2Ptr != &tclDoubleType))) { - /* - * One operand is not numeric. Compare as strings. - */ - int cmpValue; - s1 = Tcl_GetString(valuePtr); - s2 = Tcl_GetString(value2Ptr); - cmpValue = strcmp(s1, s2); - switch (*pc) { - case INST_EQ: - iResult = (cmpValue == 0); - break; - case INST_NEQ: - iResult = (cmpValue != 0); - break; - case INST_LT: - iResult = (cmpValue < 0); - break; - case INST_GT: - iResult = (cmpValue > 0); - break; - case INST_LE: - iResult = (cmpValue <= 0); - break; - case INST_GE: - iResult = (cmpValue >= 0); - break; - } - } else if ((t1Ptr == &tclDoubleType) - || (t2Ptr == &tclDoubleType)) { - /* - * Compare as doubles. - */ - if (t1Ptr == &tclDoubleType) { - d1 = valuePtr->internalRep.doubleValue; - if (t2Ptr == &tclIntType) { - d2 = value2Ptr->internalRep.longValue; - } else { - d2 = value2Ptr->internalRep.doubleValue; - } - } else { /* t1Ptr is int, t2Ptr is double */ - d1 = valuePtr->internalRep.longValue; - d2 = value2Ptr->internalRep.doubleValue; - } - switch (*pc) { - case INST_EQ: - iResult = d1 == d2; - break; - case INST_NEQ: - iResult = d1 != d2; - break; - case INST_LT: - iResult = d1 < d2; - break; - case INST_GT: - iResult = d1 > d2; - break; - case INST_LE: - iResult = d1 <= d2; - break; - case INST_GE: - iResult = d1 >= d2; - break; - } + goto divideByZero; + } + if (value2Ptr->typePtr == &tclIntType && i2 == 0) { + if (valuePtr->typePtr == &tclIntType) { + TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2)); } else { - /* - * Compare as ints. - */ - i = valuePtr->internalRep.longValue; - i2 = value2Ptr->internalRep.longValue; - switch (*pc) { - case INST_EQ: - iResult = i == i2; - break; - case INST_NEQ: - iResult = i != i2; - break; - case INST_LT: - iResult = i < i2; - break; - case INST_GT: - iResult = i > i2; - break; - case INST_LE: - iResult = i <= i2; - break; - case INST_GE: - iResult = i >= i2; - break; - } + LLTRACE((LLD" %ld => DIVIDE BY ZERO\n", w, i2)); } - + goto divideByZero; + } +#endif /* TCL_WIDE_INT_IS_LONG */ + negative = 0; +#ifndef TCL_WIDE_INT_IS_LONG + if (valuePtr->typePtr == &tclWideIntType + || value2Ptr->typePtr == &tclWideIntType) { + Tcl_WideInt wRemainder; /* - * Reuse the valuePtr object already on stack if possible. + * Promote to wide */ - - if (Tcl_IsShared(valuePtr)) { - PUSH_OBJECT(Tcl_NewLongObj(iResult)); - TRACE(("%.20s %.20s => %ld\n", - O2S(valuePtr), O2S(value2Ptr), iResult)); - TclDecrRefCount(valuePtr); - } else { /* reuse the valuePtr object */ - TRACE(("%.20s %.20s => %ld\n", - O2S(valuePtr), O2S(value2Ptr), iResult)); - Tcl_SetLongObj(valuePtr, iResult); - ++stackTop; /* valuePtr now on stk top has right r.c. */ + if (valuePtr->typePtr == &tclIntType) { + w = Tcl_LongAsWide(i); + } else if (value2Ptr->typePtr == &tclIntType) { + w2 = Tcl_LongAsWide(i2); } - TclDecrRefCount(value2Ptr); + if (w2 < 0) { + w2 = -w2; + w = -w; + negative = 1; + } + wRemainder = w % w2; + if (wRemainder < 0) { + wRemainder += w2; + } + if (negative) { + wRemainder = -wRemainder; + } + wResult = wRemainder; + doWide = 1; + break; } - ADJUST_PC(1); - - case INST_MOD: +#endif /* TCL_WIDE_INT_IS_LONG */ + if (i2 < 0) { + i2 = -i2; + i = -i; + negative = 1; + } + rem = i % i2; + if (rem < 0) { + rem += i2; + } + if (negative) { + rem = -rem; + } + iResult = rem; + break; case INST_LSHIFT: +#ifndef TCL_WIDE_INT_IS_LONG + /* + * Shifts are never usefully 64-bits wide! + */ + FORCE_LONG(value2Ptr, i2, w2); + if (valuePtr->typePtr == &tclWideIntType) { +#ifdef TCL_COMPILE_DEBUG + w2 = Tcl_LongAsWide(i2); +#endif /* TCL_COMPILE_DEBUG */ + wResult = w << i2; + doWide = 1; + break; + } +#endif /* TCL_WIDE_INT_IS_LONG */ + iResult = i << i2; + break; case INST_RSHIFT: + /* + * The following code is a bit tricky: it ensures that + * right shifts propagate the sign bit even on machines + * where ">>" won't do it by default. + */ +#ifndef TCL_WIDE_INT_IS_LONG + /* + * Shifts are never usefully 64-bits wide! + */ + FORCE_LONG(value2Ptr, i2, w2); + if (valuePtr->typePtr == &tclWideIntType) { +#ifdef TCL_COMPILE_DEBUG + w2 = Tcl_LongAsWide(i2); +#endif /* TCL_COMPILE_DEBUG */ + if (w < 0) { + wResult = ~((~w) >> i2); + } else { + wResult = w >> i2; + } + doWide = 1; + break; + } +#endif /* TCL_WIDE_INT_IS_LONG */ + if (i < 0) { + iResult = ~((~i) >> i2); + } else { + iResult = i >> i2; + } + break; case INST_BITOR: +#ifndef TCL_WIDE_INT_IS_LONG + if (valuePtr->typePtr == &tclWideIntType + || value2Ptr->typePtr == &tclWideIntType) { + /* + * Promote to wide + */ + if (valuePtr->typePtr == &tclIntType) { + w = Tcl_LongAsWide(i); + } else if (value2Ptr->typePtr == &tclIntType) { + w2 = Tcl_LongAsWide(i2); + } + wResult = w | w2; + doWide = 1; + break; + } +#endif /* TCL_WIDE_INT_IS_LONG */ + iResult = i | i2; + break; case INST_BITXOR: +#ifndef TCL_WIDE_INT_IS_LONG + if (valuePtr->typePtr == &tclWideIntType + || value2Ptr->typePtr == &tclWideIntType) { + /* + * Promote to wide + */ + if (valuePtr->typePtr == &tclIntType) { + w = Tcl_LongAsWide(i); + } else if (value2Ptr->typePtr == &tclIntType) { + w2 = Tcl_LongAsWide(i2); + } + wResult = w ^ w2; + doWide = 1; + break; + } +#endif /* TCL_WIDE_INT_IS_LONG */ + iResult = i ^ i2; + break; case INST_BITAND: - { +#ifndef TCL_WIDE_INT_IS_LONG + if (valuePtr->typePtr == &tclWideIntType + || value2Ptr->typePtr == &tclWideIntType) { /* - * Only integers are allowed. We compute value op value2. + * Promote to wide */ + if (valuePtr->typePtr == &tclIntType) { + w = Tcl_LongAsWide(i); + } else if (value2Ptr->typePtr == &tclIntType) { + w2 = Tcl_LongAsWide(i2); + } + wResult = w & w2; + doWide = 1; + break; + } +#endif /* TCL_WIDE_INT_IS_LONG */ + iResult = i & i2; + break; + } - long i2, rem, negative; - long iResult = 0; /* Init. avoids compiler warning. */ + /* + * Reuse the valuePtr object already on stack if possible. + */ - value2Ptr = POP_OBJECT(); - valuePtr = POP_OBJECT(); - if (valuePtr->typePtr == &tclIntType) { - i = valuePtr->internalRep.longValue; - } else { /* try to convert to int */ - result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, - valuePtr, &i); - if (result != TCL_OK) { - TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", - O2S(valuePtr), O2S(value2Ptr), - (valuePtr->typePtr? - valuePtr->typePtr->name : "null"))); - IllegalExprOperandType(interp, pc, valuePtr); - Tcl_DecrRefCount(valuePtr); - Tcl_DecrRefCount(value2Ptr); - goto checkForCatch; + if (Tcl_IsShared(valuePtr)) { +#ifndef TCL_WIDE_INT_IS_LONG + if (doWide) { + objResultPtr = Tcl_NewWideIntObj(wResult); + LLTRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult)); + } else { +#endif /* TCL_WIDE_INT_IS_LONG */ + objResultPtr = Tcl_NewLongObj(iResult); + TRACE(("%ld %ld => %ld\n", i, i2, iResult)); +#ifndef TCL_WIDE_INT_IS_LONG + } +#endif /* TCL_WIDE_INT_IS_LONG */ + NEXT_INST_F(1, 2, 1); + } else { /* reuse the valuePtr object */ +#ifndef TCL_WIDE_INT_IS_LONG + if (doWide) { + LLTRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult)); + Tcl_SetWideIntObj(valuePtr, wResult); + } else { +#endif /* TCL_WIDE_INT_IS_LONG */ + TRACE(("%ld %ld => %ld\n", i, i2, iResult)); + Tcl_SetLongObj(valuePtr, iResult); +#ifndef TCL_WIDE_INT_IS_LONG + } +#endif /* TCL_WIDE_INT_IS_LONG */ + NEXT_INST_F(1, 1, 0); + } + } + + case INST_ADD: + case INST_SUB: + case INST_MULT: + case INST_DIV: + { + /* + * Operands must be numeric and ints get converted to floats + * if necessary. We compute value op value2. + */ + + Tcl_ObjType *t1Ptr, *t2Ptr; + long i2 = 0, quot, rem; /* Init. avoids compiler warning. */ + double d1, d2; + long iResult = 0; /* Init. avoids compiler warning. */ + double dResult = 0.0; /* Init. avoids compiler warning. */ + int doDouble = 0; /* 1 if doing floating arithmetic */ +#ifndef TCL_WIDE_INT_IS_LONG + Tcl_WideInt w2, wquot, wrem; + Tcl_WideInt wResult = W0; /* Init. avoids compiler warning. */ + int doWide = 0; /* 1 if doing wide arithmetic. */ +#endif /* TCL_WIDE_INT_IS_LONG */ + + value2Ptr = stackPtr[stackTop]; + valuePtr = stackPtr[stackTop - 1]; + t1Ptr = valuePtr->typePtr; + t2Ptr = value2Ptr->typePtr; + + if (t1Ptr == &tclIntType) { + i = valuePtr->internalRep.longValue; +#ifndef TCL_WIDE_INT_IS_LONG + } else if (t1Ptr == &tclWideIntType) { + w = valuePtr->internalRep.wideValue; +#endif /* TCL_WIDE_INT_IS_LONG */ + } else if ((t1Ptr == &tclDoubleType) + && (valuePtr->bytes == NULL)) { + /* + * We can only use the internal rep directly if there is + * no string rep. Otherwise the string rep might actually + * look like an integer, which is preferred. + */ + + d1 = valuePtr->internalRep.doubleValue; + } else { + char *s = Tcl_GetStringFromObj(valuePtr, &length); + if (TclLooksLikeInt(s, length)) { + GET_WIDE_OR_INT(result, valuePtr, i, w); + } else { + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, + valuePtr, &d1); + } + if (result != TCL_OK) { + TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", + s, O2S(valuePtr), + (valuePtr->typePtr? + valuePtr->typePtr->name : "null"))); + IllegalExprOperandType(interp, pc, valuePtr); + goto checkForCatch; + } + t1Ptr = valuePtr->typePtr; + } + + if (t2Ptr == &tclIntType) { + i2 = value2Ptr->internalRep.longValue; +#ifndef TCL_WIDE_INT_IS_LONG + } else if (t2Ptr == &tclWideIntType) { + w2 = value2Ptr->internalRep.wideValue; +#endif /* TCL_WIDE_INT_IS_LONG */ + } else if ((t2Ptr == &tclDoubleType) + && (value2Ptr->bytes == NULL)) { + /* + * We can only use the internal rep directly if there is + * no string rep. Otherwise the string rep might actually + * look like an integer, which is preferred. + */ + + d2 = value2Ptr->internalRep.doubleValue; + } else { + char *s = Tcl_GetStringFromObj(value2Ptr, &length); + if (TclLooksLikeInt(s, length)) { + GET_WIDE_OR_INT(result, value2Ptr, i2, w2); + } else { + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, + value2Ptr, &d2); + } + if (result != TCL_OK) { + TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", + O2S(value2Ptr), s, + (value2Ptr->typePtr? + value2Ptr->typePtr->name : "null"))); + IllegalExprOperandType(interp, pc, value2Ptr); + goto checkForCatch; + } + t2Ptr = value2Ptr->typePtr; + } + + if ((t1Ptr == &tclDoubleType) || (t2Ptr == &tclDoubleType)) { + /* + * Do double arithmetic. + */ + doDouble = 1; + if (t1Ptr == &tclIntType) { + d1 = i; /* promote value 1 to double */ + } else if (t2Ptr == &tclIntType) { + d2 = i2; /* promote value 2 to double */ +#ifndef TCL_WIDE_INT_IS_LONG + } else if (t1Ptr == &tclWideIntType) { + d1 = Tcl_WideAsDouble(w); + } else if (t2Ptr == &tclWideIntType) { + d2 = Tcl_WideAsDouble(w2); +#endif /* TCL_WIDE_INT_IS_LONG */ + } + switch (*pc) { + case INST_ADD: + dResult = d1 + d2; + break; + case INST_SUB: + dResult = d1 - d2; + break; + case INST_MULT: + dResult = d1 * d2; + break; + case INST_DIV: + if (d2 == 0.0) { + TRACE(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2)); + goto divideByZero; } - } - if (value2Ptr->typePtr == &tclIntType) { - i2 = value2Ptr->internalRep.longValue; - } else { - result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, - value2Ptr, &i2); - if (result != TCL_OK) { - TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", - O2S(valuePtr), O2S(value2Ptr), - (value2Ptr->typePtr? - value2Ptr->typePtr->name : "null"))); - IllegalExprOperandType(interp, pc, value2Ptr); - Tcl_DecrRefCount(valuePtr); - Tcl_DecrRefCount(value2Ptr); - goto checkForCatch; + dResult = d1 / d2; + break; + } + + /* + * Check now for IEEE floating-point error. + */ + + if (IS_NAN(dResult) || IS_INF(dResult)) { + TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n", + O2S(valuePtr), O2S(value2Ptr))); + TclExprFloatError(interp, dResult); + result = TCL_ERROR; + goto checkForCatch; + } +#ifndef TCL_WIDE_INT_IS_LONG + } else if ((t1Ptr == &tclWideIntType) + || (t2Ptr == &tclWideIntType)) { + /* + * Do wide integer arithmetic. + */ + doWide = 1; + if (t1Ptr == &tclIntType) { + w = Tcl_LongAsWide(i); + } else if (t2Ptr == &tclIntType) { + w2 = Tcl_LongAsWide(i2); + } + switch (*pc) { + case INST_ADD: + wResult = w + w2; + break; + case INST_SUB: + wResult = w - w2; + break; + case INST_MULT: + wResult = w * w2; + break; + case INST_DIV: + /* + * This code is tricky: C doesn't guarantee much + * about the quotient or remainder, but Tcl does. + * The remainder always has the same sign as the + * divisor and a smaller absolute value. + */ + if (w2 == W0) { + LLTRACE((LLD" "LLD" => DIVIDE BY ZERO\n", w, w2)); + goto divideByZero; } - } - - switch (*pc) { - case INST_MOD: + if (w2 < 0) { + w2 = -w2; + w = -w; + } + wquot = w / w2; + wrem = w % w2; + if (wrem < W0) { + wquot -= 1; + } + wResult = wquot; + break; + } +#endif /* TCL_WIDE_INT_IS_LONG */ + } else { + /* + * Do integer arithmetic. + */ + switch (*pc) { + case INST_ADD: + iResult = i + i2; + break; + case INST_SUB: + iResult = i - i2; + break; + case INST_MULT: + iResult = i * i2; + break; + case INST_DIV: /* - * This code is tricky: C doesn't guarantee much about - * the quotient or remainder, but Tcl does. The - * remainder always has the same sign as the divisor and - * a smaller absolute value. + * This code is tricky: C doesn't guarantee much + * about the quotient or remainder, but Tcl does. + * The remainder always has the same sign as the + * divisor and a smaller absolute value. */ if (i2 == 0) { TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2)); - Tcl_DecrRefCount(valuePtr); - Tcl_DecrRefCount(value2Ptr); goto divideByZero; } - negative = 0; if (i2 < 0) { i2 = -i2; i = -i; - negative = 1; } + quot = i / i2; rem = i % i2; if (rem < 0) { - rem += i2; - } - if (negative) { - rem = -rem; + quot -= 1; } - iResult = rem; + iResult = quot; break; - case INST_LSHIFT: - iResult = i << i2; - break; - case INST_RSHIFT: - /* - * The following code is a bit tricky: it ensures that - * right shifts propagate the sign bit even on machines - * where ">>" won't do it by default. - */ - if (i < 0) { - iResult = ~((~i) >> i2); - } else { - iResult = i >> i2; - } - break; - case INST_BITOR: - iResult = i | i2; - break; - case INST_BITXOR: - iResult = i ^ i2; - break; - case INST_BITAND: - iResult = i & i2; - break; - } + } + } - /* - * Reuse the valuePtr object already on stack if possible. - */ + /* + * Reuse the valuePtr object already on stack if possible. + */ - if (Tcl_IsShared(valuePtr)) { - PUSH_OBJECT(Tcl_NewLongObj(iResult)); - TRACE(("%ld %ld => %ld\n", i, i2, iResult)); - TclDecrRefCount(valuePtr); - } else { /* reuse the valuePtr object */ - TRACE(("%ld %ld => %ld\n", i, i2, iResult)); - Tcl_SetLongObj(valuePtr, iResult); - ++stackTop; /* valuePtr now on stk top has right r.c. */ - } - TclDecrRefCount(value2Ptr); + if (Tcl_IsShared(valuePtr)) { + if (doDouble) { + objResultPtr = Tcl_NewDoubleObj(dResult); + TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult)); +#ifndef TCL_WIDE_INT_IS_LONG + } else if (doWide) { + objResultPtr = Tcl_NewWideIntObj(wResult); + LLTRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult)); +#endif /* TCL_WIDE_INT_IS_LONG */ + } else { + objResultPtr = Tcl_NewLongObj(iResult); + TRACE(("%ld %ld => %ld\n", i, i2, iResult)); + } + NEXT_INST_F(1, 2, 1); + } else { /* reuse the valuePtr object */ + if (doDouble) { /* NB: stack top is off by 1 */ + TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult)); + Tcl_SetDoubleObj(valuePtr, dResult); +#ifndef TCL_WIDE_INT_IS_LONG + } else if (doWide) { + LLTRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult)); + Tcl_SetWideIntObj(valuePtr, wResult); +#endif /* TCL_WIDE_INT_IS_LONG */ + } else { + TRACE(("%ld %ld => %ld\n", i, i2, iResult)); + Tcl_SetLongObj(valuePtr, iResult); } - ADJUST_PC(1); - - case INST_ADD: - case INST_SUB: - case INST_MULT: - case INST_DIV: - { - /* - * Operands must be numeric and ints get converted to floats - * if necessary. We compute value op value2. - */ + NEXT_INST_F(1, 1, 0); + } + } - Tcl_ObjType *t1Ptr, *t2Ptr; - long i2, quot, rem; - double d1, d2; - long iResult = 0; /* Init. avoids compiler warning. */ - double dResult = 0.0; /* Init. avoids compiler warning. */ - int doDouble = 0; /* 1 if doing floating arithmetic */ - - value2Ptr = POP_OBJECT(); - valuePtr = POP_OBJECT(); - t1Ptr = valuePtr->typePtr; - t2Ptr = value2Ptr->typePtr; + case INST_UPLUS: + { + /* + * Operand must be numeric. + */ + + double d; + Tcl_ObjType *tPtr; - if (t1Ptr == &tclIntType) { - i = valuePtr->internalRep.longValue; - } else if ((t1Ptr == &tclDoubleType) - && (valuePtr->bytes == NULL)) { - /* - * We can only use the internal rep directly if there is - * no string rep. Otherwise the string rep might actually - * look like an integer, which is preferred. - */ + valuePtr = stackPtr[stackTop]; + tPtr = valuePtr->typePtr; + if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType) + || (valuePtr->bytes != NULL))) { + char *s = Tcl_GetStringFromObj(valuePtr, &length); + if (TclLooksLikeInt(s, length)) { + GET_WIDE_OR_INT(result, valuePtr, i, w); + } else { + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d); + } + if (result != TCL_OK) { + TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", + s, (tPtr? tPtr->name : "null"))); + IllegalExprOperandType(interp, pc, valuePtr); + goto checkForCatch; + } + tPtr = valuePtr->typePtr; + } - d1 = valuePtr->internalRep.doubleValue; + /* + * Ensure that the operand's string rep is the same as the + * formatted version of its internal rep. This makes sure + * that "expr +000123" yields "83", not "000123". We + * implement this by _discarding_ the string rep since we + * know it will be regenerated, if needed later, by + * formatting the internal rep's value. + */ + + if (Tcl_IsShared(valuePtr)) { + if (tPtr == &tclIntType) { + i = valuePtr->internalRep.longValue; + objResultPtr = Tcl_NewLongObj(i); +#ifndef TCL_WIDE_INT_IS_LONG + } else if (tPtr == &tclWideIntType) { + w = valuePtr->internalRep.wideValue; + objResultPtr = Tcl_NewWideIntObj(w); +#endif /* TCL_WIDE_INT_IS_LONG */ + } else { + d = valuePtr->internalRep.doubleValue; + objResultPtr = Tcl_NewDoubleObj(d); + } + TRACE_WITH_OBJ(("%s => ", O2S(objResultPtr)), objResultPtr); + NEXT_INST_F(1, 1, 1); + } else { + Tcl_InvalidateStringRep(valuePtr); + TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), valuePtr); + NEXT_INST_F(1, 0, 0); + } + } + + case INST_UMINUS: + case INST_LNOT: + { + /* + * The operand must be numeric or a boolean string as + * accepted by Tcl_GetBooleanFromObj(). If the operand + * object is unshared modify it directly, otherwise + * create a copy to modify: this is "copy on write". + * Free any old string representation since it is now + * invalid. + */ + + double d; + int boolvar; + Tcl_ObjType *tPtr; + + valuePtr = stackPtr[stackTop]; + tPtr = valuePtr->typePtr; + if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType) + || (valuePtr->bytes != NULL))) { + if ((tPtr == &tclBooleanType) && (valuePtr->bytes == NULL)) { + valuePtr->typePtr = &tclIntType; + } else { + char *s = Tcl_GetStringFromObj(valuePtr, &length); + if (TclLooksLikeInt(s, length)) { + GET_WIDE_OR_INT(result, valuePtr, i, w); } else { - char *s = Tcl_GetStringFromObj(valuePtr, &length); - if (TclLooksLikeInt(s, length)) { - result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, - valuePtr, &i); - } else { - result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, - valuePtr, &d1); - } - if (result != TCL_OK) { - TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", - s, O2S(valuePtr), - (valuePtr->typePtr? - valuePtr->typePtr->name : "null"))); - IllegalExprOperandType(interp, pc, valuePtr); - Tcl_DecrRefCount(valuePtr); - Tcl_DecrRefCount(value2Ptr); - goto checkForCatch; - } - t1Ptr = valuePtr->typePtr; + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, + valuePtr, &d); } - - if (t2Ptr == &tclIntType) { - i2 = value2Ptr->internalRep.longValue; - } else if ((t2Ptr == &tclDoubleType) - && (value2Ptr->bytes == NULL)) { - /* - * We can only use the internal rep directly if there is - * no string rep. Otherwise the string rep might actually - * look like an integer, which is preferred. - */ + if (result == TCL_ERROR && *pc == INST_LNOT) { + result = Tcl_GetBooleanFromObj((Tcl_Interp *)NULL, + valuePtr, &boolvar); + i = (long)boolvar; /* i is long, not int! */ + } + if (result != TCL_OK) { + TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", + s, (tPtr? tPtr->name : "null"))); + IllegalExprOperandType(interp, pc, valuePtr); + goto checkForCatch; + } + } + tPtr = valuePtr->typePtr; + } - d2 = value2Ptr->internalRep.doubleValue; + if (Tcl_IsShared(valuePtr)) { + /* + * Create a new object. + */ + if ((tPtr == &tclIntType) || (tPtr == &tclBooleanType)) { + i = valuePtr->internalRep.longValue; + objResultPtr = Tcl_NewLongObj( + (*pc == INST_UMINUS)? -i : !i); + TRACE_WITH_OBJ(("%ld => ", i), objResultPtr); +#ifndef TCL_WIDE_INT_IS_LONG + } else if (tPtr == &tclWideIntType) { + w = valuePtr->internalRep.wideValue; + if (*pc == INST_UMINUS) { + objResultPtr = Tcl_NewWideIntObj(-w); } else { - char *s = Tcl_GetStringFromObj(value2Ptr, &length); - if (TclLooksLikeInt(s, length)) { - result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, - value2Ptr, &i2); - } else { - result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, - value2Ptr, &d2); - } - if (result != TCL_OK) { - TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", - O2S(value2Ptr), s, - (value2Ptr->typePtr? - value2Ptr->typePtr->name : "null"))); - IllegalExprOperandType(interp, pc, value2Ptr); - Tcl_DecrRefCount(valuePtr); - Tcl_DecrRefCount(value2Ptr); - goto checkForCatch; - } - t2Ptr = value2Ptr->typePtr; + objResultPtr = Tcl_NewLongObj(w == W0); } - - if ((t1Ptr == &tclDoubleType) || (t2Ptr == &tclDoubleType)) { - /* - * Do double arithmetic. - */ - doDouble = 1; - if (t1Ptr == &tclIntType) { - d1 = i; /* promote value 1 to double */ - } else if (t2Ptr == &tclIntType) { - d2 = i2; /* promote value 2 to double */ - } - switch (*pc) { - case INST_ADD: - dResult = d1 + d2; - break; - case INST_SUB: - dResult = d1 - d2; - break; - case INST_MULT: - dResult = d1 * d2; - break; - case INST_DIV: - if (d2 == 0.0) { - TRACE(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2)); - Tcl_DecrRefCount(valuePtr); - Tcl_DecrRefCount(value2Ptr); - goto divideByZero; - } - dResult = d1 / d2; - break; - } - + LLTRACE_WITH_OBJ((LLD" => ", w), objResultPtr); +#endif /* TCL_WIDE_INT_IS_LONG */ + } else { + d = valuePtr->internalRep.doubleValue; + if (*pc == INST_UMINUS) { + objResultPtr = Tcl_NewDoubleObj(-d); + } else { /* - * Check now for IEEE floating-point error. + * Should be able to use "!d", but apparently + * some compilers can't handle it. */ - - if (IS_NAN(dResult) || IS_INF(dResult)) { - TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n", - O2S(valuePtr), O2S(value2Ptr))); - TclExprFloatError(interp, dResult); - result = TCL_ERROR; - Tcl_DecrRefCount(valuePtr); - Tcl_DecrRefCount(value2Ptr); - goto checkForCatch; - } + objResultPtr = Tcl_NewLongObj((d==0.0)? 1 : 0); + } + TRACE_WITH_OBJ(("%.6g => ", d), objResultPtr); + } + NEXT_INST_F(1, 1, 1); + } else { + /* + * valuePtr is unshared. Modify it directly. + */ + if ((tPtr == &tclIntType) || (tPtr == &tclBooleanType)) { + i = valuePtr->internalRep.longValue; + Tcl_SetLongObj(valuePtr, + (*pc == INST_UMINUS)? -i : !i); + TRACE_WITH_OBJ(("%ld => ", i), valuePtr); +#ifndef TCL_WIDE_INT_IS_LONG + } else if (tPtr == &tclWideIntType) { + w = valuePtr->internalRep.wideValue; + if (*pc == INST_UMINUS) { + Tcl_SetWideIntObj(valuePtr, -w); + } else { + Tcl_SetLongObj(valuePtr, w == W0); + } + LLTRACE_WITH_OBJ((LLD" => ", w), valuePtr); +#endif /* TCL_WIDE_INT_IS_LONG */ + } else { + d = valuePtr->internalRep.doubleValue; + if (*pc == INST_UMINUS) { + Tcl_SetDoubleObj(valuePtr, -d); } else { /* - * Do integer arithmetic. + * Should be able to use "!d", but apparently + * some compilers can't handle it. */ - switch (*pc) { - case INST_ADD: - iResult = i + i2; - break; - case INST_SUB: - iResult = i - i2; - break; - case INST_MULT: - iResult = i * i2; - break; - case INST_DIV: - /* - * This code is tricky: C doesn't guarantee much - * about the quotient or remainder, but Tcl does. - * The remainder always has the same sign as the - * divisor and a smaller absolute value. - */ - if (i2 == 0) { - TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2)); - Tcl_DecrRefCount(valuePtr); - Tcl_DecrRefCount(value2Ptr); - goto divideByZero; - } - if (i2 < 0) { - i2 = -i2; - i = -i; - } - quot = i / i2; - rem = i % i2; - if (rem < 0) { - quot -= 1; - } - iResult = quot; - break; - } + Tcl_SetLongObj(valuePtr, (d==0.0)? 1 : 0); } + TRACE_WITH_OBJ(("%.6g => ", d), valuePtr); + } + NEXT_INST_F(1, 0, 0); + } + } - /* - * Reuse the valuePtr object already on stack if possible. - */ + case INST_BITNOT: + { + /* + * The operand must be an integer. If the operand object is + * unshared modify it directly, otherwise modify a copy. + * Free any old string representation since it is now + * invalid. + */ - if (Tcl_IsShared(valuePtr)) { - if (doDouble) { - PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); - TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult)); - } else { - PUSH_OBJECT(Tcl_NewLongObj(iResult)); - TRACE(("%ld %ld => %ld\n", i, i2, iResult)); - } - TclDecrRefCount(valuePtr); - } else { /* reuse the valuePtr object */ - if (doDouble) { /* NB: stack top is off by 1 */ - TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult)); - Tcl_SetDoubleObj(valuePtr, dResult); - } else { - TRACE(("%ld %ld => %ld\n", i, i2, iResult)); - Tcl_SetLongObj(valuePtr, iResult); - } - ++stackTop; /* valuePtr now on stk top has right r.c. */ - } - TclDecrRefCount(value2Ptr); + Tcl_ObjType *tPtr; + + valuePtr = stackPtr[stackTop]; + tPtr = valuePtr->typePtr; + if (!IS_INTEGER_TYPE(tPtr)) { + REQUIRE_WIDE_OR_INT(result, valuePtr, i, w); + if (result != TCL_OK) { /* try to convert to double */ + TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", + O2S(valuePtr), (tPtr? tPtr->name : "null"))); + IllegalExprOperandType(interp, pc, valuePtr); + goto checkForCatch; } - ADJUST_PC(1); - - case INST_UPLUS: - { - /* - * Operand must be numeric. - */ - - double d; - Tcl_ObjType *tPtr; + } - valuePtr = stackPtr[stackTop]; - tPtr = valuePtr->typePtr; - if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType) - || (valuePtr->bytes != NULL))) { - char *s = Tcl_GetStringFromObj(valuePtr, &length); - if (TclLooksLikeInt(s, length)) { - result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, - valuePtr, &i); - } else { - result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, - valuePtr, &d); - } - if (result != TCL_OK) { - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", - s, (tPtr? tPtr->name : "null"))); - IllegalExprOperandType(interp, pc, valuePtr); - goto checkForCatch; - } - tPtr = valuePtr->typePtr; - } - +#ifndef TCL_WIDE_INT_IS_LONG + if (valuePtr->typePtr == &tclWideIntType) { + w = valuePtr->internalRep.wideValue; + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewWideIntObj(~w); + LLTRACE(("0x%llx => (%llu)\n", w, ~w)); + NEXT_INST_F(1, 1, 1); + } else { /* - * Ensure that the operand's string rep is the same as the - * formatted version of its internal rep. This makes sure - * that "expr +000123" yields "83", not "000123". We - * implement this by _discarding_ the string rep since we - * know it will be regenerated, if needed later, by - * formatting the internal rep's value. + * valuePtr is unshared. Modify it directly. */ - - if (Tcl_IsShared(valuePtr)) { - if (tPtr == &tclIntType) { - i = valuePtr->internalRep.longValue; - objPtr = Tcl_NewLongObj(i); - } else { - d = valuePtr->internalRep.doubleValue; - objPtr = Tcl_NewDoubleObj(d); - } - Tcl_IncrRefCount(objPtr); - Tcl_DecrRefCount(valuePtr); - valuePtr = objPtr; - stackPtr[stackTop] = valuePtr; - } else { - Tcl_InvalidateStringRep(valuePtr); - } - TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), valuePtr); + Tcl_SetWideIntObj(valuePtr, ~w); + LLTRACE(("0x%llx => (%llu)\n", w, ~w)); + NEXT_INST_F(1, 0, 0); } - ADJUST_PC(1); - - case INST_UMINUS: - case INST_LNOT: - { + } else { +#endif /* TCL_WIDE_INT_IS_LONG */ + i = valuePtr->internalRep.longValue; + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_NewLongObj(~i); + TRACE(("0x%lx => (%lu)\n", i, ~i)); + NEXT_INST_F(1, 1, 1); + } else { /* - * The operand must be numeric. If the operand object is - * unshared modify it directly, otherwise create a copy to - * modify: this is "copy on write". free any old string - * representation since it is now invalid. + * valuePtr is unshared. Modify it directly. */ + Tcl_SetLongObj(valuePtr, ~i); + TRACE(("0x%lx => (%lu)\n", i, ~i)); + NEXT_INST_F(1, 0, 0); + } +#ifndef TCL_WIDE_INT_IS_LONG + } +#endif /* TCL_WIDE_INT_IS_LONG */ + } + + case INST_CALL_BUILTIN_FUNC1: + opnd = TclGetUInt1AtPtr(pc+1); + { + /* + * Call one of the built-in Tcl math functions. + */ + + BuiltinFunc *mathFuncPtr; + + if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) { + TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd)); + panic("TclExecuteByteCode: unrecognized builtin function code %d", opnd); + } + mathFuncPtr = &(tclBuiltinFuncTable[opnd]); + DECACHE_STACK_INFO(); + result = (*mathFuncPtr->proc)(interp, eePtr, + mathFuncPtr->clientData); + CACHE_STACK_INFO(); + if (result != TCL_OK) { + goto checkForCatch; + } + TRACE_WITH_OBJ(("%d => ", opnd), stackPtr[stackTop]); + } + NEXT_INST_F(2, 0, 0); + + case INST_CALL_FUNC1: + opnd = TclGetUInt1AtPtr(pc+1); + { + /* + * Call a non-builtin Tcl math function previously + * registered by a call to Tcl_CreateMathFunc. + */ - double d; - Tcl_ObjType *tPtr; - - valuePtr = POP_OBJECT(); - tPtr = valuePtr->typePtr; - if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType) - || (valuePtr->bytes != NULL))) { - if ((tPtr == &tclBooleanType) - && (valuePtr->bytes == NULL)) { - valuePtr->typePtr = &tclIntType; - } else { - char *s = Tcl_GetStringFromObj(valuePtr, &length); - if (TclLooksLikeInt(s, length)) { - result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, - valuePtr, &i); - } else { - result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, - valuePtr, &d); - } - if (result != TCL_OK) { - TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", - s, (tPtr? tPtr->name : "null"))); - IllegalExprOperandType(interp, pc, valuePtr); - Tcl_DecrRefCount(valuePtr); - goto checkForCatch; - } - } - tPtr = valuePtr->typePtr; - } + int objc = opnd; /* Number of arguments. The function name + * is the 0-th argument. */ + Tcl_Obj **objv; /* The array of arguments. The function + * name is objv[0]. */ + + objv = &(stackPtr[stackTop - (objc-1)]); /* "objv[0]" */ + DECACHE_STACK_INFO(); + result = ExprCallMathFunc(interp, eePtr, objc, objv); + CACHE_STACK_INFO(); + if (result != TCL_OK) { + goto checkForCatch; + } + TRACE_WITH_OBJ(("%d => ", objc), stackPtr[stackTop]); + } + NEXT_INST_F(2, 0, 0); + + case INST_TRY_CVT_TO_NUMERIC: + { + /* + * Try to convert the topmost stack object to an int or + * double object. This is done in order to support Tcl's + * policy of interpreting operands if at all possible as + * first integers, else floating-point numbers. + */ - if (Tcl_IsShared(valuePtr)) { - /* - * Create a new object. - */ - if (tPtr == &tclIntType) { - i = valuePtr->internalRep.longValue; - objPtr = Tcl_NewLongObj( - (*pc == INST_UMINUS)? -i : !i); - TRACE_WITH_OBJ(("%ld => ", i), objPtr); - } else { - d = valuePtr->internalRep.doubleValue; - if (*pc == INST_UMINUS) { - objPtr = Tcl_NewDoubleObj(-d); - } else { - /* - * Should be able to use "!d", but apparently - * some compilers can't handle it. - */ - objPtr = Tcl_NewLongObj((d==0.0)? 1 : 0); - } - TRACE_WITH_OBJ(("%.6g => ", d), objPtr); - } - PUSH_OBJECT(objPtr); - TclDecrRefCount(valuePtr); + double d; + char *s; + Tcl_ObjType *tPtr; + int converted, needNew; + + valuePtr = stackPtr[stackTop]; + tPtr = valuePtr->typePtr; + converted = 0; + if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType) + || (valuePtr->bytes != NULL))) { + if ((tPtr == &tclBooleanType) && (valuePtr->bytes == NULL)) { + valuePtr->typePtr = &tclIntType; + converted = 1; + } else { + s = Tcl_GetStringFromObj(valuePtr, &length); + if (TclLooksLikeInt(s, length)) { + GET_WIDE_OR_INT(result, valuePtr, i, w); } else { + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, + valuePtr, &d); + } + if (result == TCL_OK) { + converted = 1; + } + result = TCL_OK; /* reset the result variable */ + } + tPtr = valuePtr->typePtr; + } + + /* + * Ensure that the topmost stack object, if numeric, has a + * string rep the same as the formatted version of its + * internal rep. This is used, e.g., to make sure that "expr + * {0001}" yields "1", not "0001". We implement this by + * _discarding_ the string rep since we know it will be + * regenerated, if needed later, by formatting the internal + * rep's value. Also check if there has been an IEEE + * floating point error. + */ + + objResultPtr = valuePtr; + needNew = 0; + if (IS_NUMERIC_TYPE(tPtr)) { + if (Tcl_IsShared(valuePtr)) { + if (valuePtr->bytes != NULL) { /* - * valuePtr is unshared. Modify it directly. + * We only need to make a copy of the object + * when it already had a string rep */ + needNew = 1; if (tPtr == &tclIntType) { i = valuePtr->internalRep.longValue; - Tcl_SetLongObj(valuePtr, - (*pc == INST_UMINUS)? -i : !i); - TRACE_WITH_OBJ(("%ld => ", i), valuePtr); + objResultPtr = Tcl_NewLongObj(i); +#ifndef TCL_WIDE_INT_IS_LONG + } else if (tPtr == &tclWideIntType) { + w = valuePtr->internalRep.wideValue; + objResultPtr = Tcl_NewWideIntObj(w); +#endif /* TCL_WIDE_INT_IS_LONG */ } else { d = valuePtr->internalRep.doubleValue; - if (*pc == INST_UMINUS) { - Tcl_SetDoubleObj(valuePtr, -d); - } else { - /* - * Should be able to use "!d", but apparently - * some compilers can't handle it. - */ - Tcl_SetLongObj(valuePtr, (d==0.0)? 1 : 0); - } - TRACE_WITH_OBJ(("%.6g => ", d), valuePtr); + objResultPtr = Tcl_NewDoubleObj(d); } - ++stackTop; /* valuePtr now on stk top has right r.c. */ + tPtr = objResultPtr->typePtr; } + } else { + Tcl_InvalidateStringRep(valuePtr); } - ADJUST_PC(1); - - case INST_BITNOT: - { - /* - * The operand must be an integer. If the operand object is - * unshared modify it directly, otherwise modify a copy. - * Free any old string representation since it is now - * invalid. - */ - - Tcl_ObjType *tPtr; - - valuePtr = POP_OBJECT(); - tPtr = valuePtr->typePtr; - if (tPtr != &tclIntType) { - result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, - valuePtr, &i); - if (result != TCL_OK) { /* try to convert to double */ - TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", - O2S(valuePtr), (tPtr? tPtr->name : "null"))); - IllegalExprOperandType(interp, pc, valuePtr); - Tcl_DecrRefCount(valuePtr); - goto checkForCatch; - } - } - - i = valuePtr->internalRep.longValue; - if (Tcl_IsShared(valuePtr)) { - PUSH_OBJECT(Tcl_NewLongObj(~i)); - TRACE(("0x%lx => (%lu)\n", i, ~i)); - TclDecrRefCount(valuePtr); - } else { - /* - * valuePtr is unshared. Modify it directly. - */ - Tcl_SetLongObj(valuePtr, ~i); - ++stackTop; /* valuePtr now on stk top has right r.c. */ - TRACE(("0x%lx => (%lu)\n", i, ~i)); - } - } - ADJUST_PC(1); - - case INST_CALL_BUILTIN_FUNC1: - opnd = TclGetUInt1AtPtr(pc+1); - { - /* - * Call one of the built-in Tcl math functions. - */ - - BuiltinFunc *mathFuncPtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) { - TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd)); - panic("TclExecuteByteCode: unrecognized builtin function code %d", opnd); - } - mathFuncPtr = &(builtinFuncTable[opnd]); - DECACHE_STACK_INFO(); - tsdPtr->mathInProgress++; - result = (*mathFuncPtr->proc)(interp, eePtr, - mathFuncPtr->clientData); - tsdPtr->mathInProgress--; - CACHE_STACK_INFO(); - if (result != TCL_OK) { - goto checkForCatch; - } - TRACE_WITH_OBJ(("%d => ", opnd), stackPtr[stackTop]); - } - ADJUST_PC(2); - - case INST_CALL_FUNC1: - opnd = TclGetUInt1AtPtr(pc+1); - { - /* - * Call a non-builtin Tcl math function previously - * registered by a call to Tcl_CreateMathFunc. - */ - int objc = opnd; /* Number of arguments. The function name - * is the 0-th argument. */ - Tcl_Obj **objv; /* The array of arguments. The function - * name is objv[0]. */ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - objv = &(stackPtr[stackTop - (objc-1)]); /* "objv[0]" */ - DECACHE_STACK_INFO(); - tsdPtr->mathInProgress++; - result = ExprCallMathFunc(interp, eePtr, objc, objv); - tsdPtr->mathInProgress--; - CACHE_STACK_INFO(); - if (result != TCL_OK) { + if (tPtr == &tclDoubleType) { + d = objResultPtr->internalRep.doubleValue; + if (IS_NAN(d) || IS_INF(d)) { + TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n", + O2S(objResultPtr))); + TclExprFloatError(interp, d); + result = TCL_ERROR; goto checkForCatch; } - TRACE_WITH_OBJ(("%d => ", objc), stackPtr[stackTop]); - ADJUST_PC(2); } + converted = converted; /* lint, converted not used. */ + TRACE(("\"%.20s\" => numeric, %s, %s\n", O2S(valuePtr), + (converted? "converted" : "not converted"), + (needNew? "new Tcl_Obj" : "same Tcl_Obj"))); + } else { + TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr))); + } + if (needNew) { + NEXT_INST_F(1, 1, 1); + } else { + NEXT_INST_F(1, 0, 0); + } + } + + case INST_BREAK: + Tcl_ResetResult(interp); + result = TCL_BREAK; + cleanup = 0; + goto processExceptionReturn; - case INST_TRY_CVT_TO_NUMERIC: - { - /* - * Try to convert the topmost stack object to an int or - * double object. This is done in order to support Tcl's - * policy of interpreting operands if at all possible as - * first integers, else floating-point numbers. - */ - - double d; - char *s; - Tcl_ObjType *tPtr; - int converted, shared; - - valuePtr = stackPtr[stackTop]; - tPtr = valuePtr->typePtr; - converted = 0; - if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType) - || (valuePtr->bytes != NULL))) { - if ((tPtr == &tclBooleanType) - && (valuePtr->bytes == NULL)) { - valuePtr->typePtr = &tclIntType; - converted = 1; - } else { - s = Tcl_GetStringFromObj(valuePtr, &length); - if (TclLooksLikeInt(s, length)) { - result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, - valuePtr, &i); - } else { - result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, - valuePtr, &d); - } - if (result == TCL_OK) { - converted = 1; - } - result = TCL_OK; /* reset the result variable */ - } - tPtr = valuePtr->typePtr; - } + case INST_CONTINUE: + Tcl_ResetResult(interp); + result = TCL_CONTINUE; + cleanup = 0; + goto processExceptionReturn; - /* - * Ensure that the topmost stack object, if numeric, has a - * string rep the same as the formatted version of its - * internal rep. This is used, e.g., to make sure that "expr - * {0001}" yields "1", not "0001". We implement this by - * _discarding_ the string rep since we know it will be - * regenerated, if needed later, by formatting the internal - * rep's value. Also check if there has been an IEEE - * floating point error. - */ + case INST_FOREACH_START4: + opnd = TclGetUInt4AtPtr(pc+1); + { + /* + * Initialize the temporary local var that holds the count + * of the number of iterations of the loop body to -1. + */ - if ((tPtr == &tclIntType) || (tPtr == &tclDoubleType)) { - shared = 0; - if (Tcl_IsShared(valuePtr)) { - shared = 1; - if (valuePtr->bytes != NULL) { - /* - * We only need to make a copy of the object - * when it already had a string rep - */ - if (tPtr == &tclIntType) { - i = valuePtr->internalRep.longValue; - objPtr = Tcl_NewLongObj(i); - } else { - d = valuePtr->internalRep.doubleValue; - objPtr = Tcl_NewDoubleObj(d); - } - Tcl_IncrRefCount(objPtr); - TclDecrRefCount(valuePtr); - valuePtr = objPtr; - stackPtr[stackTop] = valuePtr; - tPtr = valuePtr->typePtr; - } - } else { - Tcl_InvalidateStringRep(valuePtr); - } - - if (tPtr == &tclDoubleType) { - d = valuePtr->internalRep.doubleValue; - if (IS_NAN(d) || IS_INF(d)) { - TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n", - O2S(valuePtr))); - TclExprFloatError(interp, d); - result = TCL_ERROR; - goto checkForCatch; - } - } - shared = shared; /* lint, shared not used. */ - converted = converted; /* lint, converted not used. */ - TRACE(("\"%.20s\" => numeric, %s, %s\n", O2S(valuePtr), - (converted? "converted" : "not converted"), - (shared? "shared" : "not shared"))); - } else { - TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr))); - } + ForeachInfo *infoPtr = (ForeachInfo *) + codePtr->auxDataArrayPtr[opnd].clientData; + int iterTmpIndex = infoPtr->loopCtTemp; + Var *compiledLocals = iPtr->varFramePtr->compiledLocals; + Var *iterVarPtr = &(compiledLocals[iterTmpIndex]); + Tcl_Obj *oldValuePtr = iterVarPtr->value.objPtr; + + if (oldValuePtr == NULL) { + iterVarPtr->value.objPtr = Tcl_NewLongObj(-1); + Tcl_IncrRefCount(iterVarPtr->value.objPtr); + } else { + Tcl_SetLongObj(oldValuePtr, -1); } - ADJUST_PC(1); + TclSetVarScalar(iterVarPtr); + TclClearVarUndefined(iterVarPtr); + TRACE(("%u => loop iter count temp %d\n", + opnd, iterTmpIndex)); + } + +#ifndef TCL_COMPILE_DEBUG + /* + * Remark that the compiler ALWAYS sets INST_FOREACH_STEP4 + * immediately after INST_FOREACH_START4 - let us just fall + * through instead of jumping back to the top. + */ - case INST_BREAK: + pc += 5; +#else + NEXT_INST_F(5, 0, 0); +#endif + case INST_FOREACH_STEP4: + opnd = TclGetUInt4AtPtr(pc+1); + { /* - * First reset the interpreter's result. Then find the closest - * enclosing loop or catch exception range, if any. If a loop is - * found, terminate its execution. If the closest is a catch - * exception range, jump to its catchOffset. If no enclosing - * range is found, stop execution and return TCL_BREAK. + * "Step" a foreach loop (i.e., begin its next iteration) by + * assigning the next value list element to each loop var. */ - Tcl_ResetResult(interp); - rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr); - if (rangePtr == NULL) { - TRACE(("=> no encl. loop or catch, returning TCL_BREAK\n")); - result = TCL_BREAK; - goto abnormalReturn; /* no catch exists to check */ - } - switch (rangePtr->type) { - case LOOP_EXCEPTION_RANGE: - result = TCL_OK; - TRACE(("=> range at %d, new pc %d\n", - rangePtr->codeOffset, rangePtr->breakOffset)); - break; - case CATCH_EXCEPTION_RANGE: - result = TCL_BREAK; - TRACE(("=> ...\n")); - goto processCatch; /* it will use rangePtr */ - default: - panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type); - } - pc = (codePtr->codeStart + rangePtr->breakOffset); - continue; /* restart outer instruction loop at pc */ - - case INST_CONTINUE: - /* - * Find the closest enclosing loop or catch exception range, - * if any. If a loop is found, skip to its next iteration. - * If the closest is a catch exception range, jump to its - * catchOffset. If no enclosing range is found, stop - * execution and return TCL_CONTINUE. + ForeachInfo *infoPtr = (ForeachInfo *) + codePtr->auxDataArrayPtr[opnd].clientData; + ForeachVarList *varListPtr; + int numLists = infoPtr->numLists; + Var *compiledLocals = iPtr->varFramePtr->compiledLocals; + Tcl_Obj *listPtr; + List *listRepPtr; + Var *iterVarPtr, *listVarPtr; + int iterNum, listTmpIndex, listLen, numVars; + int varIndex, valIndex, continueLoop, j; + + /* + * Increment the temp holding the loop iteration number. */ - Tcl_ResetResult(interp); - rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr); - if (rangePtr == NULL) { - TRACE(("=> no encl. loop or catch, returning TCL_CONTINUE\n")); - result = TCL_CONTINUE; - goto abnormalReturn; - } - switch (rangePtr->type) { - case LOOP_EXCEPTION_RANGE: - if (rangePtr->continueOffset == -1) { - TRACE(("=> loop w/o continue, checking for catch\n")); + iterVarPtr = &(compiledLocals[infoPtr->loopCtTemp]); + valuePtr = iterVarPtr->value.objPtr; + iterNum = (valuePtr->internalRep.longValue + 1); + Tcl_SetLongObj(valuePtr, iterNum); + + /* + * Check whether all value lists are exhausted and we should + * stop the loop. + */ + + continueLoop = 0; + listTmpIndex = infoPtr->firstValueTemp; + for (i = 0; i < numLists; i++) { + varListPtr = infoPtr->varLists[i]; + numVars = varListPtr->numVars; + + listVarPtr = &(compiledLocals[listTmpIndex]); + listPtr = listVarPtr->value.objPtr; + result = Tcl_ListObjLength(interp, listPtr, &listLen); + if (result != TCL_OK) { + TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ", + opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp)); goto checkForCatch; - } else { - result = TCL_OK; - TRACE(("=> range at %d, new pc %d\n", - rangePtr->codeOffset, rangePtr->continueOffset)); } - break; - case CATCH_EXCEPTION_RANGE: - result = TCL_CONTINUE; - TRACE(("=> ...\n")); - goto processCatch; /* it will use rangePtr */ - default: - panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type); - } - pc = (codePtr->codeStart + rangePtr->continueOffset); - continue; /* restart outer instruction loop at pc */ - - case INST_FOREACH_START4: - opnd = TclGetUInt4AtPtr(pc+1); - { - /* - * Initialize the temporary local var that holds the count - * of the number of iterations of the loop body to -1. - */ - - ForeachInfo *infoPtr = (ForeachInfo *) - codePtr->auxDataArrayPtr[opnd].clientData; - int iterTmpIndex = infoPtr->loopCtTemp; - Var *compiledLocals = iPtr->varFramePtr->compiledLocals; - Var *iterVarPtr = &(compiledLocals[iterTmpIndex]); - Tcl_Obj *oldValuePtr = iterVarPtr->value.objPtr; - - if (oldValuePtr == NULL) { - iterVarPtr->value.objPtr = Tcl_NewLongObj(-1); - Tcl_IncrRefCount(iterVarPtr->value.objPtr); - } else { - Tcl_SetLongObj(oldValuePtr, -1); + if (listLen > (iterNum * numVars)) { + continueLoop = 1; } - TclSetVarScalar(iterVarPtr); - TclClearVarUndefined(iterVarPtr); - TRACE(("%u => loop iter count temp %d\n", - opnd, iterTmpIndex)); + listTmpIndex++; } - ADJUST_PC(5); - - case INST_FOREACH_STEP4: - opnd = TclGetUInt4AtPtr(pc+1); - { - /* - * "Step" a foreach loop (i.e., begin its next iteration) by - * assigning the next value list element to each loop var. - */ - - ForeachInfo *infoPtr = (ForeachInfo *) - codePtr->auxDataArrayPtr[opnd].clientData; - ForeachVarList *varListPtr; - int numLists = infoPtr->numLists; - Var *compiledLocals = iPtr->varFramePtr->compiledLocals; - Tcl_Obj *listPtr; - List *listRepPtr; - Var *iterVarPtr, *listVarPtr; - int iterNum, listTmpIndex, listLen, numVars; - int varIndex, valIndex, continueLoop, j; - - /* - * Increment the temp holding the loop iteration number. - */ - iterVarPtr = &(compiledLocals[infoPtr->loopCtTemp]); - valuePtr = iterVarPtr->value.objPtr; - iterNum = (valuePtr->internalRep.longValue + 1); - Tcl_SetLongObj(valuePtr, iterNum); + /* + * If some var in some var list still has a remaining list + * element iterate one more time. Assign to var the next + * element from its value list. We already checked above + * that each list temp holds a valid list object. + */ - /* - * Check whether all value lists are exhausted and we should - * stop the loop. - */ - - continueLoop = 0; + if (continueLoop) { listTmpIndex = infoPtr->firstValueTemp; for (i = 0; i < numLists; i++) { varListPtr = infoPtr->varLists[i]; numVars = varListPtr->numVars; - + listVarPtr = &(compiledLocals[listTmpIndex]); listPtr = listVarPtr->value.objPtr; - result = Tcl_ListObjLength(interp, listPtr, &listLen); - if (result != TCL_OK) { - TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ", - opnd, i, O2S(listPtr)), - Tcl_GetObjResult(interp)); - goto checkForCatch; - } - if (listLen > (iterNum * numVars)) { - continueLoop = 1; - } - listTmpIndex++; - } - - /* - * If some var in some var list still has a remaining list - * element iterate one more time. Assign to var the next - * element from its value list. We already checked above - * that each list temp holds a valid list object. - */ - - if (continueLoop) { - listTmpIndex = infoPtr->firstValueTemp; - for (i = 0; i < numLists; i++) { - varListPtr = infoPtr->varLists[i]; - numVars = varListPtr->numVars; - - listVarPtr = &(compiledLocals[listTmpIndex]); - listPtr = listVarPtr->value.objPtr; - listRepPtr = (List *) listPtr->internalRep.otherValuePtr; - listLen = listRepPtr->elemCount; + listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + listLen = listRepPtr->elemCount; - valIndex = (iterNum * numVars); - for (j = 0; j < numVars; j++) { - int setEmptyStr = 0; - if (valIndex >= listLen) { - setEmptyStr = 1; - valuePtr = Tcl_NewObj(); - } else { - valuePtr = listRepPtr->elements[valIndex]; - } + valIndex = (iterNum * numVars); + for (j = 0; j < numVars; j++) { + int setEmptyStr = 0; + if (valIndex >= listLen) { + setEmptyStr = 1; + TclNewObj(valuePtr); + } else { + valuePtr = listRepPtr->elements[valIndex]; + } - varIndex = varListPtr->varIndexes[j]; + varIndex = varListPtr->varIndexes[j]; + varPtr = &(varFramePtr->compiledLocals[varIndex]); + part1 = varPtr->name; + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + if (!((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) + && (varPtr->tracePtr == NULL) + && (TclIsVarScalar(varPtr) || TclIsVarUndefined(varPtr))) { + value2Ptr = varPtr->value.objPtr; + if (valuePtr != value2Ptr) { + if (value2Ptr != NULL) { + TclDecrRefCount(value2Ptr); + } else { + TclSetVarScalar(varPtr); + TclClearVarUndefined(varPtr); + } + varPtr->value.objPtr = valuePtr; + Tcl_IncrRefCount(valuePtr); + } + } else { DECACHE_STACK_INFO(); - value2Ptr = TclSetIndexedScalar(interp, - varIndex, valuePtr, /*leaveErrorMsg*/ 1); + value2Ptr = TclPtrSetVar(interp, varPtr, NULL, part1, + NULL, valuePtr, TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); if (value2Ptr == NULL) { TRACE_WITH_OBJ(("%u => ERROR init. index temp %d: ", - opnd, varIndex), - Tcl_GetObjResult(interp)); + opnd, varIndex), + Tcl_GetObjResult(interp)); if (setEmptyStr) { - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(valuePtr); } result = TCL_ERROR; goto checkForCatch; } - valIndex++; } - listTmpIndex++; + valIndex++; } + listTmpIndex++; } - - /* - * Push 1 if at least one value list had a remaining element - * and the loop should continue. Otherwise push 0. - */ - - PUSH_OBJECT(Tcl_NewLongObj(continueLoop)); - TRACE(("%u => %d lists, iter %d, %s loop\n", - opnd, numLists, iterNum, - (continueLoop? "continue" : "exit"))); } - ADJUST_PC(5); + TRACE(("%u => %d lists, iter %d, %s loop\n", opnd, numLists, + iterNum, (continueLoop? "continue" : "exit"))); - case INST_BEGIN_CATCH4: - /* - * Record start of the catch command with exception range index - * equal to the operand. Push the current stack depth onto the - * special catch stack. + /* + * Run-time peep-hole optimisation: the compiler ALWAYS follows + * INST_FOREACH_STEP4 with an INST_JUMP_FALSE. We just skip that + * instruction and jump direct from here. */ - catchStackPtr[++catchTop] = stackTop; - TRACE(("%u => catchTop=%d, stackTop=%d\n", - TclGetUInt4AtPtr(pc+1), catchTop, stackTop)); - ADJUST_PC(5); - case INST_END_CATCH: - catchTop--; - result = TCL_OK; - TRACE(("=> catchTop=%d\n", catchTop)); - ADJUST_PC(1); + pc += 5; + if (*pc == INST_JUMP_FALSE1) { + NEXT_INST_F((continueLoop? 2 : TclGetInt1AtPtr(pc+1)), 0, 0); + } else { + NEXT_INST_F((continueLoop? 5 : TclGetInt4AtPtr(pc+1)), 0, 0); + } + } - case INST_PUSH_RESULT: - PUSH_OBJECT(Tcl_GetObjResult(interp)); - TRACE_WITH_OBJ(("=> "), Tcl_GetObjResult(interp)); - ADJUST_PC(1); + case INST_BEGIN_CATCH4: + /* + * Record start of the catch command with exception range index + * equal to the operand. Push the current stack depth onto the + * special catch stack. + */ + catchStackPtr[++catchTop] = stackTop; + TRACE(("%u => catchTop=%d, stackTop=%d\n", + TclGetUInt4AtPtr(pc+1), catchTop, stackTop)); + NEXT_INST_F(5, 0, 0); + + case INST_END_CATCH: + catchTop--; + result = TCL_OK; + TRACE(("=> catchTop=%d\n", catchTop)); + NEXT_INST_F(1, 0, 0); + + case INST_PUSH_RESULT: + objResultPtr = Tcl_GetObjResult(interp); + TRACE_WITH_OBJ(("=> "), Tcl_GetObjResult(interp)); + NEXT_INST_F(1, 0, 1); - case INST_PUSH_RETURN_CODE: - PUSH_OBJECT(Tcl_NewLongObj(result)); - TRACE(("=> %u\n", result)); - ADJUST_PC(1); + case INST_PUSH_RETURN_CODE: + objResultPtr = Tcl_NewLongObj(result); + TRACE(("=> %u\n", result)); + NEXT_INST_F(1, 0, 1); - default: - panic("TclExecuteByteCode: unrecognized opCode %u", *pc); - } /* end of switch on opCode */ + default: + panic("TclExecuteByteCode: unrecognized opCode %u", *pc); + } /* end of switch on opCode */ - /* - * Division by zero in an expression. Control only reaches this - * point by "goto divideByZero". - */ - - divideByZero: - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), "divide by zero", -1); - Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", - (char *) NULL); - result = TCL_ERROR; + /* + * Division by zero in an expression. Control only reaches this + * point by "goto divideByZero". + */ - /* - * Execution has generated an "exception" such as TCL_ERROR. If the - * exception is an error, record information about what was being - * executed when the error occurred. Find the closest enclosing - * catch range, if any. If no enclosing catch range is found, stop - * execution and return the "exception" code. - */ + divideByZero: + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), "divide by zero", -1); + Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", + (char *) NULL); + result = TCL_ERROR; + goto checkForCatch; - checkForCatch: - if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { - bytes = GetSrcInfoForPc(pc, codePtr, &length); - if (bytes != NULL) { - Tcl_LogCommandInfo(interp, codePtr->source, bytes, length); - iPtr->flags |= ERR_ALREADY_LOGGED; - } - } - rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 1, codePtr); + /* + * An external evaluation (INST_INVOKE or INST_EVAL) returned + * something different from TCL_OK, or else INST_BREAK or + * INST_CONTINUE were called. + */ + + processExceptionReturn: +#if TCL_COMPILE_DEBUG + switch (*pc) { + case INST_INVOKE_STK1: + case INST_INVOKE_STK4: + TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf)); + break; + case INST_EVAL_STK: + /* + * Note that the object at stacktop has to be used + * before doing the cleanup. + */ + + TRACE(("\"%.30s\" => ", O2S(stackPtr[stackTop]))); + break; + default: + TRACE(("=> ")); + } +#endif + if ((result == TCL_CONTINUE) || (result == TCL_BREAK)) { + rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr); if (rangePtr == NULL) { -#ifdef TCL_COMPILE_DEBUG - if (traceInstructions) { - fprintf(stdout, " ... no enclosing catch, returning %s\n", - StringForResultCode(result)); - } -#endif + TRACE_APPEND(("no encl. loop or catch, returning %s\n", + StringForResultCode(result))); goto abnormalReturn; + } + if (rangePtr->type == CATCH_EXCEPTION_RANGE) { + TRACE_APPEND(("%s ...\n", StringForResultCode(result))); + goto processCatch; } - - /* - * A catch exception range (rangePtr) was found to handle an - * "exception". It was found either by checkForCatch just above or - * by an instruction during break, continue, or error processing. - * Jump to its catchOffset after unwinding the operand stack to - * the depth it had when starting to execute the range's catch - * command. - */ - - processCatch: - while (stackTop > catchStackPtr[catchTop]) { + while (cleanup--) { valuePtr = POP_OBJECT(); TclDecrRefCount(valuePtr); } + if (result == TCL_BREAK) { + result = TCL_OK; + pc = (codePtr->codeStart + rangePtr->breakOffset); + TRACE_APPEND(("%s, range at %d, new pc %d\n", + StringForResultCode(result), + rangePtr->codeOffset, rangePtr->breakOffset)); + NEXT_INST_F(0, 0, 0); + } else { + if (rangePtr->continueOffset == -1) { + TRACE_APPEND(("%s, loop w/o continue, checking for catch\n", + StringForResultCode(result))); + goto checkForCatch; + } + result = TCL_OK; + pc = (codePtr->codeStart + rangePtr->continueOffset); + TRACE_APPEND(("%s, range at %d, new pc %d\n", + StringForResultCode(result), + rangePtr->codeOffset, rangePtr->continueOffset)); + NEXT_INST_F(0, 0, 0); + } +#if TCL_COMPILE_DEBUG + } else if (traceInstructions) { + if ((result != TCL_ERROR) && (result != TCL_RETURN)) { + objPtr = Tcl_GetObjResult(interp); + TRACE_APPEND(("OTHER RETURN CODE %d, result= \"%s\"\n ", + result, O2S(objPtr))); + } else { + objPtr = Tcl_GetObjResult(interp); + TRACE_APPEND(("%s, result= \"%s\"\n", + StringForResultCode(result), O2S(objPtr))); + } +#endif + } + + /* + * Execution has generated an "exception" such as TCL_ERROR. If the + * exception is an error, record information about what was being + * executed when the error occurred. Find the closest enclosing + * catch range, if any. If no enclosing catch range is found, stop + * execution and return the "exception" code. + */ + + checkForCatch: + if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { + bytes = GetSrcInfoForPc(pc, codePtr, &length); + if (bytes != NULL) { + Tcl_LogCommandInfo(interp, codePtr->source, bytes, length); + iPtr->flags |= ERR_ALREADY_LOGGED; + } + } + if (catchTop == -1) { +#ifdef TCL_COMPILE_DEBUG + if (traceInstructions) { + fprintf(stdout, " ... no enclosing catch, returning %s\n", + StringForResultCode(result)); + } +#endif + goto abnormalReturn; + } + rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 1, codePtr); + if (rangePtr == NULL) { + /* + * This is only possible when compiling a [catch] that sends its + * script to INST_EVAL. Cannot correct the compiler without + * breakingcompat with previous .tbc compiled scripts. + */ #ifdef TCL_COMPILE_DEBUG if (traceInstructions) { - fprintf(stdout, " ... found catch at %d, catchTop=%d, unwound to %d, new pc %u\n", + fprintf(stdout, " ... no enclosing catch, returning %s\n", + StringForResultCode(result)); + } +#endif + goto abnormalReturn; + } + + /* + * A catch exception range (rangePtr) was found to handle an + * "exception". It was found either by checkForCatch just above or + * by an instruction during break, continue, or error processing. + * Jump to its catchOffset after unwinding the operand stack to + * the depth it had when starting to execute the range's catch + * command. + */ + + processCatch: + while (stackTop > catchStackPtr[catchTop]) { + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); + } +#ifdef TCL_COMPILE_DEBUG + if (traceInstructions) { + fprintf(stdout, " ... found catch at %d, catchTop=%d, unwound to %d, new pc %u\n", rangePtr->codeOffset, catchTop, catchStackPtr[catchTop], (unsigned int)(rangePtr->catchOffset)); - } + } #endif - pc = (codePtr->codeStart + rangePtr->catchOffset); - continue; /* restart the execution loop at pc */ - } /* end of infinite loop dispatching on instructions */ + pc = (codePtr->codeStart + rangePtr->catchOffset); + NEXT_INST_F(0, 0, 0); /* restart the execution loop at pc */ + + /* + * end of infinite loop dispatching on instructions. + */ /* * Abnormal return code. Restore the stack to state it had when starting - * to execute the ByteCode. + * to execute the ByteCode. Panic if the stack is below the initial level. */ - abnormalReturn: + abnormalReturn: while (stackTop > initStackTop) { valuePtr = POP_OBJECT(); - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(valuePtr); } - + if (stackTop < initStackTop) { + fprintf(stderr, "\nTclExecuteByteCode: abnormal return at pc %u: stack top %d < entry stack top %d\n", + (unsigned int)(pc - codePtr->codeStart), + (unsigned int) stackTop, + (unsigned int) initStackTop); + panic("TclExecuteByteCode execution failure: end stack top < start stack top"); + } + /* * Free the catch stack array if malloc'ed storage was used. */ - done: if (catchStackPtr != catchStackStorage) { ckfree((char *) catchStackPtr); } @@ -3004,8 +4301,7 @@ PrintByteCodeInfo(codePtr) #ifdef TCL_COMPILE_DEBUG static void -ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound, - stackUpperBound) +ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound) register ByteCode *codePtr; /* The bytecode whose summary is printed * to stdout. */ unsigned char *pc; /* Points to first byte of a bytecode @@ -3014,8 +4310,9 @@ ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound, * stackLowerBound and stackUpperBound * (inclusive). */ int stackLowerBound; /* Smallest legal value for stackTop. */ - int stackUpperBound; /* Greatest legal value for stackTop. */ { + int stackUpperBound = stackLowerBound + codePtr->maxStackDepth; + /* Greatest legal value for stackTop. */ unsigned int relativePc = (unsigned int) (pc - codePtr->codeStart); unsigned int codeStart = (unsigned int) codePtr->codeStart; unsigned int codeEnd = (unsigned int) @@ -3030,15 +4327,15 @@ ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound, if ((unsigned int) opCode > LAST_INST_OPCODE) { fprintf(stderr, "\nBad opcode %d at pc %u in TclExecuteByteCode\n", (unsigned int) opCode, relativePc); - panic("TclExecuteByteCode execution failure: bad opcode"); + panic("TclExecuteByteCode execution failure: bad opcode"); } if ((stackTop < stackLowerBound) || (stackTop > stackUpperBound)) { int numChars; char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars); char *ellipsis = ""; - fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode", - stackTop, relativePc); + fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode (min %i, max %i)", + stackTop, relativePc, stackLowerBound, stackUpperBound); if (cmd != NULL) { if (numChars > 100) { numChars = 100; @@ -3090,27 +4387,101 @@ IllegalExprOperandType(interp, pc, opndPtr) operatorStrings[opCode - INST_LOR], "\"", (char *) NULL); } else { char *msg = "non-numeric string"; - if (opndPtr->typePtr != &tclDoubleType) { + char *s, *p; + int length; + int looksLikeInt = 0; + + s = Tcl_GetStringFromObj(opndPtr, &length); + p = s; + /* + * strtod() isn't at all consistent about detecting Inf and + * NaN between platforms. + */ + if (length == 3) { + if ((s[0]=='n' || s[0]=='N') && (s[1]=='a' || s[1]=='A') && + (s[2]=='n' || s[2]=='N')) { + msg = "non-numeric floating-point value"; + goto makeErrorMessage; + } + if ((s[0]=='i' || s[0]=='I') && (s[1]=='n' || s[1]=='N') && + (s[2]=='f' || s[2]=='F')) { + msg = "infinite floating-point value"; + goto makeErrorMessage; + } + } + + /* + * We cannot use TclLooksLikeInt here because it passes strings + * like "10;" [Bug 587140]. We'll accept as "looking like ints" + * for the present purposes any string that looks formally like + * a (decimal|octal|hex) integer. + */ + + while (length && isspace(UCHAR(*p))) { + length--; + p++; + } + if (length && ((*p == '+') || (*p == '-'))) { + length--; + p++; + } + if (length) { + if ((*p == '0') && ((*(p+1) == 'x') || (*(p+1) == 'X'))) { + p += 2; + length -= 2; + looksLikeInt = ((length > 0) && isxdigit(UCHAR(*p))); + if (looksLikeInt) { + length--; + p++; + while (length && isxdigit(UCHAR(*p))) { + length--; + p++; + } + } + } else { + looksLikeInt = (length && isdigit(UCHAR(*p))); + if (looksLikeInt) { + length--; + p++; + while (length && isdigit(UCHAR(*p))) { + length--; + p++; + } + } + } + while (length && isspace(UCHAR(*p))) { + length--; + p++; + } + looksLikeInt = !length; + } + if (looksLikeInt) { /* - * See if the operand can be interpreted as a double in order to - * improve the error message. + * If something that looks like an integer could not be + * converted, then it *must* be a bad octal or too large + * to represent [Bug 542588]. + */ + + if (TclCheckBadOctal(NULL, s)) { + msg = "invalid octal number"; + } else { + msg = "integer value too large to represent"; + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", + "integer value too large to represent", (char *) NULL); + } + } else { + /* + * See if the operand can be interpreted as a double in + * order to improve the error message. */ - char *s = Tcl_GetString(opndPtr); double d; if (Tcl_GetDouble((Tcl_Interp *) NULL, s, &d) == TCL_OK) { - /* - * Make sure that what appears to be a double - * (ie 08) isn't really a bad octal - */ - if (TclCheckBadOctal(NULL, Tcl_GetString(opndPtr))) { - msg = "invalid octal number"; - } else { - msg = "floating-point value"; - } + msg = "floating-point value"; } } + makeErrorMessage: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ", msg, " as operand of \"", operatorStrings[opCode - INST_LOR], "\"", (char *) NULL); @@ -3120,74 +4491,6 @@ IllegalExprOperandType(interp, pc, opndPtr) /* *---------------------------------------------------------------------- * - * CallTraceProcedure -- - * - * Invokes a trace procedure registered with an interpreter. These - * procedures trace command execution. Currently this trace procedure - * is called with the address of the string-based Tcl_CmdProc for the - * command, not the Tcl_ObjCmdProc. - * - * Results: - * None. - * - * Side effects: - * Those side effects made by the trace procedure. - * - *---------------------------------------------------------------------- - */ - -static void -CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv) - Tcl_Interp *interp; /* The current interpreter. */ - register Trace *tracePtr; /* Describes the trace procedure to call. */ - Command *cmdPtr; /* Points to command's Command struct. */ - char *command; /* Points to the first character of the - * command's source before substitutions. */ - int numChars; /* The number of characters in the - * command's source. */ - register int objc; /* Number of arguments for the command. */ - Tcl_Obj *objv[]; /* Pointers to Tcl_Obj of each argument. */ -{ - Interp *iPtr = (Interp *) interp; - register char **argv; - register int i; - int length; - char *p; - - /* - * Get the string rep from the objv argument objects and place their - * pointers in argv. First make sure argv is large enough to hold the - * objc args plus 1 extra word for the zero end-of-argv word. - */ - - argv = (char **) ckalloc((unsigned)(objc + 1) * sizeof(char *)); - for (i = 0; i < objc; i++) { - argv[i] = Tcl_GetStringFromObj(objv[i], &length); - } - argv[objc] = 0; - - /* - * Copy the command characters into a new string. - */ - - p = (char *) ckalloc((unsigned) (numChars + 1)); - memcpy((VOID *) p, (VOID *) command, (size_t) numChars); - p[numChars] = '\0'; - - /* - * Call the trace procedure then free allocated storage. - */ - - (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels, - p, cmdPtr->proc, cmdPtr->clientData, objc, argv); - - ckfree((char *) argv); - ckfree((char *) p); -} - -/* - *---------------------------------------------------------------------- - * * GetSrcInfoForPc -- * * Given a program counter value, finds the closest command in the @@ -3349,25 +4652,28 @@ GetExceptRangeForPc(pc, catchOnly, codePtr) int numRanges = codePtr->numExceptRanges; register ExceptionRange *rangePtr; int pcOffset = (pc - codePtr->codeStart); - register int i, level; + register int start; if (numRanges == 0) { return NULL; } - rangeArrayPtr = codePtr->exceptArrayPtr; - for (level = codePtr->maxExceptDepth; level >= 0; level--) { - for (i = 0; i < numRanges; i++) { - rangePtr = &(rangeArrayPtr[i]); - if (rangePtr->nestingLevel == level) { - int start = rangePtr->codeOffset; - int end = (start + rangePtr->numCodeBytes); - if ((start <= pcOffset) && (pcOffset < end)) { - if ((!catchOnly) - || (rangePtr->type == CATCH_EXCEPTION_RANGE)) { - return rangePtr; - } - } + /* + * This exploits peculiarities of our compiler: nested ranges + * are always *after* their containing ranges, so that by scanning + * backwards we are sure that the first matching range is indeed + * the deepest. + */ + + rangeArrayPtr = codePtr->exceptArrayPtr; + rangePtr = rangeArrayPtr + numRanges; + while (--rangePtr >= rangeArrayPtr) { + start = rangePtr->codeOffset; + if ((start <= pcOffset) && + (pcOffset < (start + rangePtr->numCodeBytes))) { + if ((!catchOnly) + || (rangePtr->type == CATCH_EXCEPTION_RANGE)) { + return rangePtr; } } } @@ -3400,7 +4706,7 @@ GetOpcodeName(pc) { unsigned char opCode = *pc; - return instructionTable[opCode].name; + return tclInstructionTable[opCode].name; } #endif /* TCL_COMPILE_DEBUG */ @@ -3418,7 +4724,8 @@ GetOpcodeName(pc) * TCL_OK if it was int or double, TCL_ERROR otherwise * * Side effects: - * objPtr is ensured to be either tclIntType of tclDoubleType. + * objPtr is ensured to be of tclIntType, tclWideIntType or + * tclDoubleType. * *---------------------------------------------------------------------- */ @@ -3429,16 +4736,20 @@ VerifyExprObjType(interp, objPtr) * function. */ Tcl_Obj *objPtr; /* Points to the object to type check. */ { - if ((objPtr->typePtr == &tclIntType) || - (objPtr->typePtr == &tclDoubleType)) { + if (IS_NUMERIC_TYPE(objPtr->typePtr)) { return TCL_OK; } else { int length, result = TCL_OK; char *s = Tcl_GetStringFromObj(objPtr, &length); if (TclLooksLikeInt(s, length)) { +#ifdef TCL_WIDE_INT_IS_LONG long i; result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, objPtr, &i); +#else /* !TCL_WIDE_INT_IS_LONG */ + Tcl_WideInt w; + result = Tcl_GetWideIntFromObj((Tcl_Interp *) NULL, objPtr, &w); +#endif /* TCL_WIDE_INT_IS_LONG */ } else { double d; result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, objPtr, &d); @@ -3515,12 +4826,8 @@ ExprUnaryFunc(interp, eePtr, clientData) result = TCL_ERROR; goto done; } - - if (valuePtr->typePtr == &tclIntType) { - d = (double) valuePtr->internalRep.longValue; - } else { - d = valuePtr->internalRep.doubleValue; - } + + GET_DOUBLE_VALUE(d, valuePtr, valuePtr->typePtr); errno = 0; dResult = (*func)(d); @@ -3541,7 +4848,7 @@ ExprUnaryFunc(interp, eePtr, clientData) */ done: - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(valuePtr); DECACHE_STACK_INFO(); return result; } @@ -3586,17 +4893,8 @@ ExprBinaryFunc(interp, eePtr, clientData) goto done; } - if (valuePtr->typePtr == &tclIntType) { - d1 = (double) valuePtr->internalRep.longValue; - } else { - d1 = valuePtr->internalRep.doubleValue; - } - - if (value2Ptr->typePtr == &tclIntType) { - d2 = (double) value2Ptr->internalRep.longValue; - } else { - d2 = value2Ptr->internalRep.doubleValue; - } + GET_DOUBLE_VALUE(d1, valuePtr, valuePtr->typePtr); + GET_DOUBLE_VALUE(d2, value2Ptr, value2Ptr->typePtr); errno = 0; dResult = (*func)(d1, d2); @@ -3617,8 +4915,8 @@ ExprBinaryFunc(interp, eePtr, clientData) */ done: - Tcl_DecrRefCount(valuePtr); - Tcl_DecrRefCount(value2Ptr); + TclDecrRefCount(valuePtr); + TclDecrRefCount(value2Ptr); DECACHE_STACK_INFO(); return result; } @@ -3676,6 +4974,25 @@ ExprAbsFunc(interp, eePtr, clientData) iResult = i; } PUSH_OBJECT(Tcl_NewLongObj(iResult)); +#ifndef TCL_WIDE_INT_IS_LONG + } else if (valuePtr->typePtr == &tclWideIntType) { + Tcl_WideInt wResult, w = valuePtr->internalRep.wideValue; + if (w < W0) { + wResult = -w; + if (wResult < 0) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "integer value too large to represent", -1); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", + "integer value too large to represent", (char *) NULL); + result = TCL_ERROR; + goto done; + } + } else { + wResult = w; + } + PUSH_OBJECT(Tcl_NewWideIntObj(wResult)); +#endif /* TCL_WIDE_INT_IS_LONG */ } else { d = valuePtr->internalRep.doubleValue; if (d < 0.0) { @@ -3696,7 +5013,7 @@ ExprAbsFunc(interp, eePtr, clientData) */ done: - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(valuePtr); DECACHE_STACK_INFO(); return result; } @@ -3733,11 +5050,7 @@ ExprDoubleFunc(interp, eePtr, clientData) goto done; } - if (valuePtr->typePtr == &tclIntType) { - dResult = (double) valuePtr->internalRep.longValue; - } else { - dResult = valuePtr->internalRep.doubleValue; - } + GET_DOUBLE_VALUE(dResult, valuePtr, valuePtr->typePtr); /* * Push a Tcl object with the result. @@ -3750,7 +5063,7 @@ ExprDoubleFunc(interp, eePtr, clientData) */ done: - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(valuePtr); DECACHE_STACK_INFO(); return result; } @@ -3790,6 +5103,10 @@ ExprIntFunc(interp, eePtr, clientData) if (valuePtr->typePtr == &tclIntType) { iResult = valuePtr->internalRep.longValue; +#ifndef TCL_WIDE_INT_IS_LONG + } else if (valuePtr->typePtr == &tclWideIntType) { + iResult = Tcl_WideAsLong(valuePtr->internalRep.wideValue); +#endif /* TCL_WIDE_INT_IS_LONG */ } else { d = valuePtr->internalRep.doubleValue; if (d < 0.0) { @@ -3827,10 +5144,91 @@ ExprIntFunc(interp, eePtr, clientData) */ done: - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(valuePtr); + DECACHE_STACK_INFO(); + return result; +} + +#ifndef TCL_WIDE_INT_IS_LONG +static int +ExprWideFunc(interp, eePtr, clientData) + Tcl_Interp *interp; /* The interpreter in which to execute the + * function. */ + ExecEnv *eePtr; /* Points to the environment for executing + * the function. */ + ClientData clientData; /* Ignored. */ +{ + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ + register int stackTop; /* Cached top index of evaluation stack. */ + register Tcl_Obj *valuePtr; + Tcl_WideInt wResult; + double d; + int result; + + /* + * Set stackPtr and stackTop from eePtr. + */ + + result = TCL_OK; + CACHE_STACK_INFO(); + + /* + * Pop the argument from the evaluation stack. + */ + + valuePtr = POP_OBJECT(); + + if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + + if (valuePtr->typePtr == &tclWideIntType) { + wResult = valuePtr->internalRep.wideValue; + } else if (valuePtr->typePtr == &tclIntType) { + wResult = Tcl_LongAsWide(valuePtr->internalRep.longValue); + } else { + d = valuePtr->internalRep.doubleValue; + if (d < 0.0) { + if (d < Tcl_WideAsDouble(LLONG_MIN)) { + tooLarge: + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "integer value too large to represent", -1); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", + "integer value too large to represent", (char *) NULL); + result = TCL_ERROR; + goto done; + } + } else { + if (d > Tcl_WideAsDouble(LLONG_MAX)) { + goto tooLarge; + } + } + if (IS_NAN(d) || IS_INF(d)) { + TclExprFloatError(interp, d); + result = TCL_ERROR; + goto done; + } + wResult = Tcl_DoubleAsWide(d); + } + + /* + * Push a Tcl object with the result. + */ + + PUSH_OBJECT(Tcl_NewWideIntObj(wResult)); + + /* + * Reflect the change to stackTop back in eePtr. + */ + + done: + TclDecrRefCount(valuePtr); DECACHE_STACK_INFO(); return result; } +#endif /* TCL_WIDE_INT_IS_LONG */ static int ExprRandFunc(interp, eePtr, clientData) @@ -3844,11 +5242,27 @@ ExprRandFunc(interp, eePtr, clientData) register int stackTop; /* Cached top index of evaluation stack. */ Interp *iPtr = (Interp *) interp; double dResult; - int tmp; + long tmp; /* Algorithm assumes at least 32 bits. + * Only long guarantees that. See below. */ if (!(iPtr->flags & RAND_SEED_INITIALIZED)) { iPtr->flags |= RAND_SEED_INITIALIZED; - iPtr->randSeed = TclpGetClicks(); + + /* + * Take into consideration the thread this interp is running in order + * to insure different seeds in different threads (bug #416643) + */ + + iPtr->randSeed = TclpGetClicks() + ((long)Tcl_GetCurrentThread()<<12); + + /* + * Make sure 1 <= randSeed <= (2^31) - 2. See below. + */ + + iPtr->randSeed &= (unsigned long) 0x7fffffff; + if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) { + iPtr->randSeed ^= 123459876; + } } /* @@ -3861,11 +5275,20 @@ ExprRandFunc(interp, eePtr, clientData) * Generate the random number using the linear congruential * generator defined by the following recurrence: * seed = ( IA * seed ) mod IM - * where IA is 16807 and IM is (2^31) - 1. In order to avoid - * potential problems with integer overflow, the code uses - * additional constants IQ and IR such that + * where IA is 16807 and IM is (2^31) - 1. The recurrence maps + * a seed in the range [1, IM - 1] to a new seed in that same range. + * The recurrence maps IM to 0, and maps 0 back to 0, so those two + * values must not be allowed as initial values of seed. + * + * In order to avoid potential problems with integer overflow, the + * recurrence is implemented in terms of additional constants + * IQ and IR such that * IM = IA*IQ + IR - * For details on how this algorithm works, refer to the following + * None of the operations in the implementation overflows a 32-bit + * signed integer, and the C type long is guaranteed to be at least + * 32 bits wide. + * + * For more details on how this algorithm works, refer to the following * papers: * * S.K. Park & K.W. Miller, "Random number generators: good ones @@ -3881,14 +5304,6 @@ ExprRandFunc(interp, eePtr, clientData) #define RAND_IR 2836 #define RAND_MASK 123459876 - if (iPtr->randSeed == 0) { - /* - * Don't allow a 0 seed, since it breaks the generator. Shift - * it to some other value. - */ - - iPtr->randSeed = 123459876; - } tmp = iPtr->randSeed/RAND_IQ; iPtr->randSeed = RAND_IA*(iPtr->randSeed - tmp*RAND_IQ) - RAND_IR*tmp; if (iPtr->randSeed < 0) { @@ -3896,14 +5311,10 @@ ExprRandFunc(interp, eePtr, clientData) } /* - * On 64-bit architectures we need to mask off the upper bits to - * ensure we only have a 32-bit range. The constant has the - * bizarre form below in order to make sure that it doesn't - * get sign-extended (the rules for sign extension are very - * concat, particularly on 64-bit machines). + * Since the recurrence keeps seed values in the range [1, RAND_IM - 1], + * dividing by RAND_IM yields a double in the range (0, 1). */ - iPtr->randSeed &= ((((unsigned long) 0xfffffff) << 4) | 0xf); dResult = iPtr->randSeed * (1.0/RAND_IM); /* @@ -3955,6 +5366,11 @@ ExprRoundFunc(interp, eePtr, clientData) if (valuePtr->typePtr == &tclIntType) { iResult = valuePtr->internalRep.longValue; +#ifndef TCL_WIDE_INT_IS_LONG + } else if (valuePtr->typePtr == &tclWideIntType) { + PUSH_OBJECT(Tcl_NewWideIntObj(valuePtr->internalRep.wideValue)); + goto done; +#endif /* TCL_WIDE_INT_IS_LONG */ } else { d = valuePtr->internalRep.doubleValue; if (d < 0.0) { @@ -3995,7 +5411,7 @@ ExprRoundFunc(interp, eePtr, clientData) */ done: - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(valuePtr); DECACHE_STACK_INFO(); return result; } @@ -4035,6 +5451,10 @@ ExprSrandFunc(interp, eePtr, clientData) if (valuePtr->typePtr == &tclIntType) { i = valuePtr->internalRep.longValue; +#ifndef TCL_WIDE_INT_IS_LONG + } else if (valuePtr->typePtr == &tclWideIntType) { + i = Tcl_WideAsLong(valuePtr->internalRep.wideValue); +#endif /* TCL_WIDE_INT_IS_LONG */ } else { /* * At this point, the only other possible type is double @@ -4044,17 +5464,22 @@ ExprSrandFunc(interp, eePtr, clientData) "can't use floating-point value as argument to srand", (char *) NULL); badValue: - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(valuePtr); DECACHE_STACK_INFO(); return TCL_ERROR; } /* - * Reset the seed. + * Reset the seed. Make sure 1 <= randSeed <= 2^31 - 2. + * See comments in ExprRandFunc() for more details. */ iPtr->flags |= RAND_SEED_INITIALIZED; iPtr->randSeed = i; + iPtr->randSeed &= (unsigned long) 0x7fffffff; + if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) { + iPtr->randSeed ^= 123459876; + } /* * To avoid duplicating the random number generation code we simply @@ -4062,7 +5487,7 @@ ExprSrandFunc(interp, eePtr, clientData) * function will always succeed. */ - Tcl_DecrRefCount(valuePtr); + TclDecrRefCount(valuePtr); DECACHE_STACK_INFO(); ExprRandFunc(interp, eePtr, clientData); @@ -4113,7 +5538,6 @@ ExprCallMathFunc(interp, eePtr, objc, objv) long i; double d; int j, k, result; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); Tcl_ResetResult(interp); @@ -4127,7 +5551,7 @@ ExprCallMathFunc(interp, eePtr, objc, objv) * Look up the MathFunc record for the function. */ - funcName = Tcl_GetString(objv[0]); + funcName = TclGetString(objv[0]); hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName); if (hPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), @@ -4167,15 +5591,39 @@ ExprCallMathFunc(interp, eePtr, objc, objv) if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) { args[k].type = TCL_DOUBLE; args[k].doubleValue = i; +#ifndef TCL_WIDE_INT_IS_LONG + } else if (mathFuncPtr->argTypes[k] == TCL_WIDE_INT) { + args[k].type = TCL_WIDE_INT; + args[k].wideValue = Tcl_LongAsWide(i); +#endif /* !TCL_WIDE_INT_IS_LONG */ } else { args[k].type = TCL_INT; args[k].intValue = i; } +#ifndef TCL_WIDE_INT_IS_LONG + } else if (valuePtr->typePtr == &tclWideIntType) { + Tcl_WideInt w = valuePtr->internalRep.wideValue; + if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) { + args[k].type = TCL_DOUBLE; + args[k].wideValue = (Tcl_WideInt) Tcl_WideAsDouble(w); + } else if (mathFuncPtr->argTypes[k] == TCL_INT) { + args[k].type = TCL_INT; + args[k].wideValue = Tcl_WideAsLong(w); + } else { + args[k].type = TCL_WIDE_INT; + args[k].wideValue = w; + } +#endif /* !TCL_WIDE_INT_IS_LONG */ } else { d = valuePtr->internalRep.doubleValue; if (mathFuncPtr->argTypes[k] == TCL_INT) { args[k].type = TCL_INT; args[k].intValue = (long) d; +#ifndef TCL_WIDE_INT_IS_LONG + } else if (mathFuncPtr->argTypes[k] == TCL_WIDE_INT) { + args[k].type = TCL_WIDE_INT; + args[k].wideValue = Tcl_DoubleAsWide(d); +#endif /* !TCL_WIDE_INT_IS_LONG */ } else { args[k].type = TCL_DOUBLE; args[k].doubleValue = d; @@ -4187,10 +5635,8 @@ ExprCallMathFunc(interp, eePtr, objc, objv) * Invoke the function and copy its result back into valuePtr. */ - tsdPtr->mathInProgress++; result = (*mathFuncPtr->proc)(mathFuncPtr->clientData, interp, args, &funcResult); - tsdPtr->mathInProgress--; if (result != TCL_OK) { goto done; } @@ -4198,14 +5644,12 @@ ExprCallMathFunc(interp, eePtr, objc, objv) /* * Pop the objc top stack elements and decrement their ref counts. */ - - i = (stackTop - (objc-1)); - while (i <= stackTop) { - valuePtr = stackPtr[i]; - Tcl_DecrRefCount(valuePtr); - i++; + + k = (stackTop - (objc-1)); + while (stackTop >= k) { + valuePtr = POP_OBJECT(); + TclDecrRefCount(valuePtr); } - stackTop -= objc; /* * Push the call's object result. @@ -4213,6 +5657,10 @@ ExprCallMathFunc(interp, eePtr, objc, objv) if (funcResult.type == TCL_INT) { PUSH_OBJECT(Tcl_NewLongObj(funcResult.intValue)); +#ifndef TCL_WIDE_INT_IS_LONG + } else if (funcResult.type == TCL_WIDE_INT) { + PUSH_OBJECT(Tcl_NewWideIntObj(funcResult.wideValue)); +#endif /* !TCL_WIDE_INT_IS_LONG */ } else { d = funcResult.doubleValue; if (IS_NAN(d) || IS_INF(d)) { @@ -4282,30 +5730,6 @@ TclExprFloatError(interp, value) } } -/* - *---------------------------------------------------------------------- - * - * TclMathInProgress -- - * - * This procedure is called to find out if Tcl is doing math - * in this thread. - * - * Results: - * 0 or 1. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclMathInProgress() -{ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - return tsdPtr->mathInProgress; -} - #ifdef TCL_COMPILE_STATS /* *---------------------------------------------------------------------- @@ -4449,7 +5873,7 @@ EvalStatsCmd(unused, interp, argc, argv) fprintf(stdout, " Mean code/source %.1f\n", totalCodeBytes / statsPtr->totalSrcBytes); - fprintf(stdout, "\nCurrent ByteCodes %ld\n", + fprintf(stdout, "\nCurrent (active) ByteCodes %ld\n", numCurrentByteCodes); fprintf(stdout, " Source bytes %.6g\n", statsPtr->currentSrcBytes); @@ -4472,6 +5896,29 @@ EvalStatsCmd(unused, interp, argc, argv) (currentCodeBytes / statsPtr->currentSrcBytes) + 1.0); /* + * Tcl_IsShared statistics check + * + * This gives the refcount of each obj as Tcl_IsShared was called + * for it. Shared objects must be duplicated before they can be + * modified. + */ + + numSharedMultX = 0; + fprintf(stdout, "\nTcl_IsShared object check (all objects):\n"); + fprintf(stdout, " Object had refcount <=1 (not shared) %ld\n", + tclObjsShared[1]); + for (i = 2; i < TCL_MAX_SHARED_OBJ_STATS; i++) { + fprintf(stdout, " refcount ==%d %ld\n", + i, tclObjsShared[i]); + numSharedMultX += tclObjsShared[i]; + } + fprintf(stdout, " refcount >=%d %ld\n", + i, tclObjsShared[0]); + numSharedMultX += tclObjsShared[0]; + fprintf(stdout, " Total shared objects %d\n", + numSharedMultX); + + /* * Literal table statistics. */ @@ -4511,7 +5958,7 @@ EvalStatsCmd(unused, interp, argc, argv) (tclObjsAlloced - tclObjsFreed)); fprintf(stdout, "Total literal objects %ld\n", statsPtr->numLiteralsCreated); - + fprintf(stdout, "\nCurrent literal objects %d (%0.1f%% of current objects)\n", globalTablePtr->numEntries, (globalTablePtr->numEntries * 100.0) / (tclObjsAlloced-tclObjsFreed)); @@ -4662,7 +6109,7 @@ EvalStatsCmd(unused, interp, argc, argv) decadeHigh, (sum * 100.0) / statsPtr->numCompilations); } - fprintf(stdout, "\nByteCode longevity (excludes current ByteCodes):\n"); + fprintf(stdout, "\nByteCode longevity (excludes Current ByteCodes):\n"); fprintf(stdout, " Up to ms Percentage\n"); minSizeDecade = maxSizeDecade = 0; for (i = 0; i < 31; i++) { @@ -4694,7 +6141,7 @@ EvalStatsCmd(unused, interp, argc, argv) for (i = 0; i <= LAST_INST_OPCODE; i++) { if (statsPtr->instructionCount[i]) { fprintf(stdout, "%20s %8ld %6.1f%%\n", - instructionTable[i].name, + tclInstructionTable[i].name, statsPtr->instructionCount[i], (statsPtr->instructionCount[i]*100.0) / numInstructions); } @@ -4703,8 +6150,7 @@ EvalStatsCmd(unused, interp, argc, argv) fprintf(stdout, "\nInstructions NEVER executed:\n"); for (i = 0; i <= LAST_INST_OPCODE; i++) { if (statsPtr->instructionCount[i] == 0) { - fprintf(stdout, "%20s\n", - instructionTable[i].name); + fprintf(stdout, "%20s\n", tclInstructionTable[i].name); } } @@ -4717,345 +6163,6 @@ EvalStatsCmd(unused, interp, argc, argv) } #endif /* TCL_COMPILE_STATS */ -/* - *---------------------------------------------------------------------- - * - * Tcl_GetCommandFromObj -- - * - * Returns the command specified by the name in a Tcl_Obj. - * - * Results: - * Returns a token for the command if it is found. Otherwise, if it - * can't be found or there is an error, returns NULL. - * - * Side effects: - * May update the internal representation for the object, caching - * the command reference so that the next time this procedure is - * called with the same object, the command can be found quickly. - * - *---------------------------------------------------------------------- - */ - -Tcl_Command -Tcl_GetCommandFromObj(interp, objPtr) - Tcl_Interp *interp; /* The interpreter in which to resolve the - * command and to report errors. */ - register Tcl_Obj *objPtr; /* The object containing the command's - * name. If the name starts with "::", will - * be looked up in global namespace. Else, - * looked up first in the current namespace - * if contextNsPtr is NULL, then in global - * namespace. */ -{ - Interp *iPtr = (Interp *) interp; - register ResolvedCmdName *resPtr; - register Command *cmdPtr; - Namespace *currNsPtr; - int result; - - /* - * Get the internal representation, converting to a command type if - * needed. The internal representation is a ResolvedCmdName that points - * to the actual command. - */ - - if (objPtr->typePtr != &tclCmdNameType) { - result = tclCmdNameType.setFromAnyProc(interp, objPtr); - if (result != TCL_OK) { - return (Tcl_Command) NULL; - } - } - resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr; - - /* - * Get the current namespace. - */ - - if (iPtr->varFramePtr != NULL) { - currNsPtr = iPtr->varFramePtr->nsPtr; - } else { - currNsPtr = iPtr->globalNsPtr; - } - - /* - * Check the context namespace and the namespace epoch of the resolved - * symbol to make sure that it is fresh. If not, then force another - * conversion to the command type, to discard the old rep and create a - * new one. Note that we verify that the namespace id of the context - * namespace is the same as the one we cached; this insures that the - * namespace wasn't deleted and a new one created at the same address - * with the same command epoch. - */ - - cmdPtr = NULL; - if ((resPtr != NULL) - && (resPtr->refNsPtr == currNsPtr) - && (resPtr->refNsId == currNsPtr->nsId) - && (resPtr->refNsCmdEpoch == currNsPtr->cmdRefEpoch)) { - cmdPtr = resPtr->cmdPtr; - if (cmdPtr->cmdEpoch != resPtr->cmdEpoch) { - cmdPtr = NULL; - } - } - - if (cmdPtr == NULL) { - result = tclCmdNameType.setFromAnyProc(interp, objPtr); - if (result != TCL_OK) { - return (Tcl_Command) NULL; - } - resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr; - if (resPtr != NULL) { - cmdPtr = resPtr->cmdPtr; - } - } - return (Tcl_Command) cmdPtr; -} - -/* - *---------------------------------------------------------------------- - * - * TclSetCmdNameObj -- - * - * Modify an object to be an CmdName object that refers to the argument - * Command structure. - * - * Results: - * None. - * - * Side effects: - * The object's old internal rep is freed. It's string rep is not - * changed. The refcount in the Command structure is incremented to - * keep it from being freed if the command is later deleted until - * TclExecuteByteCode has a chance to recognize that it was deleted. - * - *---------------------------------------------------------------------- - */ - -void -TclSetCmdNameObj(interp, objPtr, cmdPtr) - Tcl_Interp *interp; /* Points to interpreter containing command - * that should be cached in objPtr. */ - register Tcl_Obj *objPtr; /* Points to Tcl object to be changed to - * a CmdName object. */ - Command *cmdPtr; /* Points to Command structure that the - * CmdName object should refer to. */ -{ - Interp *iPtr = (Interp *) interp; - register ResolvedCmdName *resPtr; - Tcl_ObjType *oldTypePtr = objPtr->typePtr; - register Namespace *currNsPtr; - - if (oldTypePtr == &tclCmdNameType) { - return; - } - - /* - * Get the current namespace. - */ - - if (iPtr->varFramePtr != NULL) { - currNsPtr = iPtr->varFramePtr->nsPtr; - } else { - currNsPtr = iPtr->globalNsPtr; - } - - cmdPtr->refCount++; - resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName)); - resPtr->cmdPtr = cmdPtr; - resPtr->refNsPtr = currNsPtr; - resPtr->refNsId = currNsPtr->nsId; - resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; - resPtr->cmdEpoch = cmdPtr->cmdEpoch; - resPtr->refCount = 1; - - if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { - oldTypePtr->freeIntRepProc(objPtr); - } - objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - objPtr->typePtr = &tclCmdNameType; -} - -/* - *---------------------------------------------------------------------- - * - * FreeCmdNameInternalRep -- - * - * Frees the resources associated with a cmdName object's internal - * representation. - * - * Results: - * None. - * - * Side effects: - * Decrements the ref count of any cached ResolvedCmdName structure - * pointed to by the cmdName's internal representation. If this is - * the last use of the ResolvedCmdName, it is freed. This in turn - * decrements the ref count of the Command structure pointed to by - * the ResolvedSymbol, which may free the Command structure. - * - *---------------------------------------------------------------------- - */ - -static void -FreeCmdNameInternalRep(objPtr) - register Tcl_Obj *objPtr; /* CmdName object with internal - * representation to free. */ -{ - register ResolvedCmdName *resPtr = - (ResolvedCmdName *) objPtr->internalRep.otherValuePtr; - - if (resPtr != NULL) { - /* - * Decrement the reference count of the ResolvedCmdName structure. - * If there are no more uses, free the ResolvedCmdName structure. - */ - - resPtr->refCount--; - if (resPtr->refCount == 0) { - /* - * Now free the cached command, unless it is still in its - * hash table or if there are other references to it - * from other cmdName objects. - */ - - Command *cmdPtr = resPtr->cmdPtr; - TclCleanupCommand(cmdPtr); - ckfree((char *) resPtr); - } - } -} - -/* - *---------------------------------------------------------------------- - * - * DupCmdNameInternalRep -- - * - * Initialize the internal representation of an cmdName Tcl_Obj to a - * copy of the internal representation of an existing cmdName object. - * - * Results: - * None. - * - * Side effects: - * "copyPtr"s internal rep is set to point to the ResolvedCmdName - * structure corresponding to "srcPtr"s internal rep. Increments the - * ref count of the ResolvedCmdName structure pointed to by the - * cmdName's internal representation. - * - *---------------------------------------------------------------------- - */ - -static void -DupCmdNameInternalRep(srcPtr, copyPtr) - Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ - register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ -{ - register ResolvedCmdName *resPtr = - (ResolvedCmdName *) srcPtr->internalRep.otherValuePtr; - - copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; - copyPtr->internalRep.twoPtrValue.ptr2 = NULL; - if (resPtr != NULL) { - resPtr->refCount++; - } - copyPtr->typePtr = &tclCmdNameType; -} - -/* - *---------------------------------------------------------------------- - * - * SetCmdNameFromAny -- - * - * Generate an cmdName internal form for the Tcl object "objPtr". - * - * Results: - * The return value is a standard Tcl result. The conversion always - * succeeds and TCL_OK is returned. - * - * Side effects: - * A pointer to a ResolvedCmdName structure that holds a cached pointer - * to the command with a name that matches objPtr's string rep is - * stored as objPtr's internal representation. This ResolvedCmdName - * pointer will be NULL if no matching command was found. The ref count - * of the cached Command's structure (if any) is also incremented. - * - *---------------------------------------------------------------------- - */ - -static int -SetCmdNameFromAny(interp, objPtr) - Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr; /* The object to convert. */ -{ - Interp *iPtr = (Interp *) interp; - char *name; - Tcl_Command cmd; - register Command *cmdPtr; - Namespace *currNsPtr; - register ResolvedCmdName *resPtr; - - /* - * Get "objPtr"s string representation. Make it up-to-date if necessary. - */ - - name = objPtr->bytes; - if (name == NULL) { - name = Tcl_GetString(objPtr); - } - - /* - * Find the Command structure, if any, that describes the command called - * "name". Build a ResolvedCmdName that holds a cached pointer to this - * Command, and bump the reference count in the referenced Command - * structure. A Command structure will not be deleted as long as it is - * referenced from a CmdName object. - */ - - cmd = Tcl_FindCommand(interp, name, (Tcl_Namespace *) NULL, - /*flags*/ 0); - cmdPtr = (Command *) cmd; - if (cmdPtr != NULL) { - /* - * Get the current namespace. - */ - - if (iPtr->varFramePtr != NULL) { - currNsPtr = iPtr->varFramePtr->nsPtr; - } else { - currNsPtr = iPtr->globalNsPtr; - } - - cmdPtr->refCount++; - resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName)); - resPtr->cmdPtr = cmdPtr; - resPtr->refNsPtr = currNsPtr; - resPtr->refNsId = currNsPtr->nsId; - resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; - resPtr->cmdEpoch = cmdPtr->cmdEpoch; - resPtr->refCount = 1; - } else { - resPtr = NULL; /* no command named "name" was found */ - } - - /* - * Free the old internalRep before setting the new one. We do this as - * late as possible to allow the conversion code, in particular - * GetStringFromObj, to use that old internalRep. If no Command - * structure was found, leave NULL as the cached value. - */ - - if ((objPtr->typePtr != NULL) - && (objPtr->typePtr->freeIntRepProc != NULL)) { - objPtr->typePtr->freeIntRepProc(objPtr); - } - - objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - objPtr->typePtr = &tclCmdNameType; - return TCL_OK; -} - #ifdef TCL_COMPILE_DEBUG /* *---------------------------------------------------------------------- @@ -5092,4 +6199,3 @@ StringForResultCode(result) return buf; } #endif /* TCL_COMPILE_DEBUG */ - diff --git a/tcl/generic/tclFCmd.c b/tcl/generic/tclFCmd.c index 8e1d84a838a..f51b4d4a63a 100644 --- a/tcl/generic/tclFCmd.c +++ b/tcl/generic/tclFCmd.c @@ -20,14 +20,14 @@ */ static int CopyRenameOneFile _ANSI_ARGS_((Tcl_Interp *interp, - char *source, char *dest, int copyFlag, - int force)); -static char * FileBasename _ANSI_ARGS_((Tcl_Interp *interp, - char *path, Tcl_DString *bufferPtr)); + Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr, + int copyFlag, int force)); +static Tcl_Obj * FileBasename _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *pathPtr)); static int FileCopyRename _ANSI_ARGS_((Tcl_Interp *interp, - int argc, char **argv, int copyFlag)); + int objc, Tcl_Obj *CONST objv[], int copyFlag)); static int FileForceOption _ANSI_ARGS_((Tcl_Interp *interp, - int argc, char **argv, int *forcePtr)); + int objc, Tcl_Obj *CONST objv[], int *forcePtr)); /* *--------------------------------------------------------------------------- @@ -49,12 +49,12 @@ static int FileForceOption _ANSI_ARGS_((Tcl_Interp *interp, */ int -TclFileRenameCmd(interp, argc, argv) +TclFileRenameCmd(interp, objc, objv) Tcl_Interp *interp; /* Interp for error reporting. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings passed to Tcl_FileCmd. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */ { - return FileCopyRename(interp, argc, argv, 0); + return FileCopyRename(interp, objc, objv, 0); } /* @@ -77,12 +77,12 @@ TclFileRenameCmd(interp, argc, argv) */ int -TclFileCopyCmd(interp, argc, argv) +TclFileCopyCmd(interp, objc, objv) Tcl_Interp *interp; /* Used for error reporting */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings passed to Tcl_FileCmd. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */ { - return FileCopyRename(interp, argc, argv, 1); + return FileCopyRename(interp, objc, objv, 1); } /* @@ -103,26 +103,26 @@ TclFileCopyCmd(interp, argc, argv) */ static int -FileCopyRename(interp, argc, argv, copyFlag) +FileCopyRename(interp, objc, objv, copyFlag) Tcl_Interp *interp; /* Used for error reporting. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings passed to Tcl_FileCmd. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */ int copyFlag; /* If non-zero, copy source(s). Otherwise, * rename them. */ { int i, result, force; - struct stat statBuf; - Tcl_DString targetBuffer; - char *target; + Tcl_StatBuf statBuf; + Tcl_Obj *target; - i = FileForceOption(interp, argc - 2, argv + 2, &force); + i = FileForceOption(interp, objc - 2, objv + 2, &force); if (i < 0) { return TCL_ERROR; } i += 2; - if ((argc - i) < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ", argv[1], " ?options? source ?source ...? target\"", + if ((objc - i) < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + Tcl_GetString(objv[0]), " ", Tcl_GetString(objv[1]), + " ?options? source ?source ...? target\"", (char *) NULL); return TCL_ERROR; } @@ -133,38 +133,38 @@ FileCopyRename(interp, argc, argv, copyFlag) * directory. */ - target = Tcl_TranslateFileName(interp, argv[argc - 1], &targetBuffer); - if (target == NULL) { + target = objv[objc - 1]; + if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) { return TCL_ERROR; } result = TCL_OK; /* - * Call TclStat() so that if target is a symlink that points to a + * Call Tcl_FSStat() so that if target is a symlink that points to a * directory we will put the sources in that directory instead of * overwriting the symlink. */ - if ((TclStat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) { - if ((argc - i) > 2) { + if ((Tcl_FSStat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) { + if ((objc - i) > 2) { errno = ENOTDIR; Tcl_PosixError(interp); Tcl_AppendResult(interp, "error ", ((copyFlag) ? "copying" : "renaming"), ": target \"", - argv[argc - 1], "\" is not a directory", (char *) NULL); + Tcl_GetString(target), "\" is not a directory", + (char *) NULL); result = TCL_ERROR; } else { /* - * Even though already have target == translated(argv[i+1]), + * Even though already have target == translated(objv[i+1]), * pass the original argument down, so if there's an error, the * error message will reflect the original arguments. */ - result = CopyRenameOneFile(interp, argv[i], argv[i + 1], copyFlag, + result = CopyRenameOneFile(interp, objv[i], objv[i + 1], copyFlag, force); } - Tcl_DStringFree(&targetBuffer); return result; } @@ -173,30 +173,31 @@ FileCopyRename(interp, argc, argv, copyFlag) * from each source, and append it to the end of the target path. */ - for ( ; i < argc - 1; i++) { - char *jargv[2]; - char *source, *newFileName; - Tcl_DString sourceBuffer, newFileNameBuffer; - - source = FileBasename(interp, argv[i], &sourceBuffer); + for ( ; i < objc - 1; i++) { + Tcl_Obj *jargv[2]; + Tcl_Obj *source, *newFileName; + Tcl_Obj *temp; + + source = FileBasename(interp, objv[i]); if (source == NULL) { result = TCL_ERROR; break; } - jargv[0] = argv[argc - 1]; + jargv[0] = objv[objc - 1]; jargv[1] = source; - Tcl_DStringInit(&newFileNameBuffer); - newFileName = Tcl_JoinPath(2, jargv, &newFileNameBuffer); - result = CopyRenameOneFile(interp, argv[i], newFileName, copyFlag, + temp = Tcl_NewListObj(2, jargv); + newFileName = Tcl_FSJoinPath(temp, -1); + Tcl_IncrRefCount(newFileName); + result = CopyRenameOneFile(interp, objv[i], newFileName, copyFlag, force); - Tcl_DStringFree(&sourceBuffer); - Tcl_DStringFree(&newFileNameBuffer); + Tcl_DecrRefCount(newFileName); + Tcl_DecrRefCount(temp); + Tcl_DecrRefCount(source); if (result == TCL_ERROR) { break; } } - Tcl_DStringFree(&targetBuffer); return result; } @@ -219,74 +220,72 @@ FileCopyRename(interp, argc, argv, copyFlag) *---------------------------------------------------------------------- */ int -TclFileMakeDirsCmd(interp, argc, argv) +TclFileMakeDirsCmd(interp, objc, objv) Tcl_Interp *interp; /* Used for error reporting. */ - int argc; /* Number of arguments */ - char **argv; /* Argument strings passed to Tcl_FileCmd. */ + int objc; /* Number of arguments */ + Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */ { - Tcl_DString nameBuffer, targetBuffer; - char *errfile; - int result, i, j, pargc; - char **pargv; - struct stat statBuf; + Tcl_Obj *errfile; + int result, i, j, pobjc; + Tcl_Obj *split = NULL; + Tcl_Obj *target = NULL; + Tcl_StatBuf statBuf; - pargv = NULL; errfile = NULL; - Tcl_DStringInit(&nameBuffer); - Tcl_DStringInit(&targetBuffer); result = TCL_OK; - for (i = 2; i < argc; i++) { - char *name = Tcl_TranslateFileName(interp, argv[i], &nameBuffer); - if (name == NULL) { + for (i = 2; i < objc; i++) { + if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) { result = TCL_ERROR; break; } - Tcl_SplitPath(name, &pargc, &pargv); - if (pargc == 0) { + split = Tcl_FSSplitPath(objv[i],&pobjc); + if (pobjc == 0) { errno = ENOENT; - errfile = argv[i]; + errfile = objv[i]; break; } - for (j = 0; j < pargc; j++) { - char *target = Tcl_JoinPath(j + 1, pargv, &targetBuffer); - + for (j = 0; j < pobjc; j++) { + target = Tcl_FSJoinPath(split, j + 1); + Tcl_IncrRefCount(target); /* - * Call TclStat() so that if target is a symlink that points - * to a directory we will create subdirectories in that - * directory. + * Call Tcl_FSStat() so that if target is a symlink that + * points to a directory we will create subdirectories in + * that directory. */ - if (TclStat(target, &statBuf) == 0) { + if (Tcl_FSStat(target, &statBuf) == 0) { if (!S_ISDIR(statBuf.st_mode)) { errno = EEXIST; errfile = target; goto done; } } else if ((errno != ENOENT) - || (TclpCreateDirectory(target) != TCL_OK)) { + || (Tcl_FSCreateDirectory(target) != TCL_OK)) { errfile = target; goto done; } - Tcl_DStringFree(&targetBuffer); + /* Forget about this sub-path */ + Tcl_DecrRefCount(target); + target = NULL; } - ckfree((char *) pargv); - pargv = NULL; - Tcl_DStringFree(&nameBuffer); + Tcl_DecrRefCount(split); + split = NULL; } done: if (errfile != NULL) { Tcl_AppendResult(interp, "can't create directory \"", - errfile, "\": ", Tcl_PosixError(interp), (char *) NULL); + Tcl_GetString(errfile), "\": ", Tcl_PosixError(interp), + (char *) NULL); result = TCL_ERROR; } - - Tcl_DStringFree(&nameBuffer); - Tcl_DStringFree(&targetBuffer); - if (pargv != NULL) { - ckfree((char *) pargv); + if (split != NULL) { + Tcl_DecrRefCount(split); + } + if (target != NULL) { + Tcl_DecrRefCount(target); } return result; } @@ -309,39 +308,35 @@ TclFileMakeDirsCmd(interp, argc, argv) */ int -TclFileDeleteCmd(interp, argc, argv) +TclFileDeleteCmd(interp, objc, objv) Tcl_Interp *interp; /* Used for error reporting */ - int argc; /* Number of arguments */ - char **argv; /* Argument strings passed to Tcl_FileCmd. */ + int objc; /* Number of arguments */ + Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */ { - Tcl_DString nameBuffer, errorBuffer; int i, force, result; - char *errfile; + Tcl_Obj *errfile; + Tcl_Obj *errorBuffer = NULL; - i = FileForceOption(interp, argc - 2, argv + 2, &force); + i = FileForceOption(interp, objc - 2, objv + 2, &force); if (i < 0) { return TCL_ERROR; } i += 2; - if ((argc - i) < 1) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ", argv[1], " ?options? file ?file ...?\"", (char *) NULL); + if ((objc - i) < 1) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + Tcl_GetString(objv[0]), " ", Tcl_GetString(objv[1]), + " ?options? file ?file ...?\"", (char *) NULL); return TCL_ERROR; } errfile = NULL; result = TCL_OK; - Tcl_DStringInit(&errorBuffer); - Tcl_DStringInit(&nameBuffer); - for ( ; i < argc; i++) { - struct stat statBuf; - char *name; + for ( ; i < objc; i++) { + Tcl_StatBuf statBuf; - errfile = argv[i]; - Tcl_DStringSetLength(&nameBuffer, 0); - name = Tcl_TranslateFileName(interp, argv[i], &nameBuffer); - if (name == NULL) { + errfile = objv[i]; + if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) { result = TCL_ERROR; goto done; } @@ -350,7 +345,7 @@ TclFileDeleteCmd(interp, argc, argv) * Call lstat() to get info so can delete symbolic link itself. */ - if (TclpLstat(name, &statBuf) != 0) { + if (Tcl_FSLstat(objv[i], &statBuf) != 0) { /* * Trying to delete a file that does not exist is not * considered an error, just a no-op @@ -360,10 +355,15 @@ TclFileDeleteCmd(interp, argc, argv) result = TCL_ERROR; } } else if (S_ISDIR(statBuf.st_mode)) { - result = TclpRemoveDirectory(name, force, &errorBuffer); + /* + * We own a reference count on errorBuffer, if it was set + * as a result of this call. + */ + result = Tcl_FSRemoveDirectory(objv[i], force, &errorBuffer); if (result != TCL_OK) { if ((force == 0) && (errno == EEXIST)) { - Tcl_AppendResult(interp, "error deleting \"", argv[i], + Tcl_AppendResult(interp, "error deleting \"", + Tcl_GetString(objv[i]), "\": directory not empty", (char *) NULL); Tcl_PosixError(interp); goto done; @@ -373,26 +373,44 @@ TclFileDeleteCmd(interp, argc, argv) * If possible, use the untranslated name for the file. */ - errfile = Tcl_DStringValue(&errorBuffer); - if (strcmp(name, errfile) == 0) { - errfile = argv[i]; + errfile = errorBuffer; + /* FS supposed to check between translated objv and errfile */ + if (Tcl_FSEqualPaths(objv[i], errfile)) { + errfile = objv[i]; } } } else { - result = TclpDeleteFile(name); + result = Tcl_FSDeleteFile(objv[i]); } - if (result == TCL_ERROR) { + if (result != TCL_OK) { + result = TCL_ERROR; + /* + * It is important that we break on error, otherwise we + * might end up owning reference counts on numerous + * errorBuffers. + */ break; } } if (result != TCL_OK) { - Tcl_AppendResult(interp, "error deleting \"", errfile, - "\": ", Tcl_PosixError(interp), (char *) NULL); + if (errfile == NULL) { + /* + * We try to accomodate poor error results from our + * Tcl_FS calls + */ + Tcl_AppendResult(interp, "error deleting unknown file: ", + Tcl_PosixError(interp), (char *) NULL); + } else { + Tcl_AppendResult(interp, "error deleting \"", + Tcl_GetString(errfile), "\": ", + Tcl_PosixError(interp), (char *) NULL); + } } done: - Tcl_DStringFree(&errorBuffer); - Tcl_DStringFree(&nameBuffer); + if (errorBuffer != NULL) { + Tcl_DecrRefCount(errorBuffer); + } return result; } @@ -418,9 +436,9 @@ TclFileDeleteCmd(interp, argc, argv) static int CopyRenameOneFile(interp, source, target, copyFlag, force) Tcl_Interp *interp; /* Used for error reporting. */ - char *source; /* Pathname of file to copy. May need to + Tcl_Obj *source; /* Pathname of file to copy. May need to * be translated. */ - char *target; /* Pathname of file to create/overwrite. + Tcl_Obj *target; /* Pathname of file to create/overwrite. * May need to be translated. */ int copyFlag; /* If non-zero, copy files. Otherwise, * rename them. */ @@ -429,23 +447,21 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) * exists. */ { int result; - Tcl_DString sourcePath, targetPath, errorBuffer; - char *targetName, *sourceName, *errfile; - struct stat sourceStatBuf, targetStatBuf; + Tcl_Obj *errfile, *errorBuffer; + /* If source is a link, then this is the real file/directory */ + Tcl_Obj *actualSource = NULL; + Tcl_StatBuf sourceStatBuf, targetStatBuf; - sourceName = Tcl_TranslateFileName(interp, source, &sourcePath); - if (sourceName == NULL) { + if (Tcl_FSConvertToPathType(interp, source) != TCL_OK) { return TCL_ERROR; } - targetName = Tcl_TranslateFileName(interp, target, &targetPath); - if (targetName == NULL) { - Tcl_DStringFree(&sourcePath); + if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) { return TCL_ERROR; } errfile = NULL; + errorBuffer = NULL; result = TCL_ERROR; - Tcl_DStringInit(&errorBuffer); /* * We want to copy/rename links and not the files they point to, so we @@ -454,11 +470,11 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) * target. */ - if (TclpLstat(sourceName, &sourceStatBuf) != 0) { + if (Tcl_FSLstat(source, &sourceStatBuf) != 0) { errfile = source; goto done; } - if (TclpLstat(targetName, &targetStatBuf) != 0) { + if (Tcl_FSLstat(target, &targetStatBuf) != 0) { if (errno != ENOENT) { errfile = target; goto done; @@ -495,28 +511,31 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) if (S_ISDIR(sourceStatBuf.st_mode) && !S_ISDIR(targetStatBuf.st_mode)) { errno = EISDIR; - Tcl_AppendResult(interp, "can't overwrite file \"", target, - "\" with directory \"", source, "\"", (char *) NULL); + Tcl_AppendResult(interp, "can't overwrite file \"", + Tcl_GetString(target), "\" with directory \"", + Tcl_GetString(source), "\"", (char *) NULL); goto done; } if (!S_ISDIR(sourceStatBuf.st_mode) && S_ISDIR(targetStatBuf.st_mode)) { errno = EISDIR; - Tcl_AppendResult(interp, "can't overwrite directory \"", target, - "\" with file \"", source, "\"", (char *) NULL); + Tcl_AppendResult(interp, "can't overwrite directory \"", + Tcl_GetString(target), "\" with file \"", + Tcl_GetString(source), "\"", (char *) NULL); goto done; } } if (copyFlag == 0) { - result = TclpRenameFile(sourceName, targetName); + result = Tcl_FSRenameFile(source, target); if (result == TCL_OK) { goto done; } if (errno == EINVAL) { - Tcl_AppendResult(interp, "error renaming \"", source, "\" to \"", - target, "\": trying to rename a volume or ", + Tcl_AppendResult(interp, "error renaming \"", + Tcl_GetString(source), "\" to \"", + Tcl_GetString(target), "\": trying to rename a volume or ", "move a directory into itself", (char *) NULL); goto done; } else if (errno != EXDEV) { @@ -527,50 +546,138 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) /* * The rename failed because the move was across file systems. * Fall through to copy file and then remove original. Note that - * the low-level TclpRenameFile is allowed to implement - * cross-filesystem moves itself. + * the low-level Tcl_FSRenameFileProc in the filesystem is allowed + * to implement cross-filesystem moves itself, if it desires. + */ + } + + actualSource = source; + Tcl_IncrRefCount(actualSource); +#if 0 +#ifdef S_ISLNK + /* + * To add a flag to make 'copy' copy links instead of files, we could + * add a condition to ignore this 'if' here. + */ + if (copyFlag && S_ISLNK(sourceStatBuf.st_mode)) { + /* + * We want to copy files not links. Therefore we must follow the + * link. There are two purposes to this 'stat' call here. First + * we want to know if the linked-file/dir actually exists, and + * second, in the block of code which follows, some 20 lines + * down, we want to check if the thing is a file or directory. */ + if (Tcl_FSStat(source, &sourceStatBuf) != 0) { + /* Actual file doesn't exist */ + Tcl_AppendResult(interp, + "error copying \"", Tcl_GetString(source), + "\": the target of this link doesn't exist", + (char *) NULL); + goto done; + } else { + int counter = 0; + while (1) { + Tcl_Obj *path = Tcl_FSLink(actualSource, NULL, 0); + if (path == NULL) { + break; + } + Tcl_DecrRefCount(actualSource); + actualSource = path; + counter++; + /* Arbitrary limit of 20 links to follow */ + if (counter > 20) { + /* Too many links */ + Tcl_SetErrno(EMLINK); + errfile = source; + goto done; + } + } + /* Now 'actualSource' is the correct file */ + } } +#endif +#endif if (S_ISDIR(sourceStatBuf.st_mode)) { - result = TclpCopyDirectory(sourceName, targetName, &errorBuffer); + result = Tcl_FSCopyDirectory(actualSource, target, &errorBuffer); if (result != TCL_OK) { - errfile = Tcl_DStringValue(&errorBuffer); - if (strcmp(errfile, sourceName) == 0) { - errfile = source; - } else if (strcmp(errfile, targetName) == 0) { - errfile = target; + if (errno == EXDEV) { + /* + * The copy failed because we're trying to do a + * cross-filesystem copy. We do this through our Tcl + * library. + */ + Tcl_SavedResult savedResult; + Tcl_Obj *copyCommand = Tcl_NewListObj(0,NULL); + Tcl_IncrRefCount(copyCommand); + Tcl_ListObjAppendElement(interp, copyCommand, + Tcl_NewStringObj("::tcl::CopyDirectory",-1)); + if (copyFlag) { + Tcl_ListObjAppendElement(interp, copyCommand, + Tcl_NewStringObj("copying",-1)); + } else { + Tcl_ListObjAppendElement(interp, copyCommand, + Tcl_NewStringObj("renaming",-1)); + } + Tcl_ListObjAppendElement(interp, copyCommand, source); + Tcl_ListObjAppendElement(interp, copyCommand, target); + Tcl_SaveResult(interp, &savedResult); + result = Tcl_EvalObjEx(interp, copyCommand, + TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); + Tcl_DecrRefCount(copyCommand); + if (result != TCL_OK) { + /* + * There was an error in the Tcl-level copy. + * We will pass on the Tcl error message and + * can ensure this by setting errfile to NULL + */ + Tcl_DiscardResult(&savedResult); + errfile = NULL; + } else { + /* The copy was successful */ + Tcl_RestoreResult(interp, &savedResult); + } + } else { + errfile = errorBuffer; + if (Tcl_FSEqualPaths(errfile, source)) { + errfile = source; + } else if (Tcl_FSEqualPaths(errfile, target)) { + errfile = target; + } } } } else { - result = TclpCopyFile(sourceName, targetName); + result = Tcl_FSCopyFile(actualSource, target); + if ((result != TCL_OK) && (errno == EXDEV)) { + result = TclCrossFilesystemCopy(interp, source, target); + } if (result != TCL_OK) { - /* - * Well, there really shouldn't be a problem with source, - * because up there we checked to see if it was ok to copy it. + /* + * We could examine 'errno' to double-check if the problem + * was with the target, but we checked the source above, + * so it should be quite clear */ - errfile = target; } } if ((copyFlag == 0) && (result == TCL_OK)) { if (S_ISDIR(sourceStatBuf.st_mode)) { - result = TclpRemoveDirectory(sourceName, 1, &errorBuffer); + result = Tcl_FSRemoveDirectory(source, 1, &errorBuffer); if (result != TCL_OK) { - errfile = Tcl_DStringValue(&errorBuffer); - if (strcmp(errfile, sourceName) == 0) { + if (Tcl_FSEqualPaths(errfile, source) == 0) { errfile = source; } } } else { - result = TclpDeleteFile(sourceName); + result = Tcl_FSDeleteFile(source); if (result != TCL_OK) { errfile = source; } } if (result != TCL_OK) { - Tcl_AppendResult(interp, "can't unlink \"", errfile, "\": ", - Tcl_PosixError(interp), (char *) NULL); + Tcl_AppendResult(interp, "can't unlink \"", + Tcl_GetString(errfile), "\": ", + Tcl_PosixError(interp), (char *) NULL); errfile = NULL; } } @@ -579,19 +686,24 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) if (errfile != NULL) { Tcl_AppendResult(interp, ((copyFlag) ? "error copying \"" : "error renaming \""), - source, (char *) NULL); + Tcl_GetString(source), (char *) NULL); if (errfile != source) { - Tcl_AppendResult(interp, "\" to \"", target, (char *) NULL); + Tcl_AppendResult(interp, "\" to \"", Tcl_GetString(target), + (char *) NULL); if (errfile != target) { - Tcl_AppendResult(interp, "\": \"", errfile, (char *) NULL); + Tcl_AppendResult(interp, "\": \"", Tcl_GetString(errfile), + (char *) NULL); } } Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp), (char *) NULL); } - Tcl_DStringFree(&errorBuffer); - Tcl_DStringFree(&sourcePath); - Tcl_DStringFree(&targetPath); + if (errorBuffer != NULL) { + Tcl_DecrRefCount(errorBuffer); + } + if (actualSource != NULL) { + Tcl_DecrRefCount(actualSource); + } return result; } @@ -616,10 +728,10 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) */ static int -FileForceOption(interp, argc, argv, forcePtr) +FileForceOption(interp, objc, objv, forcePtr) Tcl_Interp *interp; /* Interp, for error return. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. First command line + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument strings. First command line * option, if it exists, begins at 0. */ int *forcePtr; /* If the "-force" was specified, *forcePtr * is filled with 1, otherwise with 0. */ @@ -627,17 +739,17 @@ FileForceOption(interp, argc, argv, forcePtr) int force, i; force = 0; - for (i = 0; i < argc; i++) { - if (argv[i][0] != '-') { + for (i = 0; i < objc; i++) { + if (Tcl_GetString(objv[i])[0] != '-') { break; } - if (strcmp(argv[i], "-force") == 0) { + if (strcmp(Tcl_GetString(objv[i]), "-force") == 0) { force = 1; - } else if (strcmp(argv[i], "--") == 0) { + } else if (strcmp(Tcl_GetString(objv[i]), "--") == 0) { i++; break; } else { - Tcl_AppendResult(interp, "bad option \"", argv[i], + Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[i]), "\": should be -force or --", (char *)NULL); return -1; } @@ -656,10 +768,9 @@ FileForceOption(interp, argc, argv, forcePtr) * if path is the root directory, returns no characters. * * Results: - * Appends the string that represents the basename to the end of - * the specified initialized DString, returning a pointer to the - * resulting string. If there is an error, an error message is left - * in interp, NULL is returned, and the Tcl_DString is unmodified. + * Returns the string object that represents the basename. If there + * is an error, an error message is left in interp, and NULL is + * returned. * * Side effects: * None. @@ -667,47 +778,45 @@ FileForceOption(interp, argc, argv, forcePtr) *--------------------------------------------------------------------------- */ -static char * -FileBasename(interp, path, bufferPtr) +static Tcl_Obj * +FileBasename(interp, pathPtr) Tcl_Interp *interp; /* Interp, for error return. */ - char *path; /* Path whose basename to extract. */ - Tcl_DString *bufferPtr; /* Initialized DString that receives - * basename. */ + Tcl_Obj *pathPtr; /* Path whose basename to extract. */ { - int argc; - char **argv; + int objc; + Tcl_Obj *splitPtr; + Tcl_Obj *resultPtr = NULL; - Tcl_SplitPath(path, &argc, &argv); - if (argc == 0) { - Tcl_DStringInit(bufferPtr); - } else { - if ((argc == 1) && (*path == '~')) { - Tcl_DString buffer; - - ckfree((char *) argv); - path = Tcl_TranslateFileName(interp, path, &buffer); - if (path == NULL) { + splitPtr = Tcl_FSSplitPath(pathPtr, &objc); + + if (objc != 0) { + if ((objc == 1) && (*Tcl_GetString(pathPtr) == '~')) { + Tcl_DecrRefCount(splitPtr); + if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) { return NULL; } - Tcl_SplitPath(path, &argc, &argv); - Tcl_DStringFree(&buffer); + splitPtr = Tcl_FSSplitPath(pathPtr, &objc); } - Tcl_DStringInit(bufferPtr); /* * Return the last component, unless it is the only component, and it * is the root of an absolute path. */ - if (argc > 0) { - if ((argc > 1) - || (Tcl_GetPathType(argv[0]) == TCL_PATH_RELATIVE)) { - Tcl_DStringAppend(bufferPtr, argv[argc - 1], -1); + if (objc > 0) { + Tcl_ListObjIndex(NULL, splitPtr, objc-1, &resultPtr); + if ((objc == 1) && + (Tcl_FSGetPathType(resultPtr) != TCL_PATH_RELATIVE)) { + resultPtr = NULL; } } } - ckfree((char *) argv); - return Tcl_DStringValue(bufferPtr); + if (resultPtr == NULL) { + resultPtr = Tcl_NewObj(); + } + Tcl_IncrRefCount(resultPtr); + Tcl_DecrRefCount(splitPtr); + return resultPtr; } /* @@ -715,15 +824,15 @@ FileBasename(interp, path, bufferPtr) * * TclFileAttrsCmd -- * - * Sets or gets the platform-specific attributes of a file. The objc-objv - * points to the file name with the rest of the command line following. - * This routine uses platform-specific tables of option strings - * and callbacks. The callback to get the attributes take three - * parameters: + * Sets or gets the platform-specific attributes of a file. The + * objc-objv points to the file name with the rest of the command + * line following. This routine uses platform-specific tables of + * option strings and callbacks. The callback to get the + * attributes take three parameters: * Tcl_Interp *interp; The interp to report errors with. * Since this is an object-based API, - * the object form of the result should be - * used. + * the object form of the result should + * be used. * CONST char *fileName; This is extracted using * Tcl_TranslateFileName. * TclObj **attrObjPtrPtr; A new object to hold the attribute @@ -751,46 +860,80 @@ TclFileAttrsCmd(interp, objc, objv) int objc; /* Number of command line arguments. */ Tcl_Obj *CONST objv[]; /* The command line objects. */ { - char *fileName; int result; - Tcl_DString buffer; - + CONST char ** attributeStrings; + Tcl_Obj* objStrings = NULL; + int numObjStrings = -1; + Tcl_Obj *filePtr; + if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "name ?option? ?value? ?option value ...?"); return TCL_ERROR; } - fileName = Tcl_GetString(objv[2]); - fileName = Tcl_TranslateFileName(interp, fileName, &buffer); - if (fileName == NULL) { + filePtr = objv[2]; + if (Tcl_FSConvertToPathType(interp, filePtr) != TCL_OK) { return TCL_ERROR; } objc -= 3; objv += 3; result = TCL_ERROR; - + Tcl_SetErrno(0); + attributeStrings = Tcl_FSFileAttrStrings(filePtr, &objStrings); + if (attributeStrings == NULL) { + int index; + Tcl_Obj *objPtr; + if (objStrings == NULL) { + if (Tcl_GetErrno() != 0) { + /* + * There was an error, probably that the filePtr is + * not accepted by any filesystem + */ + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "could not read \"", Tcl_GetString(filePtr), + "\": ", Tcl_PosixError(interp), + (char *) NULL); + return TCL_ERROR; + } + goto end; + } + /* We own the object now */ + Tcl_IncrRefCount(objStrings); + /* Use objStrings as a list object */ + if (Tcl_ListObjLength(interp, objStrings, &numObjStrings) != TCL_OK) { + goto end; + } + attributeStrings = (CONST char **) + ckalloc ((1+numObjStrings) * sizeof(char*)); + for (index = 0; index < numObjStrings; index++) { + Tcl_ListObjIndex(interp, objStrings, index, &objPtr); + attributeStrings[index] = Tcl_GetString(objPtr); + } + attributeStrings[index] = NULL; + } if (objc == 0) { /* * Get all attributes. */ int index; - Tcl_Obj *listPtr, *objPtr; + Tcl_Obj *listPtr; listPtr = Tcl_NewListObj(0, NULL); - for (index = 0; tclpFileAttrStrings[index] != NULL; index++) { - objPtr = Tcl_NewStringObj(tclpFileAttrStrings[index], -1); + for (index = 0; attributeStrings[index] != NULL; index++) { + Tcl_Obj *objPtr = Tcl_NewStringObj(attributeStrings[index], -1); Tcl_ListObjAppendElement(interp, listPtr, objPtr); - - if ((*tclpFileAttrProcs[index].getProc)(interp, index, fileName, - &objPtr) != TCL_OK) { + /* We now forget about objPtr, it is in the list */ + objPtr = NULL; + if (Tcl_FSFileAttrsGet(interp, index, filePtr, + &objPtr) != TCL_OK) { Tcl_DecrRefCount(listPtr); goto end; } Tcl_ListObjAppendElement(interp, listPtr, objPtr); - } + } Tcl_SetObjResult(interp, listPtr); } else if (objc == 1) { /* @@ -798,13 +941,20 @@ TclFileAttrsCmd(interp, objc, objv) */ int index; - Tcl_Obj *objPtr; - - if (Tcl_GetIndexFromObj(interp, objv[0], tclpFileAttrStrings, + Tcl_Obj *objPtr = NULL; + + if (numObjStrings == 0) { + Tcl_AppendResult(interp, "bad option \"", + Tcl_GetString(objv[0]), "\", there are no file attributes" + " in this filesystem.", (char *) NULL); + goto end; + } + + if (Tcl_GetIndexFromObj(interp, objv[0], attributeStrings, "option", 0, &index) != TCL_OK) { goto end; - } - if ((*tclpFileAttrProcs[index].getProc)(interp, index, fileName, + } + if (Tcl_FSFileAttrsGet(interp, index, filePtr, &objPtr) != TCL_OK) { goto end; } @@ -816,8 +966,15 @@ TclFileAttrsCmd(interp, objc, objv) int i, index; + if (numObjStrings == 0) { + Tcl_AppendResult(interp, "bad option \"", + Tcl_GetString(objv[0]), "\", there are no file attributes" + " in this filesystem.", (char *) NULL); + goto end; + } + for (i = 0; i < objc ; i += 2) { - if (Tcl_GetIndexFromObj(interp, objv[i], tclpFileAttrStrings, + if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings, "option", 0, &index) != TCL_OK) { goto end; } @@ -827,7 +984,7 @@ TclFileAttrsCmd(interp, objc, objv) (char *) NULL); goto end; } - if ((*tclpFileAttrProcs[index].setProc)(interp, index, fileName, + if (Tcl_FSFileAttrsSet(interp, index, filePtr, objv[i + 1]) != TCL_OK) { goto end; } @@ -836,6 +993,16 @@ TclFileAttrsCmd(interp, objc, objv) result = TCL_OK; end: - Tcl_DStringFree(&buffer); + if (numObjStrings != -1) { + /* Free up the array we allocated */ + ckfree((char*)attributeStrings); + /* + * We don't need this object that was passed to us + * any more. + */ + if (objStrings != NULL) { + Tcl_DecrRefCount(objStrings); + } + } return result; } diff --git a/tcl/generic/tclFileName.c b/tcl/generic/tclFileName.c index 32e9495c6df..431dad49047 100644 --- a/tcl/generic/tclFileName.c +++ b/tcl/generic/tclFileName.c @@ -17,18 +17,27 @@ #include "tclPort.h" #include "tclRegexp.h" -/* - * The following regular expression matches the root portion of a Windows - * absolute or volume relative path. It will match both UNC and drive relative - * paths. +/* + * This define is used to activate Tcl's interpretation of Unix-style + * paths (containing forward slashes, '.' and '..') on MacOS. A + * side-effect of this is that some paths become ambiguous. */ +#define MAC_UNDERSTANDS_UNIX_PATHS -#define WIN_ROOT_PATTERN "^(([a-zA-Z]:)|[/\\\\][/\\\\]+([^/\\\\]+)[/\\\\]+([^/\\\\]+)|([/\\\\]))([/\\\\])*" - +#ifdef MAC_UNDERSTANDS_UNIX_PATHS /* * The following regular expression matches the root portion of a Macintosh * absolute path. It will match degenerate Unix-style paths, tilde paths, - * Unix-style paths, and Mac paths. + * Unix-style paths, and Mac paths. The various subexpressions in this + * can be summarised as follows: ^(/..|~user/unix|~user:mac|/unix|mac:dir). + * The subexpression indices which match the root portions, are as follows: + * + * degenerate unix-style: 2 + * unix-tilde: 5 + * mac-tilde: 7 + * unix-style: 9 (or 10 to cut off the irrelevant header). + * mac: 12 + * */ #define MAC_ROOT_PATTERN "^((/+([.][.]?/+)*([.][.]?)?)|(~[^:/]*)(/[^:]*)?|(~[^:]*)(:.*)?|/+([.][.]?/+)*([^:/]+)(/[^:]*)?|([^:]+):.*)$" @@ -45,6 +54,11 @@ typedef struct ThreadSpecificData { static Tcl_ThreadDataKey dataKey; +static void FileNameCleanup _ANSI_ARGS_((ClientData clientData)); +static void FileNameInit _ANSI_ARGS_((void)); + +#endif + /* * The following variable is set in the TclPlatformInit call to one * of: TCL_PLATFORM_UNIX, TCL_PLATFORM_MAC, or TCL_PLATFORM_WINDOWS. @@ -53,32 +67,20 @@ static Tcl_ThreadDataKey dataKey; TclPlatformType tclPlatform = TCL_PLATFORM_UNIX; /* - * The "globParameters" argument of the globbing functions is an - * or'ed combination of the following values: - */ - -#define GLOBMODE_NO_COMPLAIN 1 -#define GLOBMODE_JOIN 2 -#define GLOBMODE_DIR 4 - -/* * Prototypes for local procedures defined in this file: */ -static char * DoTildeSubst _ANSI_ARGS_((Tcl_Interp *interp, +static CONST char * DoTildeSubst _ANSI_ARGS_((Tcl_Interp *interp, CONST char *user, Tcl_DString *resultPtr)); static CONST char * ExtractWinRoot _ANSI_ARGS_((CONST char *path, - Tcl_DString *resultPtr, int offset, Tcl_PathType *typePtr)); -static void FileNameCleanup _ANSI_ARGS_((ClientData clientData)); -static void FileNameInit _ANSI_ARGS_((void)); + Tcl_DString *resultPtr, int offset, + Tcl_PathType *typePtr)); static int SkipToChar _ANSI_ARGS_((char **stringPtr, char *match)); -static char * SplitMacPath _ANSI_ARGS_((CONST char *path, - Tcl_DString *bufPtr)); -static char * SplitWinPath _ANSI_ARGS_((CONST char *path, - Tcl_DString *bufPtr)); -static char * SplitUnixPath _ANSI_ARGS_((CONST char *path, - Tcl_DString *bufPtr)); +static Tcl_Obj* SplitMacPath _ANSI_ARGS_((CONST char *path)); +static Tcl_Obj* SplitWinPath _ANSI_ARGS_((CONST char *path)); +static Tcl_Obj* SplitUnixPath _ANSI_ARGS_((CONST char *path)); +#ifdef MAC_UNDERSTANDS_UNIX_PATHS /* *---------------------------------------------------------------------- @@ -132,6 +134,7 @@ FileNameCleanup(clientData) Tcl_DecrRefCount(tsdPtr->macRootPatternPtr); tsdPtr->initialized = 0; } +#endif /* *---------------------------------------------------------------------- @@ -161,22 +164,19 @@ ExtractWinRoot(path, resultPtr, offset, typePtr) * stored. */ Tcl_PathType *typePtr; /* Where to store pathType result */ { - FileNameInit(); - - if (path[0] == '/' || path[0] == '\\') { /* Might be a UNC or Vol-Relative path */ - char *host, *share, *tail; + CONST char *host, *share, *tail; int hlen, slen; if (path[1] != '/' && path[1] != '\\') { Tcl_DStringSetLength(resultPtr, offset); *typePtr = TCL_PATH_VOLUME_RELATIVE; Tcl_DStringAppend(resultPtr, "/", 1); return &path[1]; - } - host = (char *)&path[2]; + } + host = &path[2]; - /* Skip seperators */ + /* Skip separators */ while (host[0] == '/' || host[0] == '\\') host++; for (hlen = 0; host[hlen];hlen++) { @@ -184,6 +184,18 @@ ExtractWinRoot(path, resultPtr, offset, typePtr) break; } if (host[hlen] == 0 || host[hlen+1] == 0) { + /* + * The path given is simply of the form + * '/foo', '//foo', '/////foo' or the same + * with backslashes. If there is exactly + * one leading '/' the path is volume relative + * (see filename man page). If there are more + * than one, we are simply assuming they + * are superfluous and we trim them away. + * (An alternative interpretation would + * be that it is a host name, but we have + * been documented that that is not the case). + */ *typePtr = TCL_PATH_VOLUME_RELATIVE; Tcl_DStringAppend(resultPtr, "/", 1); return &path[2]; @@ -191,7 +203,7 @@ ExtractWinRoot(path, resultPtr, offset, typePtr) Tcl_DStringSetLength(resultPtr, offset); share = &host[hlen]; - /* Skip seperators */ + /* Skip separators */ while (share[0] == '/' || share[0] == '\\') share++; for (slen = 0; share[slen];slen++) { @@ -205,12 +217,12 @@ ExtractWinRoot(path, resultPtr, offset, typePtr) tail = &share[slen]; - /* Skip seperators */ + /* Skip separators */ while (tail[0] == '/' || tail[0] == '\\') tail++; *typePtr = TCL_PATH_ABSOLUTE; return tail; - } else if (path[1] == ':') { + } else if (*path && path[1] == ':') { /* Might be a drive sep */ Tcl_DStringSetLength(resultPtr, offset); @@ -218,17 +230,17 @@ ExtractWinRoot(path, resultPtr, offset, typePtr) *typePtr = TCL_PATH_VOLUME_RELATIVE; Tcl_DStringAppend(resultPtr, path, 2); return &path[2]; - } else { + } else { char *tail = (char*)&path[3]; - /* Skip seperators */ - while (tail[0] == '/' || tail[0] == '\\') tail++; + /* Skip separators */ + while (*tail && (tail[0] == '/' || tail[0] == '\\')) tail++; *typePtr = TCL_PATH_ABSOLUTE; Tcl_DStringAppend(resultPtr, path, 2); - Tcl_DStringAppend(resultPtr, "/", 1); + Tcl_DStringAppend(resultPtr, "/", 1); - return tail; + return tail; } } else { *typePtr = TCL_PATH_RELATIVE; @@ -243,6 +255,10 @@ ExtractWinRoot(path, resultPtr, offset, typePtr) * * Determines whether a given path is relative to the current * directory, relative to the current volume, or absolute. + * + * The objectified Tcl_FSGetPathType should be used in + * preference to this function (as you can see below, this + * is just a wrapper around that other function). * * Results: * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or @@ -256,65 +272,258 @@ ExtractWinRoot(path, resultPtr, offset, typePtr) Tcl_PathType Tcl_GetPathType(path) - char *path; + CONST char *path; { - ThreadSpecificData *tsdPtr; - Tcl_PathType type = TCL_PATH_ABSOLUTE; - Tcl_RegExp re; - - switch (tclPlatform) { - case TCL_PLATFORM_UNIX: - /* - * Paths that begin with / or ~ are absolute. - */ + Tcl_PathType type; + Tcl_Obj *tempObj = Tcl_NewStringObj(path,-1); + Tcl_IncrRefCount(tempObj); + type = Tcl_FSGetPathType(tempObj); + Tcl_DecrRefCount(tempObj); + return type; +} + +/* + *---------------------------------------------------------------------- + * + * TclpGetNativePathType -- + * + * Determines whether a given path is relative to the current + * directory, relative to the current volume, or absolute, but + * ONLY FOR THE NATIVE FILESYSTEM. This function is called from + * tclIOUtil.c (but needs to be here due to its dependence on + * static variables/functions in this file). The exported + * function Tcl_FSGetPathType should be used by extensions. + * + * Results: + * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or + * TCL_PATH_VOLUME_RELATIVE. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - if ((path[0] != '/') && (path[0] != '~')) { - type = TCL_PATH_RELATIVE; +Tcl_PathType +TclpGetNativePathType(pathObjPtr, driveNameLengthPtr, driveNameRef) + Tcl_Obj *pathObjPtr; + int *driveNameLengthPtr; + Tcl_Obj **driveNameRef; +{ + Tcl_PathType type = TCL_PATH_ABSOLUTE; + int pathLen; + char *path = Tcl_GetStringFromObj(pathObjPtr, &pathLen); + + if (path[0] == '~') { + /* + * This case is common to all platforms. + * Paths that begin with ~ are absolute. + */ + if (driveNameLengthPtr != NULL) { + char *end = path + 1; + while ((*end != '\0') && (*end != '/')) { + end++; } - break; - - case TCL_PLATFORM_MAC: - if (path[0] == ':') { - type = TCL_PATH_RELATIVE; - } else if (path[0] != '~') { - tsdPtr = TCL_TSD_INIT(&dataKey); - + *driveNameLengthPtr = end - path; + } + } else { + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: { + char *origPath = path; + /* - * Since we have eliminated the easy cases, use the - * root pattern to look for the other types. + * Paths that begin with / are absolute. */ - FileNameInit(); - re = Tcl_GetRegExpFromObj(NULL, tsdPtr->macRootPatternPtr, - REG_ADVANCED); - - if (!Tcl_RegExpExec(NULL, re, path, path)) { +#ifdef __QNX__ + /* + * Check for QNX //<node id> prefix + */ + if (*path && (pathLen > 3) && (path[0] == '/') + && (path[1] == '/') && isdigit(UCHAR(path[2]))) { + path += 3; + while (isdigit(UCHAR(*path))) { + ++path; + } + } +#endif + if (path[0] == '/') { + if (driveNameLengthPtr != NULL) { + /* + * We need this addition in case the QNX code + * was used + */ + *driveNameLengthPtr = (1 + path - origPath); + } + } else { + type = TCL_PATH_RELATIVE; + } + break; + } + case TCL_PLATFORM_MAC: + if (path[0] == ':') { type = TCL_PATH_RELATIVE; } else { - char *unixRoot, *dummy; +#ifdef MAC_UNDERSTANDS_UNIX_PATHS + ThreadSpecificData *tsdPtr; + Tcl_RegExp re; - Tcl_RegExpRange(re, 2, &unixRoot, &dummy); - if (unixRoot) { + tsdPtr = TCL_TSD_INIT(&dataKey); + + /* + * Since we have eliminated the easy cases, use the + * root pattern to look for the other types. + */ + + FileNameInit(); + re = Tcl_GetRegExpFromObj(NULL, tsdPtr->macRootPatternPtr, + REG_ADVANCED); + + if (!Tcl_RegExpExec(NULL, re, path, path)) { + type = TCL_PATH_RELATIVE; + } else { + CONST char *root, *end; + Tcl_RegExpRange(re, 2, &root, &end); + if (root != NULL) { + type = TCL_PATH_RELATIVE; + } else { + if (driveNameLengthPtr != NULL) { + Tcl_RegExpRange(re, 0, &root, &end); + *driveNameLengthPtr = end - root; + } + if (driveNameRef != NULL) { + if (*root == '/') { + char *c; + int gotColon = 0; + *driveNameRef = Tcl_NewStringObj(root + 1, + end - root -1); + c = Tcl_GetString(*driveNameRef); + while (*c != '\0') { + if (*c == '/') { + gotColon++; + *c = ':'; + } + c++; + } + /* + * If there is no colon, we have just a + * volume name so we must add a colon so + * it is an absolute path. + */ + if (gotColon == 0) { + Tcl_AppendToObj(*driveNameRef, ":", 1); + } else if ((gotColon > 1) && + (*(c-1) == ':')) { + /* We have an extra colon */ + Tcl_SetObjLength(*driveNameRef, + c - Tcl_GetString(*driveNameRef) - 1); + } + } + } + } + } +#else + if (path[0] == '~') { + } else if (path[0] == ':') { type = TCL_PATH_RELATIVE; + } else { + char *colonPos = strchr(path,':'); + if (colonPos == NULL) { + type = TCL_PATH_RELATIVE; + } else { + } } + if (type == TCL_PATH_ABSOLUTE) { + if (driveNameLengthPtr != NULL) { + *driveNameLengthPtr = strlen(path); + } + } +#endif } - } - break; - - case TCL_PLATFORM_WINDOWS: - if (path[0] != '~') { + break; + + case TCL_PLATFORM_WINDOWS: { Tcl_DString ds; - + CONST char *rootEnd; + Tcl_DStringInit(&ds); - (VOID)ExtractWinRoot(path, &ds, 0, &type); + rootEnd = ExtractWinRoot(path, &ds, 0, &type); + if ((rootEnd != path) && (driveNameLengthPtr != NULL)) { + *driveNameLengthPtr = rootEnd - path; + if (driveNameRef != NULL) { + *driveNameRef = Tcl_NewStringObj(Tcl_DStringValue(&ds), + Tcl_DStringLength(&ds)); + Tcl_IncrRefCount(*driveNameRef); + } + } Tcl_DStringFree(&ds); + break; } - break; + } } return type; } /* + *--------------------------------------------------------------------------- + * + * TclpNativeSplitPath -- + * + * 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. + * + * Note this function currently calls the older Split(Plat)Path + * functions, which require more memory allocation than is + * desirable. + * + * 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. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +Tcl_Obj* +TclpNativeSplitPath(pathPtr, lenPtr) + Tcl_Obj *pathPtr; /* Path to split. */ + int *lenPtr; /* int to store number of path elements. */ +{ + Tcl_Obj *resultPtr = NULL; /* Needed only to prevent gcc warnings. */ + + /* + * Perform platform specific splitting. + */ + + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: + resultPtr = SplitUnixPath(Tcl_GetString(pathPtr)); + break; + + case TCL_PLATFORM_WINDOWS: + resultPtr = SplitWinPath(Tcl_GetString(pathPtr)); + break; + + case TCL_PLATFORM_MAC: + resultPtr = SplitMacPath(Tcl_GetString(pathPtr)); + break; + } + + /* + * Compute the number of elements in the result. + */ + + if (lenPtr != NULL) { + Tcl_ListObjLength(NULL, resultPtr, lenPtr); + } + return resultPtr; +} + +/* *---------------------------------------------------------------------- * * Tcl_SplitPath -- @@ -345,75 +554,70 @@ Tcl_SplitPath(path, argcPtr, argvPtr) CONST char *path; /* Pointer to string containing a path. */ int *argcPtr; /* Pointer to location to fill in with * the number of elements in the path. */ - char ***argvPtr; /* Pointer to place to store pointer to array + CONST char ***argvPtr; /* Pointer to place to store pointer to array * of pointers to path elements. */ { - int i, size; - char *p; - Tcl_DString buffer; - - Tcl_DStringInit(&buffer); + Tcl_Obj *resultPtr = NULL; /* Needed only to prevent gcc warnings. */ + Tcl_Obj *tmpPtr, *eltPtr; + int i, size, len; + char *p, *str; /* - * Perform platform specific splitting. These routines will leave the - * result in the specified buffer. Individual elements are terminated - * with a null character. + * Perform the splitting, using objectified, vfs-aware code. */ - p = NULL; /* Needed only to prevent gcc warnings. */ - switch (tclPlatform) { - case TCL_PLATFORM_UNIX: - p = SplitUnixPath(path, &buffer); - break; - - case TCL_PLATFORM_WINDOWS: - p = SplitWinPath(path, &buffer); - break; - - case TCL_PLATFORM_MAC: - p = SplitMacPath(path, &buffer); - break; - } - - /* - * Compute the number of elements in the result. - */ + tmpPtr = Tcl_NewStringObj(path, -1); + Tcl_IncrRefCount(tmpPtr); + resultPtr = Tcl_FSSplitPath(tmpPtr, argcPtr); + Tcl_DecrRefCount(tmpPtr); - size = Tcl_DStringLength(&buffer); - *argcPtr = 0; - for (i = 0; i < size; i++) { - if (p[i] == '\0') { - (*argcPtr)++; - } + /* Calculate space required for the result */ + + size = 1; + for (i = 0; i < *argcPtr; i++) { + Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr); + Tcl_GetStringFromObj(eltPtr, &len); + size += len + 1; } /* - * Allocate a buffer large enough to hold the contents of the - * DString plus the argv pointers and the terminating NULL pointer. + * Allocate a buffer large enough to hold the contents of all of + * the list plus the argv pointers and the terminating NULL pointer. */ - *argvPtr = (char **) ckalloc((unsigned) + *argvPtr = (CONST char **) ckalloc((unsigned) ((((*argcPtr) + 1) * sizeof(char *)) + size)); /* * Position p after the last argv pointer and copy the contents of - * the DString. + * the list in, piece by piece. */ p = (char *) &(*argvPtr)[(*argcPtr) + 1]; - memcpy((VOID *) p, (VOID *) Tcl_DStringValue(&buffer), (size_t) size); - + for (i = 0; i < *argcPtr; i++) { + Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr); + str = Tcl_GetStringFromObj(eltPtr, &len); + memcpy((VOID *) p, (VOID *) str, (size_t) len+1); + p += len+1; + } + /* * Now set up the argv pointers. */ + p = (char *) &(*argvPtr)[(*argcPtr) + 1]; + for (i = 0; i < *argcPtr; i++) { (*argvPtr)[i] = p; while ((*p++) != '\0') {} } (*argvPtr)[i] = NULL; - Tcl_DStringFree(&buffer); + /* + * Free the result ptr given to us by Tcl_FSSplitPath + */ + + Tcl_DecrRefCount(resultPtr); } /* @@ -421,12 +625,11 @@ Tcl_SplitPath(path, argcPtr, argvPtr) * * SplitUnixPath -- * - * This routine is used by Tcl_SplitPath to handle splitting + * This routine is used by Tcl_(FS)SplitPath to handle splitting * Unix paths. * * Results: - * Stores a null separated array of strings in the specified - * Tcl_DString. + * Returns a newly allocated Tcl list object. * * Side effects: * None. @@ -434,13 +637,13 @@ Tcl_SplitPath(path, argcPtr, argvPtr) *---------------------------------------------------------------------- */ -static char * -SplitUnixPath(path, bufPtr) +static Tcl_Obj* +SplitUnixPath(path) CONST char *path; /* Pointer to string containing a path. */ - Tcl_DString *bufPtr; /* Pointer to DString to use for the result. */ { int length; CONST char *p, *elementStart; + Tcl_Obj *result = Tcl_NewObj(); /* * Deal with the root directory as a special case. @@ -460,7 +663,7 @@ SplitUnixPath(path, bufPtr) #endif if (path[0] == '/') { - Tcl_DStringAppend(bufPtr, "/", 2); + Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj("/",1)); p = path+1; } else { p = path; @@ -478,30 +681,33 @@ SplitUnixPath(path, bufPtr) } length = p - elementStart; if (length > 0) { + Tcl_Obj *nextElt; if ((elementStart[0] == '~') && (elementStart != path)) { - Tcl_DStringAppend(bufPtr, "./", 2); + nextElt = Tcl_NewStringObj("./",2); + Tcl_AppendToObj(nextElt, elementStart, length); + } else { + nextElt = Tcl_NewStringObj(elementStart, length); } - Tcl_DStringAppend(bufPtr, elementStart, length); - Tcl_DStringAppend(bufPtr, "", 1); + Tcl_ListObjAppendElement(NULL, result, nextElt); } if (*p++ == '\0') { break; } } - return Tcl_DStringValue(bufPtr); + return result; } + /* *---------------------------------------------------------------------- * * SplitWinPath -- * - * This routine is used by Tcl_SplitPath to handle splitting + * This routine is used by Tcl_(FS)SplitPath to handle splitting * Windows paths. * * Results: - * Stores a null separated array of strings in the specified - * Tcl_DString. + * Returns a newly allocated Tcl list object. * * Side effects: * None. @@ -509,25 +715,30 @@ SplitUnixPath(path, bufPtr) *---------------------------------------------------------------------- */ -static char * -SplitWinPath(path, bufPtr) +static Tcl_Obj* +SplitWinPath(path) CONST char *path; /* Pointer to string containing a path. */ - Tcl_DString *bufPtr; /* Pointer to DString to use for the result. */ { int length; CONST char *p, *elementStart; Tcl_PathType type = TCL_PATH_ABSOLUTE; - - p = ExtractWinRoot(path, bufPtr, 0, &type); + Tcl_DString buf; + Tcl_Obj *result = Tcl_NewObj(); + Tcl_DStringInit(&buf); + + p = ExtractWinRoot(path, &buf, 0, &type); /* * Terminate the root portion, if we matched something. */ if (p != path) { - Tcl_DStringAppend(bufPtr, "", 1); + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(Tcl_DStringValue(&buf), + Tcl_DStringLength(&buf))); } - + Tcl_DStringFree(&buf); + /* * Split on slashes. Embedded elements that start with tilde will be * prefixed with "./" so they are not affected by tilde substitution. @@ -540,15 +751,18 @@ SplitWinPath(path, bufPtr) } length = p - elementStart; if (length > 0) { + Tcl_Obj *nextElt; if ((elementStart[0] == '~') && (elementStart != path)) { - Tcl_DStringAppend(bufPtr, "./", 2); + nextElt = Tcl_NewStringObj("./",2); + Tcl_AppendToObj(nextElt, elementStart, length); + } else { + nextElt = Tcl_NewStringObj(elementStart, length); } - Tcl_DStringAppend(bufPtr, elementStart, length); - Tcl_DStringAppend(bufPtr, "", 1); + Tcl_ListObjAppendElement(NULL, result, nextElt); } } while (*p++ != '\0'); - return Tcl_DStringValue(bufPtr); + return result; } /* @@ -556,11 +770,11 @@ SplitWinPath(path, bufPtr) * * SplitMacPath -- * - * This routine is used by Tcl_SplitPath to handle splitting + * This routine is used by Tcl_(FS)SplitPath to handle splitting * Macintosh paths. * * Results: - * Returns a newly allocated argv array. + * Returns a newly allocated Tcl list object. * * Side effects: * None. @@ -568,17 +782,23 @@ SplitWinPath(path, bufPtr) *---------------------------------------------------------------------- */ -static char * -SplitMacPath(path, bufPtr) +static Tcl_Obj* +SplitMacPath(path) CONST char *path; /* Pointer to string containing a path. */ - Tcl_DString *bufPtr; /* Pointer to DString to use for the result. */ { int isMac = 0; /* 1 if is Mac-style, 0 if Unix-style path. */ - int i, length; + int length; CONST char *p, *elementStart; + Tcl_Obj *result; +#ifdef MAC_UNDERSTANDS_UNIX_PATHS Tcl_RegExp re; + int i; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - +#endif + + result = Tcl_NewObj(); + +#ifdef MAC_UNDERSTANDS_UNIX_PATHS /* * Initialize the path name parser for Macintosh path names. */ @@ -594,7 +814,8 @@ SplitMacPath(path, bufPtr) re = Tcl_GetRegExpFromObj(NULL, tsdPtr->macRootPatternPtr, REG_ADVANCED); if (Tcl_RegExpExec(NULL, re, path, path) == 1) { - char *start, *end; + CONST char *start, *end; + Tcl_Obj *nextElt; /* * Treat degenerate absolute paths like / and /../.. as @@ -603,10 +824,11 @@ SplitMacPath(path, bufPtr) Tcl_RegExpRange(re, 2, &start, &end); if (start) { - Tcl_DStringAppend(bufPtr, ":", 1); + Tcl_Obj *elt = Tcl_NewStringObj(":", 1); Tcl_RegExpRange(re, 0, &start, &end); - Tcl_DStringAppend(bufPtr, path, end - start + 1); - return Tcl_DStringValue(bufPtr); + Tcl_AppendToObj(elt, path, end - start); + Tcl_ListObjAppendElement(NULL, result, elt); + return result; } Tcl_RegExpRange(re, 5, &start, &end); @@ -629,7 +851,6 @@ SplitMacPath(path, bufPtr) } else { Tcl_RegExpRange(re, 10, &start, &end); if (start) { - /* * Normal Unix style paths. */ @@ -639,7 +860,6 @@ SplitMacPath(path, bufPtr) } else { Tcl_RegExpRange(re, 12, &start, &end); if (start) { - /* * Normal Mac style paths. */ @@ -650,36 +870,70 @@ SplitMacPath(path, bufPtr) } } } - Tcl_RegExpRange(re, i, &start, &end); length = end - start; /* - * Append the element and terminate it with a : and a null. Note that - * we are forcing the DString to contain an extra null at the end. + * Append the element and terminate it with a : */ - Tcl_DStringAppend(bufPtr, start, length); - Tcl_DStringAppend(bufPtr, ":", 2); + nextElt = Tcl_NewStringObj(start, length); + Tcl_AppendToObj(nextElt, ":", 1); + Tcl_ListObjAppendElement(NULL, result, nextElt); p = end; } else { isMac = (strchr(path, ':') != NULL); p = path; } +#else + if ((path[0] != ':') && (path[0] == '~' || (strchr(path,':') != NULL))) { + CONST char *end; + Tcl_Obj *nextElt; + + isMac = 1; + + end = strchr(path,':'); + if (end == NULL) { + length = strlen(path); + } else { + length = end - path; + } + + /* + * Append the element and terminate it with a : + */ + + nextElt = Tcl_NewStringObj(path, length); + Tcl_AppendToObj(nextElt, ":", 1); + Tcl_ListObjAppendElement(NULL, result, nextElt); + p = path + length; + } else { + isMac = (strchr(path, ':') != NULL); + isMac = 1; + p = path; + } +#endif if (isMac) { /* * p is pointing at the first colon in the path. There * will always be one, since this is a Mac-style path. + * (This is no longer true if MAC_UNDERSTANDS_UNIX_PATHS + * is false, so we must check whether 'p' points to the + * end of the string.) */ - - elementStart = p++; + elementStart = p; + if (*p == ':') { + p++; + } + while ((p = strchr(p, ':')) != NULL) { length = p - elementStart; if (length == 1) { while (*p == ':') { - Tcl_DStringAppend(bufPtr, "::", 3); + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj("::", 2)); elementStart = p++; } } else { @@ -692,18 +946,25 @@ SplitMacPath(path, bufPtr) elementStart++; length--; } - Tcl_DStringAppend(bufPtr, elementStart, length); - Tcl_DStringAppend(bufPtr, "", 1); + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(elementStart, length)); elementStart = p++; } } - if (elementStart[1] != '\0' || elementStart == path) { - if ((elementStart[1] != '~') && (elementStart[1] != '\0') + if (elementStart[0] != ':') { + if (elementStart[0] != '\0') { + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(elementStart, -1)); + } + } else { + if (elementStart[1] != '\0' || elementStart == path) { + if ((elementStart[1] != '~') && (elementStart[1] != '\0') && (strchr(elementStart+1, '/') == NULL)) { elementStart++; + } + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(elementStart, -1)); } - Tcl_DStringAppend(bufPtr, elementStart, -1); - Tcl_DStringAppend(bufPtr, "", 1); } } else { @@ -719,16 +980,21 @@ SplitMacPath(path, bufPtr) length = p - elementStart; if (length > 0) { if ((length == 1) && (elementStart[0] == '.')) { - Tcl_DStringAppend(bufPtr, ":", 2); + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(":", 1)); } else if ((length == 2) && (elementStart[0] == '.') && (elementStart[1] == '.')) { - Tcl_DStringAppend(bufPtr, "::", 3); + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj("::", 2)); } else { + Tcl_Obj *nextElt; if (*elementStart == '~') { - Tcl_DStringAppend(bufPtr, ":", 1); + nextElt = Tcl_NewStringObj(":",1); + Tcl_AppendToObj(nextElt, elementStart, length); + } else { + nextElt = Tcl_NewStringObj(elementStart, length); } - Tcl_DStringAppend(bufPtr, elementStart, length); - Tcl_DStringAppend(bufPtr, "", 1); + Tcl_ListObjAppendElement(NULL, result, nextElt); } } if (*p++ == '\0') { @@ -736,239 +1002,301 @@ SplitMacPath(path, bufPtr) } } } - return Tcl_DStringValue(bufPtr); + return result; } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * Tcl_JoinPath -- + * Tcl_FSJoinToPath -- * - * Combine a list of paths in a platform specific manner. + * This function takes the given object, which should usually be a + * valid path or NULL, and joins onto it the array of paths + * segments given. * * Results: - * Appends the joined path to the end of the specified - * returning a pointer to the resulting string. Note that - * the Tcl_DString must already be initialized. + * Returns object with refCount of zero * * Side effects: - * Modifies the Tcl_DString. + * None. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ -char * -Tcl_JoinPath(argc, argv, resultPtr) - int argc; - char **argv; - Tcl_DString *resultPtr; /* Pointer to previously initialized DString. */ +Tcl_Obj* +Tcl_FSJoinToPath(basePtr, objc, objv) + Tcl_Obj *basePtr; + int objc; + Tcl_Obj *CONST objv[]; { - int oldLength, length, i, needsSep; - Tcl_DString buffer; - char c, *dest; - CONST char *p; - Tcl_PathType type = TCL_PATH_ABSOLUTE; - - Tcl_DStringInit(&buffer); - oldLength = Tcl_DStringLength(resultPtr); + int i; + Tcl_Obj *lobj, *ret; - switch (tclPlatform) { - case TCL_PLATFORM_UNIX: - for (i = 0; i < argc; i++) { - p = argv[i]; - /* - * If the path is absolute, reset the result buffer. - * Consume any duplicate leading slashes or a ./ in - * front of a tilde prefixed path that isn't at the - * beginning of the path. - */ + if (basePtr == NULL) { + lobj = Tcl_NewListObj(0, NULL); + } else { + lobj = Tcl_NewListObj(1, &basePtr); + } + + for (i = 0; i<objc;i++) { + Tcl_ListObjAppendElement(NULL, lobj, objv[i]); + } + ret = Tcl_FSJoinPath(lobj, -1); + Tcl_DecrRefCount(lobj); + return ret; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpNativeJoinPath -- + * + * 'prefix' is absolute, 'joining' is relative to prefix. + * + * Results: + * modifies prefix + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ -#ifdef __QNX__ - /* - * Check for QNX //<node id> prefix - */ - if (*p && (strlen(p) > 3) && (p[0] == '/') && (p[1] == '/') - && isdigit(UCHAR(p[2]))) { /* INTL: digit */ - p += 3; - while (isdigit(UCHAR(*p))) { /* INTL: digit */ - ++p; - } - } -#endif - if (*p == '/') { - Tcl_DStringSetLength(resultPtr, oldLength); - Tcl_DStringAppend(resultPtr, "/", 1); - while (*p == '/') { - p++; - } - } else if (*p == '~') { - Tcl_DStringSetLength(resultPtr, oldLength); - } else if ((Tcl_DStringLength(resultPtr) != oldLength) - && (p[0] == '.') && (p[1] == '/') - && (p[2] == '~')) { - p += 2; - } +void +TclpNativeJoinPath(prefix, joining) + Tcl_Obj *prefix; + char* joining; +{ + int length, needsSep; + char *dest, *p, *start; + + start = Tcl_GetStringFromObj(prefix, &length); - if (*p == '\0') { - continue; - } + /* + * Remove the ./ from tilde prefixed elements unless + * it is the first component. + */ + + p = joining; + + if (length != 0) { + if ((p[0] == '.') && (p[1] == '/') && (p[2] == '~')) { + p += 2; + } + } + + if (*p == '\0') { + return; + } - /* - * Append a separator if needed. - */ - length = Tcl_DStringLength(resultPtr); - if ((length != oldLength) - && (Tcl_DStringValue(resultPtr)[length-1] != '/')) { - Tcl_DStringAppend(resultPtr, "/", 1); - length++; - } + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: + /* + * Append a separator if needed. + */ - /* - * Append the element, eliminating duplicate and trailing - * slashes. - */ + if (length > 0 && (start[length-1] != '/')) { + Tcl_AppendToObj(prefix, "/", 1); + length++; + } + needsSep = 0; + + /* + * Append the element, eliminating duplicate and trailing + * slashes. + */ - Tcl_DStringSetLength(resultPtr, (int) (length + strlen(p))); - dest = Tcl_DStringValue(resultPtr) + length; - for (; *p != '\0'; p++) { - if (*p == '/') { - while (p[1] == '/') { - p++; - } - if (p[1] != '\0') { + Tcl_SetObjLength(prefix, length + (int) strlen(p)); + + dest = Tcl_GetString(prefix) + length; + for (; *p != '\0'; p++) { + if (*p == '/') { + while (p[1] == '/') { + p++; + } + if (p[1] != '\0') { + if (needsSep) { *dest++ = '/'; } - } else { - *dest++ = *p; } + } else { + *dest++ = *p; + needsSep = 1; } - length = dest - Tcl_DStringValue(resultPtr); - Tcl_DStringSetLength(resultPtr, length); } + length = dest - Tcl_GetString(prefix); + Tcl_SetObjLength(prefix, length); break; case TCL_PLATFORM_WINDOWS: /* - * Iterate over all of the components. If a component is - * absolute, then reset the result and start building the - * path from the current component on. + * Check to see if we need to append a separator. */ - for (i = 0; i < argc; i++) { - p = ExtractWinRoot(argv[i], resultPtr, oldLength, &type); - length = Tcl_DStringLength(resultPtr); - - /* - * If the pointer didn't move, then this is a relative path - * or a tilde prefixed path. - */ - - if (p == argv[i]) { - /* - * Remove the ./ from tilde prefixed elements unless - * it is the first component. - */ + if ((length > 0) && + (start[length-1] != '/') && (start[length-1] != ':')) { + Tcl_AppendToObj(prefix, "/", 1); + length++; + } + needsSep = 0; + + /* + * Append the element, eliminating duplicate and + * trailing slashes. + */ - if ((length != oldLength) - && (p[0] == '.') - && ((p[1] == '/') || (p[1] == '\\')) - && (p[2] == '~')) { - p += 2; - } else if (*p == '~') { - Tcl_DStringSetLength(resultPtr, oldLength); - length = oldLength; + Tcl_SetObjLength(prefix, length + (int) strlen(p)); + dest = Tcl_GetString(prefix) + length; + for (; *p != '\0'; p++) { + if ((*p == '/') || (*p == '\\')) { + while ((p[1] == '/') || (p[1] == '\\')) { + p++; } + if ((p[1] != '\0') && needsSep) { + *dest++ = '/'; + } + } else { + *dest++ = *p; + needsSep = 1; } + } + length = dest - Tcl_GetString(prefix); + Tcl_SetObjLength(prefix, length); + break; - if (*p != '\0') { - /* - * Check to see if we need to append a separator. - */ + case TCL_PLATFORM_MAC: { + int newLength; + + /* + * Sort out separators. We basically add the object we've + * been given, but we have to make sure that there is + * exactly one separator inbetween (unless the object we're + * adding contains multiple contiguous colons, all of which + * we must add). Also if an object is just ':' we don't + * bother to add it unless it's the very first element. + */ - - if (length != oldLength) { - c = Tcl_DStringValue(resultPtr)[length-1]; - if ((c != '/') && (c != ':')) { - Tcl_DStringAppend(resultPtr, "/", 1); - } +#ifdef MAC_UNDERSTANDS_UNIX_PATHS + int adjustedPath = 0; + if ((strchr(p, ':') == NULL) && (strchr(p, '/') != NULL)) { + char *start = p; + adjustedPath = 1; + while (*start != '\0') { + if (*start == '/') { + *start = ':'; } - - /* - * Append the element, eliminating duplicate and - * trailing slashes. - */ - - length = Tcl_DStringLength(resultPtr); - Tcl_DStringSetLength(resultPtr, (int) (length + strlen(p))); - dest = Tcl_DStringValue(resultPtr) + length; - for (; *p != '\0'; p++) { - if ((*p == '/') || (*p == '\\')) { - while ((p[1] == '/') || (p[1] == '\\')) { - p++; - } - if (p[1] != '\0') { - *dest++ = '/'; - } - } else { - *dest++ = *p; - } + start++; + } + } +#endif + if (length > 0) { + if ((p[0] == ':') && (p[1] == '\0')) { + return; + } + if (start[length-1] != ':') { + if (*p != '\0' && *p != ':') { + Tcl_AppendToObj(prefix, ":", 1); + length++; } - length = dest - Tcl_DStringValue(resultPtr); - Tcl_DStringSetLength(resultPtr, length); + } else if (*p == ':') { + p++; + } + } else { + if (*p != '\0' && *p != ':') { + Tcl_AppendToObj(prefix, ":", 1); + length++; } } - break; + + /* + * Append the element + */ - case TCL_PLATFORM_MAC: - needsSep = 1; - for (i = 0; i < argc; i++) { - Tcl_DStringSetLength(&buffer, 0); - p = SplitMacPath(argv[i], &buffer); - if ((*p != ':') && (*p != '\0') - && (strchr(p, ':') != NULL)) { - Tcl_DStringSetLength(resultPtr, oldLength); - length = strlen(p); - Tcl_DStringAppend(resultPtr, p, length); - needsSep = 0; - p += length+1; + newLength = strlen(p); + /* + * It may not be good to just do 'Tcl_AppendToObj(prefix, + * p, newLength)' because the object may contain duplicate + * colons which we want to get rid of. + */ + Tcl_AppendToObj(prefix, p, newLength); + + /* Remove spurious trailing single ':' */ + dest = Tcl_GetString(prefix) + length + newLength; + if (*(dest-1) == ':') { + if (dest-1 > Tcl_GetString(prefix)) { + if (*(dest-2) != ':') { + Tcl_SetObjLength(prefix, length + newLength -1); + } } - - /* - * Now append the rest of the path elements, skipping - * : unless it is the first element of the path, and - * watching out for :: et al. so we don't end up with - * too many colons in the result. - */ - - for (; *p != '\0'; p += length+1) { - if (p[0] == ':' && p[1] == '\0') { - if (Tcl_DStringLength(resultPtr) != oldLength) { - p++; - } else { - needsSep = 0; - } - } else { - c = p[1]; - if (*p == ':') { - if (!needsSep) { - p++; - } - } else { - if (needsSep) { - Tcl_DStringAppend(resultPtr, ":", 1); - } - } - needsSep = (c == ':') ? 0 : 1; + } +#ifdef MAC_UNDERSTANDS_UNIX_PATHS + /* Revert the path to what it was */ + if (adjustedPath) { + char *start = joining; + while (*start != '\0') { + if (*start == ':') { + *start = '/'; } - length = strlen(p); - Tcl_DStringAppend(resultPtr, p, length); + start++; } } +#endif break; - + } } - Tcl_DStringFree(&buffer); + return; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_JoinPath -- + * + * Combine a list of paths in a platform specific manner. The + * function 'Tcl_FSJoinPath' should be used in preference where + * possible. + * + * Results: + * Appends the joined path to the end of the specified + * Tcl_DString returning a pointer to the resulting string. Note + * that the Tcl_DString must already be initialized. + * + * Side effects: + * Modifies the Tcl_DString. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_JoinPath(argc, argv, resultPtr) + int argc; + CONST char * CONST *argv; + Tcl_DString *resultPtr; /* Pointer to previously initialized DString */ +{ + int i, len; + Tcl_Obj *listObj = Tcl_NewObj(); + Tcl_Obj *resultObj; + char *resultStr; + + /* Build the list of paths */ + for (i = 0; i < argc; i++) { + Tcl_ListObjAppendElement(NULL, listObj, + Tcl_NewStringObj(argv[i], -1)); + } + + /* Ask the objectified code to join the paths */ + Tcl_IncrRefCount(listObj); + resultObj = Tcl_FSJoinPath(listObj, argc); + Tcl_IncrRefCount(resultObj); + Tcl_DecrRefCount(listObj); + + /* Store the result */ + resultStr = Tcl_GetStringFromObj(resultObj, &len); + Tcl_DStringAppend(resultPtr, resultStr, len); + Tcl_DecrRefCount(resultObj); + + /* Return a pointer to the result */ return Tcl_DStringValue(resultPtr); } @@ -1002,51 +1330,25 @@ char * Tcl_TranslateFileName(interp, name, bufferPtr) Tcl_Interp *interp; /* Interpreter in which to store error * message (if necessary). */ - char *name; /* File name, which may begin with "~" (to + CONST char *name; /* File name, which may begin with "~" (to * indicate current user's home directory) or * "~<user>" (to indicate any user's home * directory). */ Tcl_DString *bufferPtr; /* Uninitialized or free DString filled * with name after tilde substitution. */ { - register char *p; - - /* - * Handle tilde substitutions, if needed. - */ - - if (name[0] == '~') { - int argc, length; - char **argv; - Tcl_DString temp; - - Tcl_SplitPath(name, &argc, (char ***) &argv); - - /* - * Strip the trailing ':' off of a Mac path before passing the user - * name to DoTildeSubst. - */ - - if (tclPlatform == TCL_PLATFORM_MAC) { - length = strlen(argv[0]); - argv[0][length-1] = '\0'; - } - - Tcl_DStringInit(&temp); - argv[0] = DoTildeSubst(interp, argv[0]+1, &temp); - if (argv[0] == NULL) { - Tcl_DStringFree(&temp); - ckfree((char *)argv); - return NULL; - } - Tcl_DStringInit(bufferPtr); - Tcl_JoinPath(argc, (char **) argv, bufferPtr); - Tcl_DStringFree(&temp); - ckfree((char*)argv); - } else { - Tcl_DStringInit(bufferPtr); - Tcl_JoinPath(1, (char **) &name, bufferPtr); + Tcl_Obj *path = Tcl_NewStringObj(name, -1); + CONST char *result; + + Tcl_IncrRefCount(path); + result = Tcl_FSGetTranslatedStringPath(interp, path); + if (result == NULL) { + Tcl_DecrRefCount(path); + return NULL; } + Tcl_DStringInit(bufferPtr); + Tcl_DStringAppend(bufferPtr, result, -1); + Tcl_DecrRefCount(path); /* * Convert forward slashes to backslashes in Windows paths because @@ -1054,6 +1356,7 @@ Tcl_TranslateFileName(interp, name, bufferPtr) */ if (tclPlatform == TCL_PLATFORM_WINDOWS) { + register char *p; for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) { if (*p == '/') { *p = '\\'; @@ -1098,11 +1401,15 @@ TclGetExtension(name) break; case TCL_PLATFORM_MAC: +#ifdef MAC_UNDERSTANDS_UNIX_PATHS if (strchr(name, ':') == NULL) { lastSep = strrchr(name, '/'); } else { lastSep = strrchr(name, ':'); } +#else + lastSep = strrchr(name, ':'); +#endif break; case TCL_PLATFORM_WINDOWS: @@ -1115,8 +1422,7 @@ TclGetExtension(name) break; } p = strrchr(name, '.'); - if ((p != NULL) && (lastSep != NULL) - && (lastSep > p)) { + if ((p != NULL) && (lastSep != NULL) && (lastSep > p)) { p = NULL; } @@ -1152,7 +1458,7 @@ TclGetExtension(name) *---------------------------------------------------------------------- */ -static char * +static CONST char * DoTildeSubst(interp, user, resultPtr) Tcl_Interp *interp; /* Interpreter in which to store error * message (if necessary). */ @@ -1161,7 +1467,7 @@ DoTildeSubst(interp, user, resultPtr) Tcl_DString *resultPtr; /* Initialized DString filled with name * after tilde substitution. */ { - char *dir; + CONST char *dir; if (*user == '\0') { Tcl_DString dirString; @@ -1187,7 +1493,7 @@ DoTildeSubst(interp, user, resultPtr) return NULL; } } - return resultPtr->string; + return Tcl_DStringValue(resultPtr); } /* @@ -1215,23 +1521,25 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int index, i, globFlags, pathlength, length, join, dir, result; - char *string, *pathOrDir, *separators; + int index, i, globFlags, length, join, dir, result; + char *string, *separators; Tcl_Obj *typePtr, *resultPtr, *look; - Tcl_DString prefix, directory; - static char *options[] = { - "-directory", "-join", "-nocomplain", "-path", "-types", "--", NULL + Tcl_Obj *pathOrDir = NULL; + Tcl_DString prefix; + static CONST char *options[] = { + "-directory", "-join", "-nocomplain", "-path", "-tails", + "-types", "--", NULL }; enum options { - GLOB_DIR, GLOB_JOIN, GLOB_NOCOMPLAIN, GLOB_PATH, GLOB_TYPE, GLOB_LAST + GLOB_DIR, GLOB_JOIN, GLOB_NOCOMPLAIN, GLOB_PATH, GLOB_TAILS, + GLOB_TYPE, GLOB_LAST }; enum pathDirOptions {PATH_NONE = -1 , PATH_GENERAL = 0, PATH_DIR = 1}; - GlobTypeData *globTypes = NULL; + Tcl_GlobTypeData *globTypes = NULL; globFlags = 0; join = 0; dir = PATH_NONE; - pathOrDir = NULL; typePtr = NULL; resultPtr = Tcl_GetObjResult(interp); for (i = 1; i < objc; i++) { @@ -1255,7 +1563,7 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) } switch (index) { case GLOB_NOCOMPLAIN: /* -nocomplain */ - globFlags |= GLOBMODE_NO_COMPLAIN; + globFlags |= TCL_GLOBMODE_NO_COMPLAIN; break; case GLOB_DIR: /* -dir */ if (i == (objc-1)) { @@ -1263,34 +1571,37 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) "missing argument to \"-directory\"", -1); return TCL_ERROR; } - if (dir != -1) { + if (dir != PATH_NONE) { Tcl_AppendToObj(resultPtr, "\"-directory\" cannot be used with \"-path\"", -1); return TCL_ERROR; } dir = PATH_DIR; - globFlags |= GLOBMODE_DIR; - pathOrDir = Tcl_GetStringFromObj(objv[i+1], &pathlength); + globFlags |= TCL_GLOBMODE_DIR; + pathOrDir = objv[i+1]; i++; break; case GLOB_JOIN: /* -join */ join = 1; break; + case GLOB_TAILS: /* -tails */ + globFlags |= TCL_GLOBMODE_TAILS; + break; case GLOB_PATH: /* -path */ if (i == (objc-1)) { Tcl_AppendToObj(resultPtr, "missing argument to \"-path\"", -1); return TCL_ERROR; } - if (dir != -1) { + if (dir != PATH_NONE) { Tcl_AppendToObj(resultPtr, "\"-path\" cannot be used with \"-directory\"", -1); return TCL_ERROR; } dir = PATH_GENERAL; - pathOrDir = Tcl_GetStringFromObj(objv[i+1], &pathlength); + pathOrDir = objv[i+1]; i++; break; case GLOB_TYPE: /* -types */ @@ -1316,7 +1627,13 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) Tcl_WrongNumArgs(interp, 1, objv, "?switches? name ?name ...?"); return TCL_ERROR; } - + if ((globFlags & TCL_GLOBMODE_TAILS) && (pathOrDir == NULL)) { + Tcl_AppendToObj(resultPtr, + "\"-tails\" must be used with either \"-directory\" or \"-path\"", + -1); + return TCL_ERROR; + } + separators = NULL; /* lint. */ switch (tclPlatform) { case TCL_PLATFORM_UNIX: @@ -1330,34 +1647,34 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) break; } if (dir == PATH_GENERAL) { + int pathlength; char *last; + char *first = Tcl_GetStringFromObj(pathOrDir,&pathlength); /* * Find the last path separator in the path */ - last = pathOrDir + pathlength; - for (; last != pathOrDir; last--) { + last = first + pathlength; + for (; last != first; last--) { if (strchr(separators, *(last-1)) != NULL) { break; } } - if (last == pathOrDir + pathlength) { + if (last == first + pathlength) { /* It's really a directory */ - dir = 1; + dir = PATH_DIR; } else { Tcl_DString pref; char *search, *find; Tcl_DStringInit(&pref); - Tcl_DStringInit(&directory); - if (last == pathOrDir) { + if (last == first) { /* The whole thing is a prefix */ - Tcl_DStringAppend(&pref, pathOrDir, -1); + Tcl_DStringAppend(&pref, first, -1); pathOrDir = NULL; } else { /* Have to split off the end */ - Tcl_DStringAppend(&pref, last, pathOrDir+pathlength-last); - Tcl_DStringAppend(&directory, pathOrDir, last-pathOrDir-1); - pathOrDir = Tcl_DStringValue(&directory); + Tcl_DStringAppend(&pref, last, first+pathlength-last); + pathOrDir = Tcl_NewStringObj(first, last-first-1); } /* Need to quote 'prefix' */ Tcl_DStringInit(&prefix); @@ -1377,7 +1694,11 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) Tcl_DStringFree(&pref); } } - + + if (pathOrDir != NULL) { + Tcl_IncrRefCount(pathOrDir); + } + if (typePtr != NULL) { /* * The rest of the possible type arguments (except 'd') are @@ -1385,7 +1706,7 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) * on an incompatible platform. */ Tcl_ListObjLength(interp, typePtr, &length); - globTypes = (GlobTypeData*) ckalloc(sizeof(GlobTypeData)); + globTypes = (Tcl_GlobTypeData*) ckalloc(sizeof(Tcl_GlobTypeData)); globTypes->type = 0; globTypes->perm = 0; globTypes->macType = NULL; @@ -1468,17 +1789,25 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) } } /* - * Error cases + * Error cases. We re-get the interpreter's result, + * just to be sure it hasn't changed, and we reset + * the 'join' flag to zero, since we haven't yet + * made use of it. */ badTypesArg: + resultPtr = Tcl_GetObjResult(interp); Tcl_AppendToObj(resultPtr, "bad argument to \"-types\": ", -1); Tcl_AppendObjToObj(resultPtr, look); result = TCL_ERROR; + join = 0; goto endOfGlob; badMacTypesArg: + resultPtr = Tcl_GetObjResult(interp); Tcl_AppendToObj(resultPtr, - "only one MacOS type or creator argument to \"-types\" allowed", -1); + "only one MacOS type or creator argument" + " to \"-types\" allowed", -1); result = TCL_ERROR; + join = 0; goto endOfGlob; } } @@ -1544,7 +1873,7 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) } } } - if ((globFlags & GLOBMODE_NO_COMPLAIN) == 0) { + if ((globFlags & TCL_GLOBMODE_NO_COMPLAIN) == 0) { if (Tcl_ListObjLength(interp, Tcl_GetObjResult(interp), &length) != TCL_OK) { /* This should never happen. Maybe we should be more dramatic */ @@ -1572,9 +1901,9 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) endOfGlob: if (join || (dir == PATH_GENERAL)) { Tcl_DStringFree(&prefix); - if (dir == PATH_GENERAL) { - Tcl_DStringFree(&directory); - } + } + if (pathOrDir != NULL) { + Tcl_DecrRefCount(pathOrDir); } if (globTypes != NULL) { if (globTypes->macType != NULL) { @@ -1596,16 +1925,24 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) * This procedure prepares arguments for the TclDoGlob call. * It sets the separator string based on the platform, performs * tilde substitution, and calls TclDoGlob. + * + * The interpreter's result, on entry to this function, must + * be a valid Tcl list (e.g. it could be empty), since we will + * lappend any new results to that list. If it is not a valid + * list, this function will fail to do anything very meaningful. * * Results: * The return value is a standard Tcl result indicating whether * an error occurred in globbing. After a normal return the * result in interp (set by TclDoGlob) holds all of the file names - * given by the dir and rem arguments. After an error the - * result in interp will hold an error message. + * given by the pattern and unquotedPrefix arguments. After an + * error the result in interp will hold an error message, unless + * the 'TCL_GLOBMODE_NO_COMPLAIN' flag was given, in which case + * an error results in a TCL_OK return leaving the interpreter's + * result unmodified. * * Side effects: - * The currentArgString is written to. + * The 'pattern' is written to. * *---------------------------------------------------------------------- */ @@ -1617,17 +1954,19 @@ TclGlob(interp, pattern, unquotedPrefix, globFlags, types) * or appending list of matching file names. */ char *pattern; /* Glob pattern to match. Must not refer * to a static string. */ - char *unquotedPrefix; /* Prefix to glob pattern, if non-null, which - * is considered literally. May be static. */ + Tcl_Obj *unquotedPrefix; /* Prefix to glob pattern, if non-null, which + * is considered literally. */ int globFlags; /* Stores or'ed combination of flags */ - GlobTypeData *types; /* Struct containing acceptable types. + Tcl_GlobTypeData *types; /* Struct containing acceptable types. * May be NULL. */ { char *separators; - char *head, *tail, *start; + CONST char *head; + char *tail, *start; char c; - int result; + int result, prefixLen; Tcl_DString buffer; + Tcl_Obj *oldResult; separators = NULL; /* lint. */ switch (tclPlatform) { @@ -1638,17 +1977,21 @@ TclGlob(interp, pattern, unquotedPrefix, globFlags, types) separators = "/\\:"; break; case TCL_PLATFORM_MAC: +#ifdef MAC_UNDERSTANDS_UNIX_PATHS if (unquotedPrefix == NULL) { separators = (strchr(pattern, ':') == NULL) ? "/" : ":"; } else { separators = ":"; } +#else + separators = ":"; +#endif break; } Tcl_DStringInit(&buffer); if (unquotedPrefix != NULL) { - start = unquotedPrefix; + start = Tcl_GetString(unquotedPrefix); } else { start = pattern; } @@ -1673,44 +2016,23 @@ TclGlob(interp, pattern, unquotedPrefix, globFlags, types) } /* - * Determine the home directory for the specified user. Note that - * we don't allow special characters in the user name. + * Determine the home directory for the specified user. */ c = *tail; *tail = '\0'; - /* - * I don't think we need to worry about special characters in - * the user name anymore (Vince Darley, June 1999), since the - * new code is designed to handle special chars. - */ -#ifndef NOT_NEEDED_ANYMORE - head = DoTildeSubst(interp, start+1, &buffer); -#else - - if (strpbrk(start+1, "\\[]*?{}") == NULL) { - head = DoTildeSubst(interp, start+1, &buffer); + if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) { + /* + * We will ignore any error message here, and we + * don't want to mess up the interpreter's result. + */ + head = DoTildeSubst(NULL, start+1, &buffer); } else { - if (!(globFlags & GLOBMODE_NO_COMPLAIN)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "globbing characters not ", - "supported in user names", (char *) NULL); - } - head = NULL; + head = DoTildeSubst(interp, start+1, &buffer); } -#endif *tail = c; if (head == NULL) { - if (globFlags & GLOBMODE_NO_COMPLAIN) { - /* - * We should in fact pass down the nocomplain flag - * or save the interp result or use another mechanism - * so the interp result is not mangled on errors in that case. - * but that would a bigger change than reasonable for a patch - * release. - * (see fileName.test 15.2-15.4 for expected behaviour) - */ - Tcl_ResetResult(interp); + if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) { return TCL_OK; } else { return TCL_ERROR; @@ -1726,30 +2048,113 @@ TclGlob(interp, pattern, unquotedPrefix, globFlags, types) } else { tail = pattern; if (unquotedPrefix != NULL) { - Tcl_DStringAppend(&buffer,unquotedPrefix,-1); + Tcl_DStringAppend(&buffer,Tcl_GetString(unquotedPrefix),-1); } } + /* - * If the prefix is a directory, make sure it ends in a directory - * separator. + * We want to remember the length of the current prefix, + * in case we are using TCL_GLOBMODE_TAILS. Also if we + * are using TCL_GLOBMODE_DIR, we must make sure the + * prefix ends in a directory separator. */ - if (unquotedPrefix != NULL) { - if (globFlags & GLOBMODE_DIR) { - c = Tcl_DStringValue(&buffer)[Tcl_DStringLength(&buffer)-1]; - if (strchr(separators, c) == NULL) { + prefixLen = Tcl_DStringLength(&buffer); + + if (prefixLen > 0) { + c = Tcl_DStringValue(&buffer)[prefixLen-1]; + if (strchr(separators, c) == NULL) { + /* + * If the prefix is a directory, make sure it ends in a + * directory separator. + */ + if (globFlags & TCL_GLOBMODE_DIR) { Tcl_DStringAppend(&buffer,separators,1); } + prefixLen++; } } + /* + * We need to get the old result, in case it is over-written + * below when we still need it. + */ + oldResult = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(oldResult); + Tcl_ResetResult(interp); + result = TclDoGlob(interp, separators, &buffer, tail, types); - Tcl_DStringFree(&buffer); + if (result != TCL_OK) { - if (globFlags & GLOBMODE_NO_COMPLAIN) { - Tcl_ResetResult(interp); - return TCL_OK; + if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) { + /* Put back the old result and reset the return code */ + Tcl_SetObjResult(interp, oldResult); + result = TCL_OK; + } + } else { + /* + * Now we must concatenate the 'oldResult' and the current + * result, and then place that into the interpreter. + * + * If we only want the tails, we must strip off the prefix now. + * It may seem more efficient to pass the tails flag down into + * TclDoGlob, Tcl_FSMatchInDirectory, but those functions are + * continually adjusting the prefix as the various pieces of + * the pattern are assimilated, so that would add a lot of + * complexity to the code. This way is a little slower (when + * the -tails flag is given), but much simpler to code. + */ + int objc, i; + Tcl_Obj **objv; + + /* Ensure sole ownership */ + if (Tcl_IsShared(oldResult)) { + Tcl_DecrRefCount(oldResult); + oldResult = Tcl_DuplicateObj(oldResult); + Tcl_IncrRefCount(oldResult); + } + + Tcl_ListObjGetElements(NULL, Tcl_GetObjResult(interp), + &objc, &objv); +#ifdef MAC_TCL + /* adjust prefixLen if TclDoGlob prepended a ':' */ + if ((prefixLen > 0) && (objc > 0) + && (Tcl_DStringValue(&buffer)[0] != ':')) { + char *str = Tcl_GetStringFromObj(objv[0],NULL); + if (str[0] == ':') { + prefixLen++; + } + } +#endif + for (i = 0; i< objc; i++) { + Tcl_Obj* elt; + if (globFlags & TCL_GLOBMODE_TAILS) { + int len; + char *oldStr = Tcl_GetStringFromObj(objv[i],&len); + if (len == prefixLen) { + if ((pattern[0] == '\0') + || (strchr(separators, pattern[0]) == NULL)) { + elt = Tcl_NewStringObj(".",1); + } else { + elt = Tcl_NewStringObj("/",1); + } + } else { + elt = Tcl_NewStringObj(oldStr + prefixLen, + len - prefixLen); + } + } else { + elt = objv[i]; + } + /* Assumption that 'oldResult' is a valid list */ + Tcl_ListObjAppendElement(interp, oldResult, elt); } + Tcl_SetObjResult(interp, oldResult); } + /* + * Release our temporary copy. All code paths above must + * end here so we free our reference. + */ + Tcl_DecrRefCount(oldResult); + Tcl_DStringFree(&buffer); return result; } @@ -1842,8 +2247,8 @@ TclDoGlob(interp, separators, headPtr, tail, types) Tcl_DString *headPtr; /* Completely expanded prefix. */ char *tail; /* The unexpanded remainder of the path. * Must not be a pointer to a static string. */ - GlobTypeData *types; /* List object containing list of acceptable types. - * May be NULL. */ + Tcl_GlobTypeData *types; /* List object containing list of acceptable + * types. May be NULL. */ { int baseLength, quoted, count; int result = TCL_OK; @@ -1880,12 +2285,14 @@ TclDoGlob(interp, separators, headPtr, tail, types) switch (tclPlatform) { case TCL_PLATFORM_MAC: +#ifdef MAC_UNDERSTANDS_UNIX_PATHS if (*separators == '/') { if (((length == 0) && (count == 0)) || ((length > 0) && (lastChar != ':'))) { Tcl_DStringAppend(headPtr, ":", 1); } } else { +#endif if (count == 0) { if ((length > 0) && (lastChar != ':')) { Tcl_DStringAppend(headPtr, ":", 1); @@ -1898,7 +2305,9 @@ TclDoGlob(interp, separators, headPtr, tail, types) Tcl_DStringAppend(headPtr, ":", 1); } } +#ifdef MAC_UNDERSTANDS_UNIX_PATHS } +#endif break; case TCL_PLATFORM_WINDOWS: /* @@ -2000,8 +2409,8 @@ TclDoGlob(interp, separators, headPtr, tail, types) Tcl_DStringSetLength(&newName, baseLength); Tcl_DStringAppend(&newName, element, p-element); Tcl_DStringAppend(&newName, closeBrace+1, -1); - result = TclDoGlob(interp, separators, - headPtr, Tcl_DStringValue(&newName), types); + result = TclDoGlob(interp, separators, headPtr, + Tcl_DStringValue(&newName), types); if (result != TCL_OK) { break; } @@ -2026,107 +2435,230 @@ TclDoGlob(interp, separators, headPtr, tail, types) * if the string is a static. */ - savedChar = *p; - *p = '\0'; - firstSpecialChar = strpbrk(tail, "*[]?\\"); - *p = savedChar; + savedChar = *p; + *p = '\0'; + firstSpecialChar = strpbrk(tail, "*[]?\\"); + *p = savedChar; } else { firstSpecialChar = strpbrk(tail, "*[]?\\"); } if (firstSpecialChar != NULL) { + int ret; + Tcl_Obj *head = Tcl_NewStringObj(Tcl_DStringValue(headPtr),-1); + Tcl_IncrRefCount(head); /* - * Look for matching files in the current directory. The - * implementation of this function is platform specific, but may - * recursively call TclDoGlob. For each file that matches, it will - * add the match onto the interp's result, or call TclDoGlob if there - * are more characters to be processed. + * Look for matching files in the given directory. The + * implementation of this function is platform specific. For + * each file that matches, it will add the match onto the + * resultPtr given. */ + if (*p == '\0') { + ret = Tcl_FSMatchInDirectory(interp, Tcl_GetObjResult(interp), + head, tail, types); + } else { + Tcl_Obj* resultPtr; - return TclpMatchFilesTypes(interp, separators, headPtr, tail, p, types); + /* + * We do the recursion ourselves. This makes implementing + * Tcl_FSMatchInDirectory for each filesystem much easier. + */ + Tcl_GlobTypeData dirOnly = { TCL_GLOB_TYPE_DIR, 0, NULL, NULL }; + char save = *p; + + *p = '\0'; + resultPtr = Tcl_NewListObj(0, NULL); + ret = Tcl_FSMatchInDirectory(interp, resultPtr, + head, tail, &dirOnly); + *p = save; + if (ret == TCL_OK) { + int resLength; + ret = Tcl_ListObjLength(interp, resultPtr, &resLength); + if (ret == TCL_OK) { + int i; + for (i =0; i< resLength; i++) { + Tcl_Obj *elt; + Tcl_DString ds; + Tcl_ListObjIndex(interp, resultPtr, i, &elt); + Tcl_DStringInit(&ds); + Tcl_DStringAppend(&ds, Tcl_GetString(elt), -1); + if(tclPlatform == TCL_PLATFORM_MAC) { + Tcl_DStringAppend(&ds, ":",1); + } else { + Tcl_DStringAppend(&ds, "/",1); + } + ret = TclDoGlob(interp, separators, &ds, p+1, types); + Tcl_DStringFree(&ds); + if (ret != TCL_OK) { + break; + } + } + } + } + Tcl_DecrRefCount(resultPtr); + } + Tcl_DecrRefCount(head); + return ret; } Tcl_DStringAppend(headPtr, tail, p-tail); if (*p != '\0') { return TclDoGlob(interp, separators, headPtr, p, types); - } + } else { + /* + * This is the code path reached by a command like 'glob foo'. + * + * There are no more wildcards in the pattern and no more + * unprocessed characters in the tail, so now we can construct + * the path, and pass it to Tcl_FSMatchInDirectory with an + * empty pattern to verify the existence of the file and check + * it is of the correct type (if a 'types' flag it given -- if + * no such flag was given, we could just use 'Tcl_FSLStat', but + * for simplicity we keep to a common approach). + */ - /* - * There are no more wildcards in the pattern and no more unprocessed - * characters in the tail, so now we can construct the path and verify - * the existence of the file. - */ + Tcl_Obj *nameObj; + /* Used to deal with one special case pertinent to MacOS */ + int macSpecialCase = 0; - switch (tclPlatform) { - case TCL_PLATFORM_MAC: { - if (strchr(Tcl_DStringValue(headPtr), ':') == NULL) { - Tcl_DStringAppend(headPtr, ":", 1); - } - name = Tcl_DStringValue(headPtr); - if (TclpAccess(name, F_OK) == 0) { - if ((name[1] != '\0') && (strchr(name+1, ':') == NULL)) { - Tcl_ListObjAppendElement(interp, Tcl_GetObjResult(interp), - Tcl_NewStringObj(name + 1,-1)); - } else { - Tcl_ListObjAppendElement(interp, Tcl_GetObjResult(interp), - Tcl_NewStringObj(name,-1)); + switch (tclPlatform) { + case TCL_PLATFORM_MAC: { + if (strchr(Tcl_DStringValue(headPtr), ':') == NULL) { + Tcl_DStringAppend(headPtr, ":", 1); } + macSpecialCase = 1; + break; } - break; - } - case TCL_PLATFORM_WINDOWS: { - int exists; - - /* - * We need to convert slashes to backslashes before checking - * for the existence of the file. Once we are done, we need - * to convert the slashes back. - */ - - if (Tcl_DStringLength(headPtr) == 0) { - if (((*name == '\\') && (name[1] == '/' || name[1] == '\\')) - || (*name == '/')) { - Tcl_DStringAppend(headPtr, "\\", 1); - } else { - Tcl_DStringAppend(headPtr, ".", 1); + case TCL_PLATFORM_WINDOWS: { + if (Tcl_DStringLength(headPtr) == 0) { + if (((*name == '\\') && (name[1] == '/' || name[1] == '\\')) + || (*name == '/')) { + Tcl_DStringAppend(headPtr, "\\", 1); + } else { + Tcl_DStringAppend(headPtr, ".", 1); + } } - } else { + /* + * Convert to forward slashes. This is required to pass + * some Tcl tests. We should probably remove the conversions + * here and in tclWinFile.c, since they aren't needed since + * the dropping of support for Win32s. + */ for (p = Tcl_DStringValue(headPtr); *p != '\0'; p++) { - if (*p == '/') { - *p = '\\'; + if (*p == '\\') { + *p = '/'; } } + break; } - name = Tcl_DStringValue(headPtr); - exists = (TclpAccess(name, F_OK) == 0); - - for (p = name; *p != '\0'; p++) { - if (*p == '\\') { - *p = '/'; + case TCL_PLATFORM_UNIX: { + if (Tcl_DStringLength(headPtr) == 0) { + if ((*name == '\\' && name[1] == '/') || (*name == '/')) { + Tcl_DStringAppend(headPtr, "/", 1); + } else { + Tcl_DStringAppend(headPtr, ".", 1); + } } + break; } - if (exists) { - Tcl_ListObjAppendElement(interp, Tcl_GetObjResult(interp), - Tcl_NewStringObj(name,-1)); - } - break; } - case TCL_PLATFORM_UNIX: { - if (Tcl_DStringLength(headPtr) == 0) { - if ((*name == '\\' && name[1] == '/') || (*name == '/')) { - Tcl_DStringAppend(headPtr, "/", 1); - } else { - Tcl_DStringAppend(headPtr, ".", 1); - } - } - name = Tcl_DStringValue(headPtr); - if (TclpAccess(name, F_OK) == 0) { - Tcl_ListObjAppendElement(interp, Tcl_GetObjResult(interp), - Tcl_NewStringObj(name,-1)); - } - break; + /* Common for all platforms */ + name = Tcl_DStringValue(headPtr); + nameObj = Tcl_NewStringObj(name, Tcl_DStringLength(headPtr)); + + Tcl_IncrRefCount(nameObj); + Tcl_FSMatchInDirectory(interp, Tcl_GetObjResult(interp), nameObj, + NULL, types); + Tcl_DecrRefCount(nameObj); + return TCL_OK; + } +} + + +/* + *--------------------------------------------------------------------------- + * + * TclFileDirname + * + * This procedure calculates the directory above a given + * path: basically 'file dirname'. It is used both by + * the 'dirname' subcommand of file and by code in tclIOUtil.c. + * + * Results: + * NULL if an error occurred, otherwise a Tcl_Obj owned by + * the caller (i.e. most likely with refCount 1). + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +Tcl_Obj* +TclFileDirname(interp, pathPtr) + Tcl_Interp *interp; /* Used for error reporting */ + Tcl_Obj *pathPtr; /* Path to take dirname of */ +{ + int splitElements; + Tcl_Obj *splitPtr; + Tcl_Obj *splitResultPtr = NULL; + + /* + * 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 actual full path name, if we + * had just a single component. + */ + splitPtr = Tcl_FSSplitPath(pathPtr, &splitElements); + if ((splitElements == 1) && (Tcl_GetString(pathPtr)[0] == '~')) { + Tcl_DecrRefCount(splitPtr); + splitPtr = Tcl_FSGetNormalizedPath(interp, pathPtr); + if (splitPtr == NULL) { + return NULL; } + splitPtr = Tcl_FSSplitPath(splitPtr, &splitElements); } - return TCL_OK; + /* + * Return all but the last component. If there is only one + * component, return it if the path was non-relative, otherwise + * return the current directory. + */ + + if (splitElements > 1) { + splitResultPtr = Tcl_FSJoinPath(splitPtr, splitElements - 1); + } else if (splitElements == 0 || + (Tcl_FSGetPathType(pathPtr) == TCL_PATH_RELATIVE)) { + splitResultPtr = Tcl_NewStringObj( + ((tclPlatform == TCL_PLATFORM_MAC) ? ":" : "."), 1); + } else { + Tcl_ListObjIndex(NULL, splitPtr, 0, &splitResultPtr); + } + Tcl_IncrRefCount(splitResultPtr); + Tcl_DecrRefCount(splitPtr); + return splitResultPtr; } + +/* + *--------------------------------------------------------------------------- + * + * Tcl_AllocStatBuf + * + * This procedure allocates a Tcl_StatBuf on the heap. It exists + * so that extensions may be used unchanged on systems where + * largefile support is optional. + * + * Results: + * A pointer to a Tcl_StatBuf which may be deallocated by being + * passed to ckfree(). + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ +Tcl_StatBuf * +Tcl_AllocStatBuf() { + return (Tcl_StatBuf *) ckalloc(sizeof(Tcl_StatBuf)); +} diff --git a/tcl/generic/tclGet.c b/tcl/generic/tclGet.c index 72edad8d981..98e7308c015 100644 --- a/tcl/generic/tclGet.c +++ b/tcl/generic/tclGet.c @@ -41,11 +41,12 @@ int Tcl_GetInt(interp, string, intPtr) Tcl_Interp *interp; /* Interpreter to use for error reporting. */ - char *string; /* String containing a (possibly signed) + CONST char *string; /* String containing a (possibly signed) * integer in a form acceptable to strtol. */ int *intPtr; /* Place to store converted result. */ { - char *end, *p; + char *end; + CONST char *p; long i; /* @@ -128,12 +129,13 @@ int TclGetLong(interp, string, longPtr) Tcl_Interp *interp; /* Interpreter used for error reporting * if not NULL. */ - char *string; /* String containing a (possibly signed) + CONST char *string; /* String containing a (possibly signed) * long integer in a form acceptable to * strtoul. */ long *longPtr; /* Place to store converted long result. */ { - char *end, *p; + char *end; + CONST char *p; long i; /* @@ -205,7 +207,7 @@ TclGetLong(interp, string, longPtr) int Tcl_GetDouble(interp, string, doublePtr) Tcl_Interp *interp; /* Interpreter used for error reporting. */ - char *string; /* String containing a floating-point number + CONST char *string; /* String containing a floating-point number * in a form acceptable to strtod. */ double *doublePtr; /* Place to store converted result. */ { @@ -262,7 +264,7 @@ Tcl_GetDouble(interp, string, doublePtr) int Tcl_GetBoolean(interp, string, boolPtr) Tcl_Interp *interp; /* Interpreter used for error reporting. */ - char *string; /* String containing a boolean number + CONST char *string; /* String containing a boolean number * specified either as 1/0 or true/false or * yes/no. */ int *boolPtr; /* Place to store converted result, which @@ -321,4 +323,3 @@ Tcl_GetBoolean(interp, string, boolPtr) } return TCL_OK; } - diff --git a/tcl/generic/tclGetDate.y b/tcl/generic/tclGetDate.y index 33eff627aad..d7f30f17a08 100644 --- a/tcl/generic/tclGetDate.y +++ b/tcl/generic/tclGetDate.y @@ -33,7 +33,7 @@ #include "tclInt.h" #include "tclPort.h" -#ifdef MAC_TCL +#if defined(MAC_TCL) && !defined(TCL_MAC_USE_MSL_EPOCH) # define EPOCH 1904 # define START_OF_TIME 1904 # define END_OF_TIME 2039 @@ -798,6 +798,23 @@ RelativeMonth(Start, RelMonth, TimePtr) result = Convert(Month, (time_t) tm->tm_mday, Year, (time_t) tm->tm_hour, (time_t) tm->tm_min, (time_t) tm->tm_sec, MER24, DSTmaybe, &Julian); + + /* + * The Julian time returned above is behind by one day, if "month" + * or "year" is used to specify relative time and the GMT flag is true. + * This problem occurs only when the current time is closer to + * midnight, the difference being not more than its time difference + * with GMT. For example, in US/Pacific time zone, the problem occurs + * whenever the current time is between midnight to 8:00am or 7:00amDST. + * See Bug# 413397 for more details and sample script. + * To resolve this bug, we simply add the number of seconds corresponding + * to timezone difference with GMT to Julian time, if GMT flag is true. + */ + + if (TclDateTimezone == 0) { + Julian += TclpGetTimeZone((unsigned long) Start) * 60L; + } + /* * The following iteration takes into account the case were we jump * into a "short month". Far example, "one month from Jan 31" will @@ -1137,4 +1154,3 @@ TclGetDate(p, now, zone, timePtr) *timePtr = Start; return 0; } - diff --git a/tcl/generic/tclHash.c b/tcl/generic/tclHash.c index cc1dcf2e627..277609c2d78 100644 --- a/tcl/generic/tclHash.c +++ b/tcl/generic/tclHash.c @@ -16,13 +16,21 @@ #include "tclInt.h" /* + * Prevent macros from clashing with function definitions. + */ + +#if TCL_PRESERVE_BINARY_COMPATABILITY +# undef Tcl_FindHashEntry +# undef Tcl_CreateHashEntry +#endif + +/* * When there are this many entries per bucket, on average, rebuild * the hash table to make it larger. */ #define REBUILD_MULTIPLIER 3 - /* * The following macro takes a preliminary integer hash value and * produces an index into a hash tables bucket list. The idea is @@ -35,27 +43,86 @@ (((((long) (i))*1103515245) >> (tablePtr)->downShift) & (tablePtr)->mask) /* + * Prototypes for the array hash key methods. + */ + +static Tcl_HashEntry * AllocArrayEntry _ANSI_ARGS_(( + Tcl_HashTable *tablePtr, + VOID *keyPtr)); +static int CompareArrayKeys _ANSI_ARGS_(( + VOID *keyPtr, Tcl_HashEntry *hPtr)); +static unsigned int HashArrayKey _ANSI_ARGS_(( + Tcl_HashTable *tablePtr, + VOID *keyPtr)); + +/* + * Prototypes for the one word hash key methods. + */ + +#if 0 +static Tcl_HashEntry * AllocOneWordEntry _ANSI_ARGS_(( + Tcl_HashTable *tablePtr, + VOID *keyPtr)); +static int CompareOneWordKeys _ANSI_ARGS_(( + VOID *keyPtr, Tcl_HashEntry *hPtr)); +static unsigned int HashOneWordKey _ANSI_ARGS_(( + Tcl_HashTable *tablePtr, + VOID *keyPtr)); +#endif + +/* + * Prototypes for the string hash key methods. + */ + +static Tcl_HashEntry * AllocStringEntry _ANSI_ARGS_(( + Tcl_HashTable *tablePtr, + VOID *keyPtr)); +static int CompareStringKeys _ANSI_ARGS_(( + VOID *keyPtr, Tcl_HashEntry *hPtr)); +static unsigned int HashStringKey _ANSI_ARGS_(( + Tcl_HashTable *tablePtr, + VOID *keyPtr)); + +/* * Procedure prototypes for static procedures in this file: */ -static Tcl_HashEntry * ArrayFind _ANSI_ARGS_((Tcl_HashTable *tablePtr, - CONST char *key)); -static Tcl_HashEntry * ArrayCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr, - CONST char *key, int *newPtr)); +#if TCL_PRESERVE_BINARY_COMPATABILITY static Tcl_HashEntry * BogusFind _ANSI_ARGS_((Tcl_HashTable *tablePtr, CONST char *key)); static Tcl_HashEntry * BogusCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr, CONST char *key, int *newPtr)); -static unsigned int HashString _ANSI_ARGS_((CONST char *string)); +#endif + static void RebuildTable _ANSI_ARGS_((Tcl_HashTable *tablePtr)); -static Tcl_HashEntry * StringFind _ANSI_ARGS_((Tcl_HashTable *tablePtr, - CONST char *key)); -static Tcl_HashEntry * StringCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr, - CONST char *key, int *newPtr)); -static Tcl_HashEntry * OneWordFind _ANSI_ARGS_((Tcl_HashTable *tablePtr, - CONST char *key)); -static Tcl_HashEntry * OneWordCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr, - CONST char *key, int *newPtr)); + +Tcl_HashKeyType tclArrayHashKeyType = { + TCL_HASH_KEY_TYPE_VERSION, /* version */ + TCL_HASH_KEY_RANDOMIZE_HASH, /* flags */ + HashArrayKey, /* hashKeyProc */ + CompareArrayKeys, /* compareKeysProc */ + AllocArrayEntry, /* allocEntryProc */ + NULL /* freeEntryProc */ +}; + +Tcl_HashKeyType tclOneWordHashKeyType = { + TCL_HASH_KEY_TYPE_VERSION, /* version */ + 0, /* flags */ + NULL, /* HashOneWordKey, */ /* hashProc */ + NULL, /* CompareOneWordKey, */ /* compareProc */ + NULL, /* AllocOneWordKey, */ /* allocEntryProc */ + NULL /* FreeOneWordKey, */ /* freeEntryProc */ +}; + +Tcl_HashKeyType tclStringHashKeyType = { + TCL_HASH_KEY_TYPE_VERSION, /* version */ + 0, /* flags */ + HashStringKey, /* hashKeyProc */ + CompareStringKeys, /* compareKeysProc */ + AllocStringEntry, /* allocEntryProc */ + NULL /* freeEntryProc */ +}; + /* *---------------------------------------------------------------------- @@ -75,6 +142,7 @@ static Tcl_HashEntry * OneWordCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr, *---------------------------------------------------------------------- */ +#undef Tcl_InitHashTable void Tcl_InitHashTable(tablePtr, keyType) register Tcl_HashTable *tablePtr; /* Pointer to table record, which @@ -83,8 +151,48 @@ Tcl_InitHashTable(tablePtr, keyType) * TCL_STRING_KEYS, TCL_ONE_WORD_KEYS, * or an integer >= 2. */ { + /* + * Use a special value to inform the extended version that it must + * not access any of the new fields in the Tcl_HashTable. If an + * extension is rebuilt then any calls to this function will be + * redirected to the extended version by a macro. + */ + Tcl_InitCustomHashTable(tablePtr, keyType, (Tcl_HashKeyType *) -1); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_InitCustomHashTable -- + * + * Given storage for a hash table, set up the fields to prepare + * the hash table for use. This is an extended version of + * Tcl_InitHashTable which supports user defined keys. + * + * Results: + * None. + * + * Side effects: + * TablePtr is now ready to be passed to Tcl_FindHashEntry and + * Tcl_CreateHashEntry. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_InitCustomHashTable(tablePtr, keyType, typePtr) + register Tcl_HashTable *tablePtr; /* Pointer to table record, which + * is supplied by the caller. */ + int keyType; /* Type of keys to use in table: + * TCL_STRING_KEYS, TCL_ONE_WORD_KEYS, + * TCL_CUSTOM_TYPE_KEYS, + * TCL_CUSTOM_PTR_KEYS, or an + * integer >= 2. */ + Tcl_HashKeyType *typePtr; /* Pointer to structure which defines + * the behaviour of this table. */ +{ #if (TCL_SMALL_HASH_TABLE != 4) - panic("Tcl_InitHashTable: TCL_SMALL_HASH_TABLE is %d, not 4\n", + panic("Tcl_InitCustomHashTable: TCL_SMALL_HASH_TABLE is %d, not 4\n", TCL_SMALL_HASH_TABLE); #endif @@ -97,16 +205,280 @@ Tcl_InitHashTable(tablePtr, keyType) tablePtr->downShift = 28; tablePtr->mask = 3; tablePtr->keyType = keyType; - if (keyType == TCL_STRING_KEYS) { - tablePtr->findProc = StringFind; - tablePtr->createProc = StringCreate; - } else if (keyType == TCL_ONE_WORD_KEYS) { - tablePtr->findProc = OneWordFind; - tablePtr->createProc = OneWordCreate; +#if TCL_PRESERVE_BINARY_COMPATABILITY + tablePtr->findProc = Tcl_FindHashEntry; + tablePtr->createProc = Tcl_CreateHashEntry; + + if (typePtr == NULL) { + /* + * The caller has been rebuilt so the hash table is an extended + * version. + */ + } else if (typePtr != (Tcl_HashKeyType *) -1) { + /* + * The caller is requesting a customized hash table so it must be + * an extended version. + */ + tablePtr->typePtr = typePtr; + } else { + /* + * The caller has not been rebuilt so the hash table is not + * extended. + */ + } +#else + if (typePtr == NULL) { + /* + * Use the key type to decide which key type is needed. + */ + if (keyType == TCL_STRING_KEYS) { + typePtr = &tclStringHashKeyType; + } else if (keyType == TCL_ONE_WORD_KEYS) { + typePtr = &tclOneWordHashKeyType; + } else if (keyType == TCL_CUSTOM_TYPE_KEYS) { + Tcl_Panic ("No type structure specified for TCL_CUSTOM_TYPE_KEYS"); + } else if (keyType == TCL_CUSTOM_PTR_KEYS) { + Tcl_Panic ("No type structure specified for TCL_CUSTOM_PTR_KEYS"); + } else { + typePtr = &tclArrayHashKeyType; + } + } else if (typePtr == (Tcl_HashKeyType *) -1) { + /* + * If the caller has not been rebuilt then we cannot continue as + * the hash table is not an extended version. + */ + Tcl_Panic ("Hash table is not compatible"); + } + tablePtr->typePtr = typePtr; +#endif +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FindHashEntry -- + * + * Given a hash table find the entry with a matching key. + * + * Results: + * The return value is a token for the matching entry in the + * hash table, or NULL if there was no matching entry. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_HashEntry * +Tcl_FindHashEntry(tablePtr, key) + Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ + CONST char *key; /* Key to use to find matching entry. */ +{ + register Tcl_HashEntry *hPtr; + Tcl_HashKeyType *typePtr; + unsigned int hash; + int index; + +#if TCL_PRESERVE_BINARY_COMPATABILITY + if (tablePtr->keyType == TCL_STRING_KEYS) { + typePtr = &tclStringHashKeyType; + } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) { + typePtr = &tclOneWordHashKeyType; + } else if (tablePtr->keyType == TCL_CUSTOM_TYPE_KEYS + || tablePtr->keyType == TCL_CUSTOM_PTR_KEYS) { + typePtr = tablePtr->typePtr; + } else { + typePtr = &tclArrayHashKeyType; + } +#else + typePtr = tablePtr->typePtr; + if (typePtr == NULL) { + Tcl_Panic("called Tcl_FindHashEntry on deleted table"); + return NULL; + } +#endif + + if (typePtr->hashKeyProc) { + hash = typePtr->hashKeyProc (tablePtr, (VOID *) key); + if (typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { + index = RANDOM_INDEX (tablePtr, hash); + } else { + index = hash & tablePtr->mask; + } + } else { + hash = (unsigned int) key; + index = RANDOM_INDEX (tablePtr, hash); + } + + /* + * Search all of the entries in the appropriate bucket. + */ + + if (typePtr->compareKeysProc) { + for (hPtr = tablePtr->buckets[index]; hPtr != NULL; + hPtr = hPtr->nextPtr) { +#if TCL_HASH_KEY_STORE_HASH + if (hash != (unsigned int) hPtr->hash) { + continue; + } +#endif + if (typePtr->compareKeysProc ((VOID *) key, hPtr)) { + return hPtr; + } + } + } else { + for (hPtr = tablePtr->buckets[index]; hPtr != NULL; + hPtr = hPtr->nextPtr) { +#if TCL_HASH_KEY_STORE_HASH + if (hash != (unsigned int) hPtr->hash) { + continue; + } +#endif + if (key == hPtr->key.oneWordValue) { + return hPtr; + } + } + } + + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateHashEntry -- + * + * Given a hash table with string keys, and a string key, find + * the entry with a matching key. If there is no matching entry, + * then create a new entry that does match. + * + * Results: + * The return value is a pointer to the matching entry. If this + * is a newly-created entry, then *newPtr will be set to a non-zero + * value; otherwise *newPtr will be set to 0. If this is a new + * entry the value stored in the entry will initially be 0. + * + * Side effects: + * A new entry may be added to the hash table. + * + *---------------------------------------------------------------------- + */ + +Tcl_HashEntry * +Tcl_CreateHashEntry(tablePtr, key, newPtr) + 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. */ +{ + register Tcl_HashEntry *hPtr; + Tcl_HashKeyType *typePtr; + unsigned int hash; + int index; + +#if TCL_PRESERVE_BINARY_COMPATABILITY + if (tablePtr->keyType == TCL_STRING_KEYS) { + typePtr = &tclStringHashKeyType; + } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) { + typePtr = &tclOneWordHashKeyType; + } else if (tablePtr->keyType == TCL_CUSTOM_TYPE_KEYS + || tablePtr->keyType == TCL_CUSTOM_PTR_KEYS) { + typePtr = tablePtr->typePtr; + } else { + typePtr = &tclArrayHashKeyType; + } +#else + typePtr = tablePtr->typePtr; + if (typePtr == NULL) { + Tcl_Panic("called Tcl_CreateHashEntry on deleted table"); + return NULL; + } +#endif + + if (typePtr->hashKeyProc) { + hash = typePtr->hashKeyProc (tablePtr, (VOID *) key); + if (typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { + index = RANDOM_INDEX (tablePtr, hash); + } else { + index = hash & tablePtr->mask; + } + } else { + hash = (unsigned int) key; + index = RANDOM_INDEX (tablePtr, hash); + } + + /* + * Search all of the entries in the appropriate bucket. + */ + + if (typePtr->compareKeysProc) { + for (hPtr = tablePtr->buckets[index]; hPtr != NULL; + hPtr = hPtr->nextPtr) { +#if TCL_HASH_KEY_STORE_HASH + if (hash != (unsigned int) hPtr->hash) { + continue; + } +#endif + if (typePtr->compareKeysProc ((VOID *) key, hPtr)) { + *newPtr = 0; + return hPtr; + } + } + } else { + for (hPtr = tablePtr->buckets[index]; hPtr != NULL; + hPtr = hPtr->nextPtr) { +#if TCL_HASH_KEY_STORE_HASH + if (hash != (unsigned int) hPtr->hash) { + continue; + } +#endif + if (key == hPtr->key.oneWordValue) { + *newPtr = 0; + return hPtr; + } + } + } + + /* + * Entry not found. Add a new one to the bucket. + */ + + *newPtr = 1; + if (typePtr->allocEntryProc) { + hPtr = typePtr->allocEntryProc (tablePtr, (VOID *) key); } else { - tablePtr->findProc = ArrayFind; - tablePtr->createProc = ArrayCreate; - }; + hPtr = (Tcl_HashEntry *) ckalloc((unsigned) sizeof(Tcl_HashEntry)); + hPtr->key.oneWordValue = (char *) key; + } + + hPtr->tablePtr = tablePtr; +#if TCL_HASH_KEY_STORE_HASH +# if TCL_PRESERVE_BINARY_COMPATABILITY + hPtr->hash = (VOID *) hash; +# else + hPtr->hash = hash; +# endif + hPtr->nextPtr = tablePtr->buckets[index]; + tablePtr->buckets[index] = hPtr; +#else + hPtr->bucketPtr = &(tablePtr->buckets[index]); + hPtr->nextPtr = *hPtr->bucketPtr; + *hPtr->bucketPtr = hPtr; +#endif + hPtr->clientData = 0; + tablePtr->numEntries++; + + /* + * If the table has exceeded a decent size, rebuild it with many + * more buckets. + */ + + if (tablePtr->numEntries >= tablePtr->rebuildSize) { + RebuildTable(tablePtr); + } + return hPtr; } /* @@ -133,11 +505,47 @@ Tcl_DeleteHashEntry(entryPtr) Tcl_HashEntry *entryPtr; { register Tcl_HashEntry *prevPtr; + Tcl_HashKeyType *typePtr; + Tcl_HashTable *tablePtr; + Tcl_HashEntry **bucketPtr; +#if TCL_HASH_KEY_STORE_HASH + int index; +#endif + + tablePtr = entryPtr->tablePtr; - if (*entryPtr->bucketPtr == entryPtr) { - *entryPtr->bucketPtr = entryPtr->nextPtr; +#if TCL_PRESERVE_BINARY_COMPATABILITY + if (tablePtr->keyType == TCL_STRING_KEYS) { + typePtr = &tclStringHashKeyType; + } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) { + typePtr = &tclOneWordHashKeyType; + } else if (tablePtr->keyType == TCL_CUSTOM_TYPE_KEYS + || tablePtr->keyType == TCL_CUSTOM_PTR_KEYS) { + typePtr = tablePtr->typePtr; + } else { + typePtr = &tclArrayHashKeyType; + } +#else + typePtr = tablePtr->typePtr; +#endif + +#if TCL_HASH_KEY_STORE_HASH + if (typePtr->hashKeyProc == NULL + || typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { + index = RANDOM_INDEX (tablePtr, entryPtr->hash); + } else { + index = ((unsigned int) entryPtr->hash) & tablePtr->mask; + } + + bucketPtr = &(tablePtr->buckets[index]); +#else + bucketPtr = entryPtr->bucketPtr; +#endif + + if (*bucketPtr == entryPtr) { + *bucketPtr = entryPtr->nextPtr; } else { - for (prevPtr = *entryPtr->bucketPtr; ; prevPtr = prevPtr->nextPtr) { + for (prevPtr = *bucketPtr; ; prevPtr = prevPtr->nextPtr) { if (prevPtr == NULL) { panic("malformed bucket chain in Tcl_DeleteHashEntry"); } @@ -147,8 +555,13 @@ Tcl_DeleteHashEntry(entryPtr) } } } - entryPtr->tablePtr->numEntries--; - ckfree((char *) entryPtr); + + tablePtr->numEntries--; + if (typePtr->freeEntryProc) { + typePtr->freeEntryProc (entryPtr); + } else { + ckfree((char *) entryPtr); + } } /* @@ -173,8 +586,24 @@ Tcl_DeleteHashTable(tablePtr) register Tcl_HashTable *tablePtr; /* Table to delete. */ { register Tcl_HashEntry *hPtr, *nextPtr; + Tcl_HashKeyType *typePtr; int i; +#if TCL_PRESERVE_BINARY_COMPATABILITY + if (tablePtr->keyType == TCL_STRING_KEYS) { + typePtr = &tclStringHashKeyType; + } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) { + typePtr = &tclOneWordHashKeyType; + } else if (tablePtr->keyType == TCL_CUSTOM_TYPE_KEYS + || tablePtr->keyType == TCL_CUSTOM_PTR_KEYS) { + typePtr = tablePtr->typePtr; + } else { + typePtr = &tclArrayHashKeyType; + } +#else + typePtr = tablePtr->typePtr; +#endif + /* * Free up all the entries in the table. */ @@ -183,7 +612,11 @@ Tcl_DeleteHashTable(tablePtr) hPtr = tablePtr->buckets[i]; while (hPtr != NULL) { nextPtr = hPtr->nextPtr; - ckfree((char *) hPtr); + if (typePtr->freeEntryProc) { + typePtr->freeEntryProc (hPtr); + } else { + ckfree((char *) hPtr); + } hPtr = nextPtr; } } @@ -201,8 +634,12 @@ Tcl_DeleteHashTable(tablePtr) * re-initialization. */ +#if TCL_PRESERVE_BINARY_COMPATABILITY tablePtr->findProc = BogusFind; tablePtr->createProc = BogusCreate; +#else + tablePtr->typePtr = NULL; +#endif } /* @@ -299,7 +736,7 @@ Tcl_NextHashEntry(searchPtr) *---------------------------------------------------------------------- */ -char * +CONST char * Tcl_HashStats(tablePtr) Tcl_HashTable *tablePtr; /* Table for which to produce stats. */ { @@ -355,14 +792,12 @@ Tcl_HashStats(tablePtr) /* *---------------------------------------------------------------------- * - * HashString -- + * AllocArrayEntry -- * - * Compute a one-word summary of a text string, which can be - * used to generate a hash index. + * Allocate space for a Tcl_HashEntry containing the array key. * * Results: - * The return value is a one-word summary of the information in - * string. + * The return value is a pointer to the created entry. * * Side effects: * None. @@ -370,52 +805,42 @@ Tcl_HashStats(tablePtr) *---------------------------------------------------------------------- */ -static unsigned int -HashString(string) - register CONST char *string;/* String from which to compute hash value. */ +static Tcl_HashEntry * +AllocArrayEntry(tablePtr, keyPtr) + Tcl_HashTable *tablePtr; /* Hash table. */ + VOID *keyPtr; /* Key to store in the hash table entry. */ { - register unsigned int result; - register int c; - - /* - * I tried a zillion different hash functions and asked many other - * people for advice. Many people had their own favorite functions, - * all different, but no-one had much idea why they were good ones. - * I chose the one below (multiply by 9 and add new character) - * because of the following reasons: - * - * 1. Multiplying by 10 is perfect for keys that are decimal strings, - * and multiplying by 9 is just about as good. - * 2. Times-9 is (shift-left-3) plus (old). This means that each - * character's bits hang around in the low-order bits of the - * hash value for ever, plus they spread fairly rapidly up to - * the high-order bits to fill out the hash value. This seems - * works well both for decimal and non-decimal strings. - */ + int *array = (int *) keyPtr; + register int *iPtr1, *iPtr2; + Tcl_HashEntry *hPtr; + int count; + unsigned int size; - result = 0; - while (1) { - c = *string; - string++; - if (c == 0) { - break; - } - result += (result<<3) + c; + count = tablePtr->keyType; + + size = sizeof(Tcl_HashEntry) + (count*sizeof(int)) - sizeof(hPtr->key); + if (size < sizeof(Tcl_HashEntry)) + size = sizeof(Tcl_HashEntry); + hPtr = (Tcl_HashEntry *) ckalloc(size); + + for (iPtr1 = array, iPtr2 = hPtr->key.words; + count > 0; count--, iPtr1++, iPtr2++) { + *iPtr2 = *iPtr1; } - return result; + + return hPtr; } /* *---------------------------------------------------------------------- * - * StringFind -- + * CompareArrayKeys -- * - * Given a hash table with string keys, and a string key, find - * the entry with a matching key. + * Compares two array keys. * * Results: - * The return value is a token for the matching entry in the - * hash table, or NULL if there was no matching entry. + * The return value is 0 if they are different and 1 if they are + * the same. * * Side effects: * None. @@ -423,124 +848,38 @@ HashString(string) *---------------------------------------------------------------------- */ -static Tcl_HashEntry * -StringFind(tablePtr, key) - Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ - CONST char *key; /* Key to use to find matching entry. */ +static int +CompareArrayKeys(keyPtr, hPtr) + VOID *keyPtr; /* New key to compare. */ + Tcl_HashEntry *hPtr; /* Existing key to compare. */ { - register Tcl_HashEntry *hPtr; - register CONST char *p1, *p2; - int index; - - index = HashString(key) & tablePtr->mask; - - /* - * Search all of the entries in the appropriate bucket. - */ - - for (hPtr = tablePtr->buckets[index]; hPtr != NULL; - hPtr = hPtr->nextPtr) { - for (p1 = key, p2 = hPtr->key.string; ; p1++, p2++) { - if (*p1 != *p2) { - break; - } - if (*p1 == '\0') { - return hPtr; - } + register CONST int *iPtr1 = (CONST int *) keyPtr; + register CONST int *iPtr2 = (CONST int *) hPtr->key.words; + Tcl_HashTable *tablePtr = hPtr->tablePtr; + int count; + + for (count = tablePtr->keyType; ; count--, iPtr1++, iPtr2++) { + if (count == 0) { + return 1; } - } - return NULL; -} - -/* - *---------------------------------------------------------------------- - * - * StringCreate -- - * - * Given a hash table with string keys, and a string key, find - * the entry with a matching key. If there is no matching entry, - * then create a new entry that does match. - * - * Results: - * The return value is a pointer to the matching entry. If this - * is a newly-created entry, then *newPtr will be set to a non-zero - * value; otherwise *newPtr will be set to 0. If this is a new - * entry the value stored in the entry will initially be 0. - * - * Side effects: - * A new entry may be added to the hash table. - * - *---------------------------------------------------------------------- - */ - -static Tcl_HashEntry * -StringCreate(tablePtr, key, newPtr) - 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. */ -{ - register Tcl_HashEntry *hPtr; - register CONST char *p1, *p2; - int index; - - index = HashString(key) & tablePtr->mask; - - /* - * Search all of the entries in this bucket. - */ - - for (hPtr = tablePtr->buckets[index]; hPtr != NULL; - hPtr = hPtr->nextPtr) { - for (p1 = key, p2 = hPtr->key.string; ; p1++, p2++) { - if (*p1 != *p2) { - break; - } - if (*p1 == '\0') { - *newPtr = 0; - return hPtr; - } + if (*iPtr1 != *iPtr2) { + break; } } - - /* - * Entry not found. Add a new one to the bucket. - */ - - *newPtr = 1; - hPtr = (Tcl_HashEntry *) ckalloc((unsigned) - (sizeof(Tcl_HashEntry) + strlen(key) - (sizeof(hPtr->key) -1))); - hPtr->tablePtr = tablePtr; - hPtr->bucketPtr = &(tablePtr->buckets[index]); - hPtr->nextPtr = *hPtr->bucketPtr; - hPtr->clientData = 0; - strcpy(hPtr->key.string, key); - *hPtr->bucketPtr = hPtr; - tablePtr->numEntries++; - - /* - * If the table has exceeded a decent size, rebuild it with many - * more buckets. - */ - - if (tablePtr->numEntries >= tablePtr->rebuildSize) { - RebuildTable(tablePtr); - } - return hPtr; + return 0; } /* *---------------------------------------------------------------------- * - * OneWordFind -- + * HashArrayKey -- * - * Given a hash table with one-word keys, and a one-word key, find - * the entry with a matching key. + * Compute a one-word summary of an array, which can be + * used to generate a hash index. * * Results: - * The return value is a token for the matching entry in the - * hash table, or NULL if there was no matching entry. + * The return value is a one-word summary of the information in + * string. * * Side effects: * None. @@ -548,111 +887,66 @@ StringCreate(tablePtr, key, newPtr) *---------------------------------------------------------------------- */ -static Tcl_HashEntry * -OneWordFind(tablePtr, key) - Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ - register CONST char *key; /* Key to use to find matching entry. */ +static unsigned int +HashArrayKey(tablePtr, keyPtr) + Tcl_HashTable *tablePtr; /* Hash table. */ + VOID *keyPtr; /* Key from which to compute hash value. */ { - register Tcl_HashEntry *hPtr; - int index; - - index = RANDOM_INDEX(tablePtr, key); - - /* - * Search all of the entries in the appropriate bucket. - */ + register CONST int *array = (CONST int *) keyPtr; + register unsigned int result; + int count; - for (hPtr = tablePtr->buckets[index]; hPtr != NULL; - hPtr = hPtr->nextPtr) { - if (hPtr->key.oneWordValue == key) { - return hPtr; - } + for (result = 0, count = tablePtr->keyType; count > 0; + count--, array++) { + result += *array; } - return NULL; + return result; } /* *---------------------------------------------------------------------- * - * OneWordCreate -- + * AllocStringEntry -- * - * Given a hash table with one-word keys, and a one-word key, find - * the entry with a matching key. If there is no matching entry, - * then create a new entry that does match. + * Allocate space for a Tcl_HashEntry containing the string key. * * Results: - * The return value is a pointer to the matching entry. If this - * is a newly-created entry, then *newPtr will be set to a non-zero - * value; otherwise *newPtr will be set to 0. If this is a new - * entry the value stored in the entry will initially be 0. + * The return value is a pointer to the created entry. * * Side effects: - * A new entry may be added to the hash table. + * None. * *---------------------------------------------------------------------- */ static Tcl_HashEntry * -OneWordCreate(tablePtr, key, newPtr) - Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ - register CONST char *key; /* Key to use to find or create matching - * entry. */ - int *newPtr; /* Store info here telling whether a new - * entry was created. */ +AllocStringEntry(tablePtr, keyPtr) + Tcl_HashTable *tablePtr; /* Hash table. */ + VOID *keyPtr; /* Key to store in the hash table entry. */ { - register Tcl_HashEntry *hPtr; - int index; - - index = RANDOM_INDEX(tablePtr, key); - - /* - * Search all of the entries in this bucket. - */ - - for (hPtr = tablePtr->buckets[index]; hPtr != NULL; - hPtr = hPtr->nextPtr) { - if (hPtr->key.oneWordValue == key) { - *newPtr = 0; - return hPtr; - } - } - - /* - * Entry not found. Add a new one to the bucket. - */ - - *newPtr = 1; - hPtr = (Tcl_HashEntry *) ckalloc(sizeof(Tcl_HashEntry)); - hPtr->tablePtr = tablePtr; - hPtr->bucketPtr = &(tablePtr->buckets[index]); - hPtr->nextPtr = *hPtr->bucketPtr; - hPtr->clientData = 0; - hPtr->key.oneWordValue = (char *) key; /* CONST XXXX */ - *hPtr->bucketPtr = hPtr; - tablePtr->numEntries++; + CONST char *string = (CONST char *) keyPtr; + Tcl_HashEntry *hPtr; + unsigned int size; - /* - * If the table has exceeded a decent size, rebuild it with many - * more buckets. - */ + size = sizeof(Tcl_HashEntry) + strlen(string) + 1 - sizeof(hPtr->key); + if (size < sizeof(Tcl_HashEntry)) + size = sizeof(Tcl_HashEntry); + hPtr = (Tcl_HashEntry *) ckalloc(size); + strcpy(hPtr->key.string, string); - if (tablePtr->numEntries >= tablePtr->rebuildSize) { - RebuildTable(tablePtr); - } return hPtr; } /* *---------------------------------------------------------------------- * - * ArrayFind -- + * CompareStringKeys -- * - * Given a hash table with array-of-int keys, and a key, find - * the entry with a matching key. + * Compares two string keys. * * Results: - * The return value is a token for the matching entry in the - * hash table, or NULL if there was no matching entry. + * The return value is 0 if they are different and 1 if they are + * the same. * * Side effects: * None. @@ -660,128 +954,81 @@ OneWordCreate(tablePtr, key, newPtr) *---------------------------------------------------------------------- */ -static Tcl_HashEntry * -ArrayFind(tablePtr, key) - Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ - CONST char *key; /* Key to use to find matching entry. */ +static int +CompareStringKeys(keyPtr, hPtr) + VOID *keyPtr; /* New key to compare. */ + Tcl_HashEntry *hPtr; /* Existing key to compare. */ { - register Tcl_HashEntry *hPtr; - int *arrayPtr = (int *) key; - register int *iPtr1, *iPtr2; - int index, count; - - for (index = 0, count = tablePtr->keyType, iPtr1 = arrayPtr; - count > 0; count--, iPtr1++) { - index += *iPtr1; - } - index = RANDOM_INDEX(tablePtr, index); - - /* - * Search all of the entries in the appropriate bucket. - */ + register CONST char *p1 = (CONST char *) keyPtr; + register CONST char *p2 = (CONST char *) hPtr->key.string; - for (hPtr = tablePtr->buckets[index]; hPtr != NULL; - hPtr = hPtr->nextPtr) { - for (iPtr1 = arrayPtr, iPtr2 = hPtr->key.words, - count = tablePtr->keyType; ; count--, iPtr1++, iPtr2++) { - if (count == 0) { - return hPtr; - } - if (*iPtr1 != *iPtr2) { - break; - } + for (;; p1++, p2++) { + if (*p1 != *p2) { + break; + } + if (*p1 == '\0') { + return 1; } } - return NULL; + return 0; } /* *---------------------------------------------------------------------- * - * ArrayCreate -- + * HashStringKey -- * - * Given a hash table with one-word keys, and a one-word key, find - * the entry with a matching key. If there is no matching entry, - * then create a new entry that does match. + * Compute a one-word summary of a text string, which can be + * used to generate a hash index. * * Results: - * The return value is a pointer to the matching entry. If this - * is a newly-created entry, then *newPtr will be set to a non-zero - * value; otherwise *newPtr will be set to 0. If this is a new - * entry the value stored in the entry will initially be 0. + * The return value is a one-word summary of the information in + * string. * * Side effects: - * A new entry may be added to the hash table. + * None. * *---------------------------------------------------------------------- */ -static Tcl_HashEntry * -ArrayCreate(tablePtr, key, newPtr) - Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ - register CONST char *key; /* Key to use to find or create matching - * entry. */ - int *newPtr; /* Store info here telling whether a new - * entry was created. */ +static unsigned int +HashStringKey(tablePtr, keyPtr) + Tcl_HashTable *tablePtr; /* Hash table. */ + VOID *keyPtr; /* Key from which to compute hash value. */ { - register Tcl_HashEntry *hPtr; - int *arrayPtr = (int *) key; - register int *iPtr1, *iPtr2; - int index, count; - - for (index = 0, count = tablePtr->keyType, iPtr1 = arrayPtr; - count > 0; count--, iPtr1++) { - index += *iPtr1; - } - index = RANDOM_INDEX(tablePtr, index); + register CONST char *string = (CONST char *) keyPtr; + register unsigned int result; + register int c; /* - * Search all of the entries in the appropriate bucket. + * I tried a zillion different hash functions and asked many other + * people for advice. Many people had their own favorite functions, + * all different, but no-one had much idea why they were good ones. + * I chose the one below (multiply by 9 and add new character) + * because of the following reasons: + * + * 1. Multiplying by 10 is perfect for keys that are decimal strings, + * and multiplying by 9 is just about as good. + * 2. Times-9 is (shift-left-3) plus (old). This means that each + * character's bits hang around in the low-order bits of the + * hash value for ever, plus they spread fairly rapidly up to + * the high-order bits to fill out the hash value. This seems + * works well both for decimal and non-decimal strings. */ - for (hPtr = tablePtr->buckets[index]; hPtr != NULL; - hPtr = hPtr->nextPtr) { - for (iPtr1 = arrayPtr, iPtr2 = hPtr->key.words, - count = tablePtr->keyType; ; count--, iPtr1++, iPtr2++) { - if (count == 0) { - *newPtr = 0; - return hPtr; - } - if (*iPtr1 != *iPtr2) { - break; - } + result = 0; + while (1) { + c = *string; + string++; + if (c == 0) { + break; } + result += (result<<3) + c; } - - /* - * Entry not found. Add a new one to the bucket. - */ - - *newPtr = 1; - hPtr = (Tcl_HashEntry *) ckalloc((unsigned) (sizeof(Tcl_HashEntry) - + (tablePtr->keyType*sizeof(int)) - 4)); - hPtr->tablePtr = tablePtr; - hPtr->bucketPtr = &(tablePtr->buckets[index]); - hPtr->nextPtr = *hPtr->bucketPtr; - hPtr->clientData = 0; - for (iPtr1 = arrayPtr, iPtr2 = hPtr->key.words, count = tablePtr->keyType; - count > 0; count--, iPtr1++, iPtr2++) { - *iPtr2 = *iPtr1; - } - *hPtr->bucketPtr = hPtr; - tablePtr->numEntries++; - - /* - * If the table has exceeded a decent size, rebuild it with many - * more buckets. - */ - - if (tablePtr->numEntries >= tablePtr->rebuildSize) { - RebuildTable(tablePtr); - } - return hPtr; + return result; } +#if TCL_PRESERVE_BINARY_COMPATABILITY /* *---------------------------------------------------------------------- * @@ -840,6 +1087,7 @@ BogusCreate(tablePtr, key, newPtr) panic("called Tcl_CreateHashEntry on deleted table"); return NULL; } +#endif /* *---------------------------------------------------------------------- @@ -869,6 +1117,8 @@ RebuildTable(tablePtr) Tcl_HashEntry **oldBuckets; register Tcl_HashEntry **oldChainPtr, **newChainPtr; register Tcl_HashEntry *hPtr; + Tcl_HashKeyType *typePtr; + VOID *key; oldSize = tablePtr->numBuckets; oldBuckets = tablePtr->buckets; @@ -889,6 +1139,21 @@ RebuildTable(tablePtr) tablePtr->downShift -= 2; tablePtr->mask = (tablePtr->mask << 2) + 3; +#if TCL_PRESERVE_BINARY_COMPATABILITY + if (tablePtr->keyType == TCL_STRING_KEYS) { + typePtr = &tclStringHashKeyType; + } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) { + typePtr = &tclOneWordHashKeyType; + } else if (tablePtr->keyType == TCL_CUSTOM_TYPE_KEYS + || tablePtr->keyType == TCL_CUSTOM_PTR_KEYS) { + typePtr = tablePtr->typePtr; + } else { + typePtr = &tclArrayHashKeyType; + } +#else + typePtr = tablePtr->typePtr; +#endif + /* * Rehash all of the existing entries into the new bucket array. */ @@ -896,23 +1161,35 @@ RebuildTable(tablePtr) for (oldChainPtr = oldBuckets; oldSize > 0; oldSize--, oldChainPtr++) { for (hPtr = *oldChainPtr; hPtr != NULL; hPtr = *oldChainPtr) { *oldChainPtr = hPtr->nextPtr; - if (tablePtr->keyType == TCL_STRING_KEYS) { - index = HashString(hPtr->key.string) & tablePtr->mask; - } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) { - index = RANDOM_INDEX(tablePtr, hPtr->key.oneWordValue); - } else { - register int *iPtr; - int count; - for (index = 0, count = tablePtr->keyType, - iPtr = hPtr->key.words; count > 0; count--, iPtr++) { - index += *iPtr; + key = (VOID *) Tcl_GetHashKey (tablePtr, hPtr); + +#if TCL_HASH_KEY_STORE_HASH + if (typePtr->hashKeyProc == NULL + || typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { + index = RANDOM_INDEX (tablePtr, hPtr->hash); + } else { + index = ((unsigned int) hPtr->hash) & tablePtr->mask; + } + hPtr->nextPtr = tablePtr->buckets[index]; + tablePtr->buckets[index] = hPtr; +#else + if (typePtr->hashKeyProc) { + unsigned int hash; + hash = typePtr->hashKeyProc (tablePtr, (VOID *) key); + if (typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { + index = RANDOM_INDEX (tablePtr, hash); + } else { + index = hash & tablePtr->mask; } - index = RANDOM_INDEX(tablePtr, index); + } else { + index = RANDOM_INDEX (tablePtr, key); } + hPtr->bucketPtr = &(tablePtr->buckets[index]); hPtr->nextPtr = *hPtr->bucketPtr; *hPtr->bucketPtr = hPtr; +#endif } } diff --git a/tcl/generic/tclHistory.c b/tcl/generic/tclHistory.c index e69f8ca28e7..5ac7bc70748 100644 --- a/tcl/generic/tclHistory.c +++ b/tcl/generic/tclHistory.c @@ -42,7 +42,7 @@ int Tcl_RecordAndEval(interp, cmd, flags) Tcl_Interp *interp; /* Token for interpreter in which command * will be executed. */ - char *cmd; /* Command to record. */ + CONST char *cmd; /* Command to record. */ int flags; /* Additional flags. TCL_NO_EVAL means * only record: don't execute command. * TCL_EVAL_GLOBAL means use Tcl_GlobalEval diff --git a/tcl/generic/tclIO.c b/tcl/generic/tclIO.c index ab37a1b003d..997d21701c5 100644 --- a/tcl/generic/tclIO.c +++ b/tcl/generic/tclIO.c @@ -92,8 +92,7 @@ static int CopyAndTranslateBuffer _ANSI_ARGS_(( ChannelState *statePtr, char *result, int space)); static int CopyBuffer _ANSI_ARGS_(( - Channel *chanPtr, char *result, - int space)); + Channel *chanPtr, char *result, int space)); static int CopyData _ANSI_ARGS_((CopyState *csPtr, int mask)); static void CopyEventProc _ANSI_ARGS_((ClientData clientData, int mask)); @@ -104,28 +103,36 @@ static void DeleteChannelTable _ANSI_ARGS_(( ClientData clientData, Tcl_Interp *interp)); static void DeleteScriptRecord _ANSI_ARGS_((Tcl_Interp *interp, Channel *chanPtr, int mask)); +static int DetachChannel _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Channel chan)); static void DiscardInputQueued _ANSI_ARGS_((ChannelState *statePtr, int discardSavedBuffers)); static void DiscardOutputQueued _ANSI_ARGS_(( ChannelState *chanPtr)); static int DoRead _ANSI_ARGS_((Channel *chanPtr, char *srcPtr, int slen)); -static int DoWrite _ANSI_ARGS_((Channel *chanPtr, char *src, +static int DoWrite _ANSI_ARGS_((Channel *chanPtr, CONST char *src, int srcLen)); +static int DoReadChars _ANSI_ARGS_ ((Channel* chan, + Tcl_Obj* objPtr, int toRead, int appendFlag)); +static int DoWriteChars _ANSI_ARGS_ ((Channel* chan, + CONST char* src, int len)); static int FilterInputBytes _ANSI_ARGS_((Channel *chanPtr, GetsState *statePtr)); static int FlushChannel _ANSI_ARGS_((Tcl_Interp *interp, Channel *chanPtr, int calledFromAsyncFlush)); static Tcl_HashTable * GetChannelTable _ANSI_ARGS_((Tcl_Interp *interp)); static int GetInput _ANSI_ARGS_((Channel *chanPtr)); +static int HaveVersion _ANSI_ARGS_((Tcl_ChannelType *typePtr, + Tcl_ChannelTypeVersion minimumVersion)); static void PeekAhead _ANSI_ARGS_((Channel *chanPtr, char **dstEndPtr, GetsState *gsPtr)); static int ReadBytes _ANSI_ARGS_((ChannelState *statePtr, Tcl_Obj *objPtr, int charsLeft, int *offsetPtr)); static int ReadChars _ANSI_ARGS_((ChannelState *statePtr, - Tcl_Obj *objPtr, int charsLeft, int *offsetPtr, - int *factorPtr)); + Tcl_Obj *objPtr, int charsLeft, + int *offsetPtr, int *factorPtr)); static void RecycleBuffer _ANSI_ARGS_((ChannelState *statePtr, ChannelBuffer *bufPtr, int mustDiscard)); static int StackSetBlockMode _ANSI_ARGS_((Channel *chanPtr, @@ -134,11 +141,11 @@ static int SetBlockMode _ANSI_ARGS_((Tcl_Interp *interp, Channel *chanPtr, int mode)); static void StopCopy _ANSI_ARGS_((CopyState *csPtr)); static int TranslateInputEOL _ANSI_ARGS_((ChannelState *statePtr, - char *dst, CONST char *src, int *dstLenPtr, - int *srcLenPtr)); + char *dst, CONST char *src, + int *dstLenPtr, int *srcLenPtr)); static int TranslateOutputEOL _ANSI_ARGS_((ChannelState *statePtr, - char *dst, CONST char *src, int *dstLenPtr, - int *srcLenPtr)); + char *dst, CONST char *src, + int *dstLenPtr, int *srcLenPtr)); static void UpdateInterest _ANSI_ARGS_((Channel *chanPtr)); static int WriteBytes _ANSI_ARGS_((Channel *chanPtr, CONST char *src, int srcLen)); @@ -683,6 +690,38 @@ CheckForStdChannelsBeingClosed(chan) /* *---------------------------------------------------------------------- * + * Tcl_IsStandardChannel -- + * + * Test if the given channel is a standard channel. No attempt + * is made to check if the channel or the standard channels + * are initialized or otherwise valid. + * + * Results: + * Returns 1 if true, 0 if false. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +int +Tcl_IsStandardChannel(chan) + Tcl_Channel chan; /* Channel to check. */ +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + if ((chan == tsdPtr->stdinChannel) + || (chan == tsdPtr->stdoutChannel) + || (chan == tsdPtr->stderrChannel)) { + return 1; + } else { + return 0; + } +} + +/* + *---------------------------------------------------------------------- + * * Tcl_RegisterChannel -- * * Adds an already-open channel to the channel table of an interpreter. @@ -718,7 +757,7 @@ Tcl_RegisterChannel(interp, chan) chanPtr = ((Channel *) chan)->state->bottomChanPtr; statePtr = chanPtr->state; - if (statePtr->channelName == (char *) NULL) { + if (statePtr->channelName == (CONST char *) NULL) { panic("Tcl_RegisterChannel: channel without name"); } if (interp != (Tcl_Interp *) NULL) { @@ -743,13 +782,21 @@ Tcl_RegisterChannel(interp, chan) * * Deletes the hash entry for a channel associated with an interpreter. * If the interpreter given as argument is NULL, it only decrements the - * reference count. + * reference count. (This all happens in the Tcl_DetachChannel helper + * function). + * + * Finally, if the reference count of the channel drops to zero, + * it is deleted. * * Results: * A standard Tcl result. * * Side effects: - * Deletes the hash entry for a channel associated with an interpreter. + * Calls Tcl_DetachChannel which deletes the hash entry for a channel + * associated with an interpreter. + * + * May delete the channel, which can have a variety of consequences, + * especially if we are forced to close the channel. * *---------------------------------------------------------------------- */ @@ -759,46 +806,14 @@ Tcl_UnregisterChannel(interp, chan) Tcl_Interp *interp; /* Interpreter in which channel is defined. */ Tcl_Channel chan; /* Channel to delete. */ { - Tcl_HashTable *hTblPtr; /* Hash table of channels. */ - Tcl_HashEntry *hPtr; /* Search variable. */ - Channel *chanPtr; /* The real IO channel. */ ChannelState *statePtr; /* State of the real channel. */ - /* - * Always (un)register bottom-most channel in the stack. This makes - * management of the channel list easier because no manipulation is - * necessary during (un)stack operation. - */ - chanPtr = ((Channel *) chan)->state->bottomChanPtr; - statePtr = chanPtr->state; - - if (interp != (Tcl_Interp *) NULL) { - hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); - if (hTblPtr == (Tcl_HashTable *) NULL) { - return TCL_OK; - } - hPtr = Tcl_FindHashEntry(hTblPtr, statePtr->channelName); - if (hPtr == (Tcl_HashEntry *) NULL) { - return TCL_OK; - } - if ((Channel *) Tcl_GetHashValue(hPtr) != chanPtr) { - return TCL_OK; - } - Tcl_DeleteHashEntry(hPtr); - - /* - * Remove channel handlers that refer to this interpreter, so that they - * will not be present if the actual close is delayed and more events - * happen on the channel. This may occur if the channel is shared - * between several interpreters, or if the channel has async - * flushing active. - */ - - CleanupChannelHandlers(interp, chanPtr); + if (DetachChannel(interp, chan) != TCL_OK) { + return TCL_OK; } - - statePtr->refCount--; + statePtr = ((Channel *) chan)->state->bottomChanPtr->state; + /* * Perform special handling for standard channels being closed. If the * refCount is now 1 it means that the last reference to the standard @@ -825,15 +840,145 @@ Tcl_UnregisterChannel(interp, chan) statePtr->curOutPtr->nextRemoved)) { statePtr->flags |= BUFFER_READY; } - statePtr->flags |= CHANNEL_CLOSED; + Tcl_Preserve((ClientData)statePtr); if (!(statePtr->flags & BG_FLUSH_SCHEDULED)) { - if (Tcl_Close(interp, chan) != TCL_OK) { - return TCL_ERROR; - } + /* We don't want to re-enter Tcl_Close */ + if (!(statePtr->flags & CHANNEL_CLOSED)) { + if (Tcl_Close(interp, chan) != TCL_OK) { + statePtr->flags |= CHANNEL_CLOSED; + Tcl_Release((ClientData)statePtr); + return TCL_ERROR; + } + } } + statePtr->flags |= CHANNEL_CLOSED; + Tcl_Release((ClientData)statePtr); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DetachChannel -- + * + * Deletes the hash entry for a channel associated with an interpreter. + * If the interpreter given as argument is NULL, it only decrements the + * reference count. Even if the ref count drops to zero, the + * channel is NOT closed or cleaned up. This allows a channel to + * be detached from an interpreter and left in the same state it + * was in when it was originally returned by 'Tcl_OpenFileChannel', + * for example. + * + * This function cannot be used on the standard channels, and + * will return TCL_ERROR if that is attempted. + * + * This function should only be necessary for special purposes + * in which you need to generate a pristine channel from one + * that has already been used. All ordinary purposes will almost + * always want to use Tcl_UnregisterChannel instead. + * + * Provided the channel is not attached to any other interpreter, + * it can then be closed with Tcl_Close, rather than with + * Tcl_UnregisterChannel. + * + * Results: + * A standard Tcl result. If the channel is not currently registered + * with the given interpreter, TCL_ERROR is returned, otherwise + * TCL_OK. However no error messages are left in the interp's result. + * + * Side effects: + * Deletes the hash entry for a channel associated with an + * interpreter. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_DetachChannel(interp, chan) + Tcl_Interp *interp; /* Interpreter in which channel is defined. */ + Tcl_Channel chan; /* Channel to delete. */ +{ + if (Tcl_IsStandardChannel(chan)) { + return TCL_ERROR; + } + + return DetachChannel(interp, chan); +} + +/* + *---------------------------------------------------------------------- + * + * DetachChannel -- + * + * Deletes the hash entry for a channel associated with an interpreter. + * If the interpreter given as argument is NULL, it only decrements the + * reference count. Even if the ref count drops to zero, the + * channel is NOT closed or cleaned up. This allows a channel to + * be detached from an interpreter and left in the same state it + * was in when it was originally returned by 'Tcl_OpenFileChannel', + * for example. + * + * Results: + * A standard Tcl result. If the channel is not currently registered + * with the given interpreter, TCL_ERROR is returned, otherwise + * TCL_OK. However no error messages are left in the interp's result. + * + * Side effects: + * Deletes the hash entry for a channel associated with an + * interpreter. + * + *---------------------------------------------------------------------- + */ + +static int +DetachChannel(interp, chan) + Tcl_Interp *interp; /* Interpreter in which channel is defined. */ + Tcl_Channel chan; /* Channel to delete. */ +{ + Tcl_HashTable *hTblPtr; /* Hash table of channels. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + Channel *chanPtr; /* The real IO channel. */ + ChannelState *statePtr; /* State of the real channel. */ + + /* + * Always (un)register bottom-most channel in the stack. This makes + * management of the channel list easier because no manipulation is + * necessary during (un)stack operation. + */ + chanPtr = ((Channel *) chan)->state->bottomChanPtr; + statePtr = chanPtr->state; + + if (interp != (Tcl_Interp *) NULL) { + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(hTblPtr, statePtr->channelName); + if (hPtr == (Tcl_HashEntry *) NULL) { + return TCL_ERROR; + } + if ((Channel *) Tcl_GetHashValue(hPtr) != chanPtr) { + return TCL_ERROR; + } + Tcl_DeleteHashEntry(hPtr); + + /* + * Remove channel handlers that refer to this interpreter, so that they + * will not be present if the actual close is delayed and more events + * happen on the channel. This may occur if the channel is shared + * between several interpreters, or if the channel has async + * flushing active. + */ + + CleanupChannelHandlers(interp, chanPtr); } + + statePtr->refCount--; + return TCL_OK; } + /* *--------------------------------------------------------------------------- @@ -859,7 +1004,7 @@ Tcl_Channel Tcl_GetChannel(interp, chanName, modePtr) Tcl_Interp *interp; /* Interpreter in which to find or create * the channel. */ - char *chanName; /* The name of the channel. */ + CONST char *chanName; /* The name of the channel. */ int *modePtr; /* Where to store the mode in which the * channel was opened? Will contain an ORed * combination of TCL_READABLE and @@ -868,7 +1013,7 @@ Tcl_GetChannel(interp, chanName, modePtr) Channel *chanPtr; /* The actual channel. */ Tcl_HashTable *hTblPtr; /* Hash table of channels. */ Tcl_HashEntry *hPtr; /* Search variable. */ - char *name; /* Translated name. */ + CONST char *name; /* Translated name. */ /* * Substitute "stdin", etc. Note that even though we immediately @@ -937,7 +1082,7 @@ Tcl_GetChannel(interp, chanName, modePtr) Tcl_Channel Tcl_CreateChannel(typePtr, chanName, instanceData, mask) Tcl_ChannelType *typePtr; /* The channel type record. */ - char *chanName; /* Name of channel to record. */ + CONST char *chanName; /* Name of channel to record. */ ClientData instanceData; /* Instance specific data. */ int mask; /* TCL_READABLE & TCL_WRITABLE to indicate * if the channel is readable, writable. */ @@ -960,6 +1105,10 @@ Tcl_CreateChannel(typePtr, chanName, instanceData, mask) assert(sizeof(Tcl_ChannelTypeVersion) == sizeof(Tcl_DriverBlockModeProc*)); + /* + * JH: We could subsequently memset these to 0 to avoid the + * numerous assignments to 0/NULL below. + */ chanPtr = (Channel *) ckalloc((unsigned) sizeof(Channel)); statePtr = (ChannelState *) ckalloc((unsigned) sizeof(ChannelState)); chanPtr->state = statePtr; @@ -973,8 +1122,9 @@ Tcl_CreateChannel(typePtr, chanName, instanceData, mask) */ if (chanName != (char *) NULL) { - statePtr->channelName = ckalloc((unsigned) (strlen(chanName) + 1)); - strcpy(statePtr->channelName, chanName); + char *tmp = ckalloc((unsigned) (strlen(chanName) + 1)); + statePtr->channelName = tmp; + strcpy(tmp, chanName); } else { panic("Tcl_CreateChannel: NULL channel name"); } @@ -1044,10 +1194,20 @@ Tcl_CreateChannel(typePtr, chanName, instanceData, mask) * Link the channel into the list of all channels; create an on-exit * handler if there is not one already, to close off all the channels * in the list on exit. + * + * JH: Could call Tcl_SpliceChannel, but need to avoid NULL check. + */ + + statePtr->nextCSPtr = tsdPtr->firstCSPtr; + tsdPtr->firstCSPtr = statePtr; + + /* + * TIP #10. Mark the current thread as the one managing the new + * channel. Note: 'Tcl_GetCurrentThread' returns sensible + * values even for a non-threaded core. */ - statePtr->nextCSPtr = tsdPtr->firstCSPtr; - tsdPtr->firstCSPtr = statePtr; + statePtr->managingThread = Tcl_GetCurrentThread (); /* * Install this channel in the first empty standard channel slot, if @@ -1465,6 +1625,32 @@ Tcl_GetChannelInstanceData(chan) /* *---------------------------------------------------------------------- * + * Tcl_GetChannelThread -- + * + * Given a channel structure, returns the thread managing it. + * TIP #10 + * + * Results: + * Returns the id of the thread managing the channel. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_ThreadId +Tcl_GetChannelThread(chan) + Tcl_Channel chan; /* The channel to return managing thread for. */ +{ + Channel *chanPtr = (Channel *) chan; /* The actual channel. */ + + return chanPtr->state->managingThread; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_GetChannelType -- * * Given a channel structure, returns the channel type structure. @@ -1533,7 +1719,7 @@ Tcl_GetChannelMode(chan) *---------------------------------------------------------------------- */ -char * +CONST char * Tcl_GetChannelName(chan) Tcl_Channel chan; /* The channel for which to return the name. */ { @@ -1657,6 +1843,17 @@ RecycleBuffer(statePtr, bufPtr, mustDiscard) } /* + * Only save buffers which are at least as big as the requested + * buffersize for the channel. This is to honor dynamic changes + * of the buffersize made by the user. + */ + + if ((bufPtr->bufLength - BUFFER_PADDING) < statePtr->bufSize) { + ckfree((char *) bufPtr); + return; + } + + /* * Only save buffers for the input queue if the channel is readable. */ @@ -1865,7 +2062,7 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush) toWrite = bufPtr->nextAdded - bufPtr->nextRemoved; written = (chanPtr->typePtr->outputProc) (chanPtr->instanceData, - (char *) bufPtr->buf + bufPtr->nextRemoved, toWrite, + bufPtr->buf + bufPtr->nextRemoved, toWrite, &errorCode); /* @@ -1916,8 +2113,15 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush) } else { Tcl_SetErrno(errorCode); if (interp != NULL) { + + /* + * Casting away CONST here is safe because the + * TCL_VOLATILE flag guarantees CONST treatment + * of the Posix error string. + */ + Tcl_SetResult(interp, - Tcl_PosixError(interp), TCL_VOLATILE); + (char *) Tcl_PosixError(interp), TCL_VOLATILE); } } @@ -2012,9 +2216,6 @@ CloseChannel(interp, chanPtr, errorCode) { int result = 0; /* Of calling driver close * operation. */ - ChannelState *prevCSPtr; /* Preceding channel state in list of - * all states - used to splice a - * channel out of the list on close. */ ChannelState *statePtr; /* state of the channel stack. */ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -2059,38 +2260,11 @@ CloseChannel(interp, chanPtr, errorCode) c = (char) statePtr->outEofChar; (chanPtr->typePtr->outputProc) (chanPtr->instanceData, &c, 1, &dummy); } -#if 0 - /* - * Remove TCL_READABLE and TCL_WRITABLE from statePtr->flags, so - * that close callbacks can not do input or output (assuming they - * squirreled the channel away in their clientData). This also - * prevents infinite loops if the callback calls any C API that - * could call FlushChannel. - */ /* - * This prevents any data from being flushed from stacked channels. + * Remove this channel from of the list of all channels. */ - statePtr->flags &= (~(TCL_READABLE|TCL_WRITABLE)); -#endif - - /* - * Splice this channel out of the list of all channels. - */ - - if (tsdPtr->firstCSPtr && (statePtr == tsdPtr->firstCSPtr)) { - tsdPtr->firstCSPtr = statePtr->nextCSPtr; - } else { - for (prevCSPtr = tsdPtr->firstCSPtr; - prevCSPtr && (prevCSPtr->nextCSPtr != statePtr); - prevCSPtr = prevCSPtr->nextCSPtr) { - /* Empty loop body. */ - } - if (prevCSPtr == (ChannelState *) NULL) { - panic("FlushChannel: damaged channel list"); - } - prevCSPtr->nextCSPtr = statePtr->nextCSPtr; - } + Tcl_CutChannel((Tcl_Channel) chanPtr); /* * Close and free the channel driver state. @@ -2111,7 +2285,7 @@ CloseChannel(interp, chanPtr, errorCode) if (chanPtr == statePtr->bottomChanPtr) { if (statePtr->channelName != (char *) NULL) { - ckfree(statePtr->channelName); + ckfree((char *) statePtr->channelName); statePtr->channelName = NULL; } @@ -2148,23 +2322,6 @@ CloseChannel(interp, chanPtr, errorCode) */ if (chanPtr->downChanPtr != (Channel *) NULL) { -#if 0 - int code = TCL_OK; - - while (chanPtr->downChanPtr != (Channel *) NULL) { - /* - * Unwind the state of the transformation, and then restore the - * state of (unstack) the underlying channel into the TOP channel - * structure. - */ - code = Tcl_UnstackChannel(interp, (Tcl_Channel) chanPtr); - if (code == TCL_ERROR) { - errorCode = Tcl_GetErrno(); - break; - } - chanPtr = chanPtr->downChanPtr; - } -#else Channel *downChanPtr = chanPtr->downChanPtr; statePtr->nextCSPtr = tsdPtr->firstCSPtr; @@ -2176,15 +2333,18 @@ CloseChannel(interp, chanPtr, errorCode) Tcl_EventuallyFree((ClientData) chanPtr, TCL_DYNAMIC); return Tcl_Close(interp, (Tcl_Channel) downChanPtr); -#endif } /* * There is only the TOP Channel, so we free the remaining - * pointers we have and then ourselves. + * pointers we have and then ourselves. Since this is the + * last of the channels in the stack, make sure to free the + * ChannelState structure associated with it. We use + * Tcl_EventuallyFree to allow for any last */ chanPtr->typePtr = NULL; + Tcl_EventuallyFree((ClientData) statePtr, TCL_DYNAMIC); Tcl_EventuallyFree((ClientData) chanPtr, TCL_DYNAMIC); return errorCode; @@ -2193,6 +2353,118 @@ CloseChannel(interp, chanPtr, errorCode) /* *---------------------------------------------------------------------- * + * Tcl_CutChannel -- + * + * Removes a channel from the (thread-)global list of all channels + * (in that thread). This is actually the statePtr for the stack + * of channel. + * + * Results: + * Nothing. + * + * Side effects: + * Resets the field 'nextCSPtr' of the specified channel state to NULL. + * + * NOTE: + * The channel to splice out of the list must not be referenced + * in any interpreter. This is something this procedure cannot + * check (despite the refcount) because the caller usually wants + * fiddle with the channel (like transfering it to a different + * thread) and thus keeps the refcount artifically high to prevent + * its destruction. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_CutChannel(chan) + Tcl_Channel chan; /* The channel being removed. Must + * not be referenced in any + * interpreter. */ +{ + ThreadSpecificData* tsdPtr = TCL_TSD_INIT(&dataKey); + ChannelState *prevCSPtr; /* Preceding channel state in list of + * all states - used to splice a + * channel out of the list on close. */ + ChannelState *statePtr = ((Channel *) chan)->state; + /* state of the channel stack. */ + + /* + * Remove this channel from of the list of all channels + * (in the current thread). + */ + + if (tsdPtr->firstCSPtr && (statePtr == tsdPtr->firstCSPtr)) { + tsdPtr->firstCSPtr = statePtr->nextCSPtr; + } else { + for (prevCSPtr = tsdPtr->firstCSPtr; + prevCSPtr && (prevCSPtr->nextCSPtr != statePtr); + prevCSPtr = prevCSPtr->nextCSPtr) { + /* Empty loop body. */ + } + if (prevCSPtr == (ChannelState *) NULL) { + panic("FlushChannel: damaged channel list"); + } + prevCSPtr->nextCSPtr = statePtr->nextCSPtr; + } + + statePtr->nextCSPtr = (ChannelState *) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SpliceChannel -- + * + * Adds a channel to the (thread-)global list of all channels + * (in that thread). Expects that the field 'nextChanPtr' in + * the channel is set to NULL. + * + * Results: + * Nothing. + * + * Side effects: + * Nothing. + * + * NOTE: + * The channel to add to the list must not be referenced in any + * interpreter. This is something this procedure cannot check + * (despite the refcount) because the caller usually wants figgle + * with the channel (like transfering it to a different thread) + * and thus keeps the refcount artifically high to prevent its + * destruction. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SpliceChannel(chan) + Tcl_Channel chan; /* The channel being added. Must + * not be referenced in any + * interpreter. */ +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + ChannelState *statePtr = ((Channel *) chan)->state; + + if (statePtr->nextCSPtr != (ChannelState *) NULL) { + panic("Tcl_SpliceChannel: trying to add channel used in different list"); + } + + statePtr->nextCSPtr = tsdPtr->firstCSPtr; + tsdPtr->firstCSPtr = statePtr; + + /* + * TIP #10. Mark the current thread as the new one managing this + * channel. Note: 'Tcl_GetCurrentThread' returns sensible + * values even for a non-threaded core. + */ + + statePtr->managingThread = Tcl_GetCurrentThread (); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_Close -- * * Closes a channel. @@ -2220,15 +2492,11 @@ Tcl_Close(interp, chan) * not be referenced in any * interpreter. */ { - ChannelHandler *chPtr, *chNext; /* Iterate over channel handlers. */ CloseCallback *cbPtr; /* Iterate over close callbacks * for this channel. */ - EventScriptRecord *ePtr, *eNextPtr; /* Iterate over eventscript records. */ Channel *chanPtr; /* The real IO channel. */ ChannelState *statePtr; /* State of real IO channel. */ int result; /* Of calling FlushChannel. */ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - NextChannelHandler *nhPtr; if (chan == (Tcl_Channel) NULL) { return TCL_OK; @@ -2257,6 +2525,100 @@ Tcl_Close(interp, chan) } /* + * When the channel has an escape sequence driven encoding such as + * iso2022, the terminated escape sequence must write to the buffer. + */ + if ((statePtr->encoding != NULL) && (statePtr->curOutPtr != NULL) + && (CheckChannelErrors(statePtr, TCL_WRITABLE) == 0)) { + statePtr->outputEncodingFlags |= TCL_ENCODING_END; + WriteChars(chanPtr, "", 0); + } + + Tcl_ClearChannelHandlers(chan); + + /* + * Invoke the registered close callbacks and delete their records. + */ + + while (statePtr->closeCbPtr != (CloseCallback *) NULL) { + cbPtr = statePtr->closeCbPtr; + statePtr->closeCbPtr = cbPtr->nextPtr; + (cbPtr->proc) (cbPtr->clientData); + ckfree((char *) cbPtr); + } + + /* + * Ensure that the last output buffer will be flushed. + */ + + if ((statePtr->curOutPtr != (ChannelBuffer *) NULL) && + (statePtr->curOutPtr->nextAdded > statePtr->curOutPtr->nextRemoved)) { + statePtr->flags |= BUFFER_READY; + } + + /* + * If this channel supports it, close the read side, since we don't need it + * anymore and this will help avoid deadlocks on some channel types. + */ + + if (chanPtr->typePtr->closeProc == TCL_CLOSE2PROC) { + result = (chanPtr->typePtr->close2Proc)(chanPtr->instanceData, interp, + TCL_CLOSE_READ); + } else { + result = 0; + } + + /* + * The call to FlushChannel will flush any queued output and invoke + * the close function of the channel driver, or it will set up the + * channel to be flushed and closed asynchronously. + */ + + statePtr->flags |= CHANNEL_CLOSED; + if ((FlushChannel(interp, chanPtr, 0) != 0) || (result != 0)) { + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ClearChannelHandlers -- + * + * Removes all channel handlers and event scripts from the channel, + * cancels all background copies involving the channel and any interest + * in events. + * + * Results: + * None. + * + * Side effects: + * See above. Deallocates memory. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_ClearChannelHandlers (channel) + Tcl_Channel channel; +{ + ChannelHandler *chPtr, *chNext; /* Iterate over channel handlers. */ + EventScriptRecord *ePtr, *eNextPtr; /* Iterate over eventscript records. */ + Channel *chanPtr; /* The real IO channel. */ + ChannelState *statePtr; /* State of real IO channel. */ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + NextChannelHandler *nhPtr; + + /* + * This operation should occur at the top of a channel stack. + */ + + chanPtr = (Channel *) channel; + statePtr = chanPtr->state; + chanPtr = statePtr->topChanPtr; + + /* * Remove any references to channel handlers for this channel that * may be about to be invoked. */ @@ -2310,50 +2672,6 @@ Tcl_Close(interp, chan) ckfree((char *) ePtr); } statePtr->scriptRecordPtr = (EventScriptRecord *) NULL; - - /* - * Invoke the registered close callbacks and delete their records. - */ - - while (statePtr->closeCbPtr != (CloseCallback *) NULL) { - cbPtr = statePtr->closeCbPtr; - statePtr->closeCbPtr = cbPtr->nextPtr; - (cbPtr->proc) (cbPtr->clientData); - ckfree((char *) cbPtr); - } - - /* - * Ensure that the last output buffer will be flushed. - */ - - if ((statePtr->curOutPtr != (ChannelBuffer *) NULL) && - (statePtr->curOutPtr->nextAdded > statePtr->curOutPtr->nextRemoved)) { - statePtr->flags |= BUFFER_READY; - } - - /* - * If this channel supports it, close the read side, since we don't need it - * anymore and this will help avoid deadlocks on some channel types. - */ - - if (chanPtr->typePtr->closeProc == TCL_CLOSE2PROC) { - result = (chanPtr->typePtr->close2Proc)(chanPtr->instanceData, interp, - TCL_CLOSE_READ); - } else { - result = 0; - } - - /* - * The call to FlushChannel will flush any queued output and invoke - * the close function of the channel driver, or it will set up the - * channel to be flushed and closed asynchronously. - */ - - statePtr->flags |= CHANNEL_CLOSED; - if ((FlushChannel(interp, chanPtr, 0) != 0) || (result != 0)) { - return TCL_ERROR; - } - return TCL_OK; } /* @@ -2364,7 +2682,10 @@ Tcl_Close(interp, chan) * Puts a sequence of bytes into an output buffer, may queue the * buffer for output if it gets full, and also remembers whether the * current buffer is ready e.g. if it contains a newline and we are in - * line buffering mode. + * line buffering mode. Compensates stacking, i.e. will redirect the + * data from the specified channel to the topmost channel in a stack. + * + * No encoding conversions are applied to the bytes being read. * * Results: * The number of bytes written or -1 in case of error. If -1, @@ -2380,7 +2701,7 @@ Tcl_Close(interp, chan) int Tcl_Write(chan, src, srcLen) Tcl_Channel chan; /* The channel to buffer output for. */ - char *src; /* Data to queue in output buffer. */ + CONST char *src; /* Data to queue in output buffer. */ int srcLen; /* Length of data in bytes, or < 0 for * strlen(). */ { @@ -2411,7 +2732,10 @@ Tcl_Write(chan, src, srcLen) * Puts a sequence of bytes into an output buffer, may queue the * buffer for output if it gets full, and also remembers whether the * current buffer is ready e.g. if it contains a newline and we are in - * line buffering mode. + * line buffering mode. Writes directly to the driver of the channel, + * does not compensate for stacking. + * + * No encoding conversions are applied to the bytes being read. * * Results: * The number of bytes written or -1 in case of error. If -1, @@ -2427,7 +2751,7 @@ Tcl_Write(chan, src, srcLen) int Tcl_WriteRaw(chan, src, srcLen) Tcl_Channel chan; /* The channel to buffer output for. */ - char *src; /* Data to queue in output buffer. */ + CONST char *src; /* Data to queue in output buffer. */ int srcLen; /* Length of data in bytes, or < 0 for * strlen(). */ { @@ -2467,7 +2791,8 @@ Tcl_WriteRaw(chan, src, srcLen) * using the channel's current encoding, may queue the buffer for * output if it gets full, and also remembers whether the current * buffer is ready e.g. if it contains a newline and we are in - * line buffering mode. + * line buffering mode. Compensates stacking, i.e. will redirect the + * data from the specified channel to the topmost channel in a stack. * * Results: * The number of bytes written or -1 in case of error. If -1, @@ -2487,18 +2812,55 @@ Tcl_WriteChars(chan, src, len) int len; /* Length of string in bytes, or < 0 for * strlen(). */ { - /* - * Always use the topmost channel of the stack - */ - Channel *chanPtr; ChannelState *statePtr; /* state info for channel */ statePtr = ((Channel *) chan)->state; - chanPtr = statePtr->topChanPtr; if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) { return -1; } + + return DoWriteChars ((Channel*) chan, src, len); +} + +/* + *--------------------------------------------------------------------------- + * + * DoWriteChars -- + * + * Takes a sequence of UTF-8 characters and converts them for output + * using the channel's current encoding, may queue the buffer for + * output if it gets full, and also remembers whether the current + * buffer is ready e.g. if it contains a newline and we are in + * line buffering mode. Compensates stacking, i.e. will redirect the + * data from the 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. + * + * Side effects: + * May buffer up output and may cause output to be produced on the + * channel. + * + *---------------------------------------------------------------------- + */ + +static int +DoWriteChars(chanPtr, src, len) + Channel* chanPtr; /* The channel to buffer output for. */ + CONST char *src; /* UTF-8 characters to queue in output buffer. */ + int len; /* Length of string in bytes, or < 0 for + * strlen(). */ +{ + /* + * Always use the topmost channel of the stack + */ + ChannelState *statePtr; /* state info for channel */ + + statePtr = chanPtr->state; + chanPtr = statePtr->topChanPtr; + if (len < 0) { len = strlen(src); } @@ -2603,7 +2965,7 @@ WriteBytes(chanPtr, src, srcLen) ChannelState *statePtr = chanPtr->state; /* state info for channel */ ChannelBuffer *bufPtr; char *dst; - int dstLen, dstMax, sawLF, savedLF, total, toWrite; + int dstMax, sawLF, savedLF, total, dstLen, toWrite; total = 0; sawLF = 0; @@ -2691,8 +3053,9 @@ WriteChars(chanPtr, src, srcLen) ChannelState *statePtr = chanPtr->state; /* state info for channel */ ChannelBuffer *bufPtr; char *dst, *stage; - int saved, savedLF, sawLF, total, toWrite, flags; - int dstWrote, dstLen, stageLen, stageMax, stageRead; + int saved, savedLF, sawLF, total, dstLen, stageMax, dstWrote; + int stageLen, toWrite, stageRead, endEncoding, result; + int consumedSomething; Tcl_Encoding encoding; char safe[BUFFER_PADDING]; @@ -2703,11 +3066,19 @@ WriteChars(chanPtr, src, srcLen) encoding = statePtr->encoding; /* + * Write the terminated escape sequence even if srcLen is 0. + */ + + endEncoding = ((statePtr->outputEncodingFlags & TCL_ENCODING_END) != 0); + + /* * Loop over all UTF-8 characters in src, storing them in staging buffer * with proper EOL translation. */ - while (srcLen + savedLF > 0) { + consumedSomething = 1; + while (consumedSomething && (srcLen + savedLF + endEncoding > 0)) { + consumedSomething = 0; stage = statePtr->outputStage; stageMax = statePtr->bufSize; stageLen = stageMax; @@ -2742,17 +3113,12 @@ WriteChars(chanPtr, src, srcLen) src += toWrite; srcLen -= toWrite; - flags = statePtr->outputEncodingFlags; - if (srcLen == 0) { - flags |= TCL_ENCODING_END; - } - /* * Loop over all UTF-8 characters in staging buffer, converting them * to external encoding, storing them in output buffer. */ - while (stageLen + saved > 0) { + while (stageLen + saved + endEncoding > 0) { bufPtr = statePtr->curOutPtr; if (bufPtr == NULL) { bufPtr = AllocChannelBuffer(statePtr->bufSize); @@ -2775,10 +3141,31 @@ WriteChars(chanPtr, src, srcLen) saved = 0; } - Tcl_UtfToExternal(NULL, encoding, stage, stageLen, flags, + result = Tcl_UtfToExternal(NULL, encoding, stage, stageLen, + statePtr->outputEncodingFlags, &statePtr->outputEncodingState, dst, dstLen + BUFFER_PADDING, &stageRead, &dstWrote, NULL); - if (stageRead + dstWrote == 0) { + + /* Fix for SF #506297, reported by Martin Forssen + * <ruric@users.sourceforge.net>. + * + * The encoding chosen in the script exposing the bug writes out + * three intro characters when TCL_ENCODING_START is set, but does + * not consume any input as TCL_ENCODING_END is cleared. As some + * output was generated the enclosing loop calls UtfToExternal + * again, again with START set. Three more characters in the out + * and still no use of input ... To break this infinite loop we + * remove TCL_ENCODING_START from the set of flags after the first + * call (no condition is required, the later calls remove an unset + * flag, which is a no-op). This causes the subsequent calls to + * UtfToExternal to consume and convert the actual input. + */ + + statePtr->outputEncodingFlags &= ~TCL_ENCODING_START; + /* + * The following code must be executed only when result is not 0. + */ + if (result && ((stageRead + dstWrote) == 0)) { /* * We have an incomplete UTF-8 character at the end of the * staging buffer. It will get moved to the beginning of the @@ -2814,8 +3201,29 @@ WriteChars(chanPtr, src, srcLen) stage += stageRead; stageLen -= stageRead; sawLF = 0; + + consumedSomething = 1; + + /* + * If all translated characters are written to the buffer, + * endEncoding is set to 0 because the escape sequence may be + * output. + */ + + if ((stageLen + saved == 0) && (result == 0)) { + endEncoding = 0; + } } } + + /* If nothing was written and it happened because there was no progress + * in the UTF conversion, we throw an error. + */ + + if (!consumedSomething && (total == 0)) { + Tcl_SetErrno (EINVAL); + return -1; + } return total; } @@ -3075,11 +3483,10 @@ Tcl_GetsObj(chan, objPtr) Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; /* state info for channel */ ChannelBuffer *bufPtr; - int inEofChar, skip, copiedTotal; + int inEofChar, skip, copiedTotal, oldLength, oldFlags, oldRemoved; Tcl_Encoding encoding; char *dst, *dstEnd, *eol, *eof; Tcl_EncodingState oldState; - int oldLength, oldFlags, oldRemoved; /* * This operation should occur at the top of a channel stack. @@ -3288,13 +3695,13 @@ Tcl_GetsObj(chan, objPtr) if (statePtr->flags & CHANNEL_EOF) { skip = 0; eol = dstEnd; - if (eol == objPtr->bytes) { + if (eol == objPtr->bytes + oldLength) { /* - * If we didn't produce any bytes before encountering EOF, + * If we didn't append any bytes before encountering EOF, * caller needs to see -1. */ - Tcl_SetObjLength(objPtr, 0); + Tcl_SetObjLength(objPtr, oldLength); CommonGetsCleanup(chanPtr, encoding); copiedTotal = -1; goto done; @@ -3317,8 +3724,9 @@ Tcl_GetsObj(chan, objPtr) statePtr->inputEncodingState = gs.state; Tcl_ExternalToUtf(NULL, gs.encoding, bufPtr->buf + bufPtr->nextRemoved, gs.rawRead, statePtr->inputEncodingFlags, - &statePtr->inputEncodingState, dst, eol - dst + skip + TCL_UTF_MAX, - &gs.rawRead, NULL, &gs.charsWrote); + &statePtr->inputEncodingState, dst, + eol - dst + skip + TCL_UTF_MAX, &gs.rawRead, NULL, + &gs.charsWrote); bufPtr->nextRemoved += gs.rawRead; /* @@ -3409,7 +3817,7 @@ FilterInputBytes(chanPtr, gsPtr) char *dst; int offset, toRead, dstNeeded, spaceLeft, result, rawLen, length; Tcl_Obj *objPtr; -#define ENCODING_LINESIZE 30 /* Lower bound on how many bytes to convert +#define ENCODING_LINESIZE 20 /* Lower bound on how many bytes to convert * at a time. Since we don't know a priori * how many bytes of storage this many source * bytes will use, we actually need at least @@ -3438,7 +3846,7 @@ FilterInputBytes(chanPtr, gsPtr) * seen EOL. Need to read more bytes from the channel device. * Side effect is to allocate another channel buffer. */ - + read: if (statePtr->flags & CHANNEL_BLOCKED) { if (statePtr->flags & CHANNEL_NONBLOCKING) { @@ -3491,7 +3899,14 @@ FilterInputBytes(chanPtr, gsPtr) result = Tcl_ExternalToUtf(NULL, gsPtr->encoding, raw, rawLen, statePtr->inputEncodingFlags, &statePtr->inputEncodingState, dst, spaceLeft, &gsPtr->rawRead, &gsPtr->bytesWrote, - &gsPtr->charsWrote); + &gsPtr->charsWrote); + + /* + * Make sure that if we go through 'gets', that we reset the + * TCL_ENCODING_START flag still. [Bug #523988] + */ + statePtr->inputEncodingFlags &= ~TCL_ENCODING_START; + if (result == TCL_CONVERT_MULTIBYTE) { /* * The last few bytes in this channel buffer were the start of a @@ -3762,7 +4177,7 @@ Tcl_Read(chan, dst, bytesToRead) int Tcl_ReadRaw(chan, bufPtr, bytesToRead) Tcl_Channel chan; /* The channel from which to read. */ - char *bufPtr; /* Where to store input read. */ + char *bufPtr; /* Where to store input read. */ int bytesToRead; /* Maximum number of bytes to read. */ { Channel *chanPtr = (Channel *) chan; @@ -3806,17 +4221,23 @@ Tcl_ReadRaw(chan, bufPtr, bytesToRead) statePtr->flags &= (~(CHANNEL_BLOCKED)); } - /* - * Now go to the driver to get as much as is possible to - * fill the remaining request. Do all the error handling - * by ourselves. The code was stolen from 'GetInput' and - * slightly adapted (different return value here). - * - * The case of 'bytesToRead == 0' at this point cannot happen. - */ - - nread = (chanPtr->typePtr->inputProc)(chanPtr->instanceData, + if ((statePtr->flags & CHANNEL_TIMER_FEV) && + (statePtr->flags & CHANNEL_NONBLOCKING)) { + nread = -1; + result = EWOULDBLOCK; + } else { + /* + * Now go to the driver to get as much as is possible to + * fill the remaining request. Do all the error handling + * by ourselves. The code was stolen from 'GetInput' and + * slightly adapted (different return value here). + * + * The case of 'bytesToRead == 0' at this point cannot happen. + */ + + nread = (chanPtr->typePtr->inputProc)(chanPtr->instanceData, bufPtr + copied, bytesToRead - copied, &result); + } if (nread > 0) { /* * If we get a short read, signal up that we may be @@ -3893,12 +4314,8 @@ Tcl_ReadChars(chan, objPtr, toRead, appendFlag) * of the object. */ { - Channel *chanPtr = (Channel *) chan; - ChannelState *statePtr = chanPtr->state; /* state info for channel */ - ChannelBuffer *bufPtr; - int offset, factor, copied, copiedNow, result; - Tcl_Encoding encoding; -#define UTF_EXPANSION_FACTOR 1024 + Channel* chanPtr = (Channel *) chan; + ChannelState* statePtr = chanPtr->state; /* state info for channel */ /* * This operation should occur at the top of a channel stack. @@ -3907,12 +4324,64 @@ Tcl_ReadChars(chan, objPtr, toRead, appendFlag) chanPtr = statePtr->topChanPtr; if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) { - copied = -1; - goto done; + /* + * Update the notifier state so we don't block while there is still + * data in the buffers. + */ + UpdateInterest(chanPtr); + return -1; } + return DoReadChars (chanPtr, objPtr, toRead, appendFlag); +} +/* + *--------------------------------------------------------------------------- + * + * DoReadChars -- + * + * Reads from the channel until the requested number of characters + * have been seen, EOF is seen, or the channel would block. EOL + * and EOF translation is done. If reading binary data, the raw + * bytes are wrapped in a Tcl byte array object. Otherwise, the raw + * bytes are converted to UTF-8 using the channel's current encoding + * and stored in a Tcl string object. + * + * Results: + * The number of characters read, or -1 on error. Use Tcl_GetErrno() + * to retrieve the error code for the error that occurred. + * + * Side effects: + * May cause input to be buffered. + * + *--------------------------------------------------------------------------- + */ + +static int +DoReadChars(chanPtr, objPtr, toRead, appendFlag) + 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 when channel blocks). */ + int appendFlag; /* If non-zero, data read from the channel + * will be appended to the object. Otherwise, + * the data will replace the existing contents + * of the object. */ + +{ + ChannelState *statePtr = chanPtr->state; /* state info for channel */ + ChannelBuffer *bufPtr; + int offset, factor, copied, copiedNow, result; + Tcl_Encoding encoding; +#define UTF_EXPANSION_FACTOR 1024 + + /* + * This operation should occur at the top of a channel stack. + */ + + chanPtr = statePtr->topChanPtr; encoding = statePtr->encoding; - factor = UTF_EXPANSION_FACTOR; + factor = UTF_EXPANSION_FACTOR; if (appendFlag == 0) { if (encoding == NULL) { @@ -3951,7 +4420,7 @@ Tcl_ReadChars(chan, objPtr, toRead, appendFlag) RecycleBuffer(statePtr, bufPtr, 0); statePtr->inQueueHead = nextPtr; if (nextPtr == NULL) { - statePtr->inQueueTail = nextPtr; + statePtr->inQueueTail = NULL; } } } @@ -4023,25 +4492,25 @@ Tcl_ReadChars(chan, objPtr, toRead, appendFlag) static int ReadBytes(statePtr, objPtr, bytesToRead, offsetPtr) ChannelState *statePtr; /* State of the channel to read. */ - int bytesToRead; /* Maximum number of characters to store, - * or < 0 to get all available characters. - * Characters are obtained from the first - * buffer in the queue -- even if this number - * is larger than the number of characters - * available in the first buffer, only the - * characters from the first buffer are - * returned. */ Tcl_Obj *objPtr; /* Input data is appended to this ByteArray * object. Its length is how much space * has been allocated to hold data, not how * many bytes of data have been stored in the * object. */ + int bytesToRead; /* Maximum number of bytes to store, + * or < 0 to get all available bytes. + * Bytes are obtained from the first + * buffer in the queue -- even if this number + * is larger than the number of bytes + * available in the first buffer, only the + * bytes from the first buffer are + * returned. */ int *offsetPtr; /* On input, contains how many bytes of * objPtr have been used to hold data. On * output, filled with how many bytes are now * being used. */ { - int toRead, srcLen, srcRead, dstWrote, offset, length; + int toRead, srcLen, offset, length, srcRead, dstWrote; ChannelBuffer *bufPtr; char *src, *dst; @@ -4127,6 +4596,10 @@ ReadBytes(statePtr, objPtr, bytesToRead, offsetPtr) static int ReadChars(statePtr, objPtr, charsToRead, offsetPtr, factorPtr) ChannelState *statePtr; /* State of channel to read. */ + Tcl_Obj *objPtr; /* Input data is appended to this object. + * objPtr->length is how much space has been + * allocated to hold data, not how many bytes + * of data have been stored in the object. */ int charsToRead; /* Maximum number of characters to store, * or -1 to get all available characters. * Characters are obtained from the first @@ -4135,10 +4608,6 @@ ReadChars(statePtr, objPtr, charsToRead, offsetPtr, factorPtr) * available in the first buffer, only the * characters from the first buffer are * returned. */ - Tcl_Obj *objPtr; /* Input data is appended to this object. - * objPtr->length is how much space has been - * allocated to hold data, not how many bytes - * of data have been stored in the object. */ int *offsetPtr; /* On input, contains how many bytes of * objPtr have been used to hold data. On * output, filled with how many bytes are now @@ -4149,8 +4618,8 @@ ReadChars(statePtr, objPtr, charsToRead, offsetPtr, factorPtr) * UTF-8. On output, contains another guess * based on the data seen so far. */ { - int toRead, factor, offset, spaceLeft, length; - int srcLen, srcRead, dstNeeded, dstRead, dstWrote, numChars; + int toRead, factor, offset, spaceLeft, length, srcLen, dstNeeded; + int srcRead, dstWrote, numChars, dstRead; ChannelBuffer *bufPtr; char *src, *dst; Tcl_EncodingState oldState; @@ -4163,7 +4632,7 @@ ReadChars(statePtr, objPtr, charsToRead, offsetPtr, factorPtr) srcLen = bufPtr->nextAdded - bufPtr->nextRemoved; toRead = charsToRead; - if ((unsigned) toRead > (unsigned) srcLen) { + if ((unsigned)toRead > (unsigned)srcLen) { toRead = srcLen; } @@ -4245,13 +4714,23 @@ ReadChars(statePtr, objPtr, charsToRead, offsetPtr, factorPtr) nextPtr = bufPtr->nextPtr; if (nextPtr == NULL) { - /* - * There isn't enough data in the buffers to complete the next - * character, so we need to wait for more data before the next - * file event can be delivered. - */ + if (srcLen > 0) { + /* + * There isn't enough data in the buffers to complete the next + * character, so we need to wait for more data before the next + * file event can be delivered. + * + * SF #478856. + * + * The exception to this is if the input buffer was + * completely empty before we tried to convert its + * contents. Nothing in, nothing out, and no incomplete + * character data. The conversion before the current one + * was complete. + */ - statePtr->flags |= CHANNEL_NEED_MORE_DATA; + statePtr->flags |= CHANNEL_NEED_MORE_DATA; + } return -1; } nextPtr->nextRemoved -= srcLen; @@ -4266,7 +4745,9 @@ ReadChars(statePtr, objPtr, charsToRead, offsetPtr, factorPtr) if (TranslateInputEOL(statePtr, dst, dst, &dstWrote, &dstRead) != 0) { /* * Hit EOF char. How many bytes of src correspond to where the - * EOF was located in dst? + * EOF was located in dst? Run the conversion again with an + * output buffer just big enough to hold the data so we can + * get the correct value for srcRead. */ if (dstWrote == 0) { @@ -4292,7 +4773,7 @@ ReadChars(statePtr, objPtr, charsToRead, offsetPtr, factorPtr) * Got too many chars. */ - char *eof; + CONST char *eof; eof = Tcl_UtfAtIndex(dst, toRead); statePtr->inputEncodingState = oldState; @@ -4505,7 +4986,7 @@ TranslateInputEOL(statePtr, dstStart, srcStart, dstLenPtr, srcLenPtr) int Tcl_Ungets(chan, str, len, atEnd) Tcl_Channel chan; /* The channel for which to add the input. */ - char *str; /* The input itself. */ + CONST char *str; /* The input itself. */ int len; /* The length of the input. */ int atEnd; /* If non-zero, add at end of queue; otherwise * add at head of queue. */ @@ -4754,12 +5235,39 @@ GetInput(chanPtr) } else { bufPtr = statePtr->saveInBufPtr; statePtr->saveInBufPtr = NULL; + + /* + * Check the actual buffersize against the requested + * buffersize. Buffers which are smaller than requested are + * squashed. This is done to honor dynamic changes of the + * buffersize made by the user. + */ + + if ((bufPtr != NULL) && ((bufPtr->bufLength - BUFFER_PADDING) < statePtr->bufSize)) { + ckfree((char *) bufPtr); + bufPtr = NULL; + } + if (bufPtr == NULL) { bufPtr = AllocChannelBuffer(statePtr->bufSize); } bufPtr->nextPtr = (ChannelBuffer *) NULL; - toRead = statePtr->bufSize; + /* SF #427196: Use the actual size of the buffer to determine + * the number of bytes to read from the channel and not the + * size for new buffers. They can be different if the + * buffersize was changed between reads. + * + * Note: This affects performance negatively if the buffersize + * was extended but this small buffer is reused for all + * subsequent reads. The system never uses buffers with the + * requested bigger size in that case. An adjunct patch could + * try and delete all unused buffers it encounters and which + * are smaller than the formally requested buffersize. + */ + + toRead = bufPtr->bufLength - bufPtr->nextAdded; + if (statePtr->inQueueTail == NULL) { statePtr->inQueueHead = bufPtr; } else { @@ -4767,7 +5275,7 @@ GetInput(chanPtr) } statePtr->inQueueTail = bufPtr; } - + /* * If EOF is set, we should avoid calling the driver because on some * platforms it is impossible to read from a device after EOF. @@ -4777,8 +5285,14 @@ GetInput(chanPtr) return 0; } - nread = (chanPtr->typePtr->inputProc)(chanPtr->instanceData, - bufPtr->buf + bufPtr->nextAdded, toRead, &result); + if ((statePtr->flags & CHANNEL_TIMER_FEV) && + (statePtr->flags & CHANNEL_NONBLOCKING)) { + nread = -1; + result = EWOULDBLOCK; + } else { + nread = (chanPtr->typePtr->inputProc)(chanPtr->instanceData, + bufPtr->buf + bufPtr->nextAdded, toRead, &result); + } if (nread > 0) { bufPtr->nextAdded += nread; @@ -4803,7 +5317,7 @@ GetInput(chanPtr) } Tcl_SetErrno(result); return result; - } + } return 0; } @@ -4825,24 +5339,24 @@ GetInput(chanPtr) *---------------------------------------------------------------------- */ -int +Tcl_WideInt Tcl_Seek(chan, offset, mode) Tcl_Channel chan; /* The channel on which to seek. */ - int offset; /* Offset to seek to. */ + Tcl_WideInt offset; /* Offset to seek to. */ int mode; /* Relative to which location to seek? */ { Channel *chanPtr = (Channel *) chan; /* The real IO channel. */ ChannelState *statePtr = chanPtr->state; /* state info for channel */ - ChannelBuffer *bufPtr; int inputBuffered, outputBuffered; + /* # bytes held in buffers. */ int result; /* Of device driver operations. */ - int curPos; /* Position on the device. */ + Tcl_WideInt curPos; /* Position on the device. */ int wasAsync; /* Was the channel nonblocking before the * seek operation? If so, must restore to * nonblocking mode after the seek. */ if (CheckChannelErrors(statePtr, TCL_WRITABLE | TCL_READABLE) != 0) { - return -1; + return Tcl_LongAsWide(-1); } /* @@ -4852,7 +5366,9 @@ Tcl_Seek(chan, offset, mode) * registered in an interpreter. */ - if (CheckForDeadChannel(NULL, statePtr)) return -1; + if (CheckForDeadChannel(NULL, statePtr)) { + return Tcl_LongAsWide(-1); + } /* * This operation should occur at the top of a channel stack. @@ -4867,7 +5383,7 @@ Tcl_Seek(chan, offset, mode) if (chanPtr->typePtr->seekProc == (Tcl_DriverSeekProc *) NULL) { Tcl_SetErrno(EINVAL); - return -1; + return Tcl_LongAsWide(-1); } /* @@ -4875,37 +5391,12 @@ Tcl_Seek(chan, offset, mode) * output is buffered, cannot compute the current position. */ - for (bufPtr = statePtr->inQueueHead, inputBuffered = 0; - bufPtr != (ChannelBuffer *) NULL; - bufPtr = bufPtr->nextPtr) { - inputBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved); - } - - /* - * Don't forget the bytes in the topmost pushback area. - */ - - for (bufPtr = statePtr->topChanPtr->inQueueHead; - bufPtr != (ChannelBuffer *) NULL; - bufPtr = bufPtr->nextPtr) { - inputBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved); - } - - for (bufPtr = statePtr->outQueueHead, outputBuffered = 0; - bufPtr != (ChannelBuffer *) NULL; - bufPtr = bufPtr->nextPtr) { - outputBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved); - } - if ((statePtr->curOutPtr != (ChannelBuffer *) NULL) && - (statePtr->curOutPtr->nextAdded > statePtr->curOutPtr->nextRemoved)) { - statePtr->flags |= BUFFER_READY; - outputBuffered += - (statePtr->curOutPtr->nextAdded - statePtr->curOutPtr->nextRemoved); - } + inputBuffered = Tcl_InputBuffered(chan); + outputBuffered = Tcl_OutputBuffered(chan); if ((inputBuffered != 0) && (outputBuffered != 0)) { Tcl_SetErrno(EFAULT); - return -1; + return Tcl_LongAsWide(-1); } /* @@ -4944,7 +5435,7 @@ Tcl_Seek(chan, offset, mode) wasAsync = 1; result = StackSetBlockMode(chanPtr, TCL_MODE_BLOCKING); if (result != 0) { - return -1; + return Tcl_LongAsWide(-1); } statePtr->flags &= (~(CHANNEL_NONBLOCKING)); if (statePtr->flags & BG_FLUSH_SCHEDULED) { @@ -4966,14 +5457,26 @@ Tcl_Seek(chan, offset, mode) /* * Now seek to the new position in the channel as requested by the - * caller. + * caller. Note that we prefer the wideSeekProc if that is + * available and non-NULL... */ - curPos = (chanPtr->typePtr->seekProc) (chanPtr->instanceData, - (long) offset, mode, &result); - if (curPos == -1) { - Tcl_SetErrno(result); - } + if (HaveVersion(chanPtr->typePtr, TCL_CHANNEL_VERSION_3) && + chanPtr->typePtr->wideSeekProc != NULL) { + curPos = (chanPtr->typePtr->wideSeekProc) (chanPtr->instanceData, + offset, mode, &result); + } else if (offset < Tcl_LongAsWide(LONG_MIN) || + offset > Tcl_LongAsWide(LONG_MAX)) { + Tcl_SetErrno(EOVERFLOW); + curPos = Tcl_LongAsWide(-1); + } else { + curPos = Tcl_LongAsWide((chanPtr->typePtr->seekProc) ( + chanPtr->instanceData, Tcl_WideAsLong(offset), mode, + &result)); + if (curPos == Tcl_LongAsWide(-1)) { + Tcl_SetErrno(result); + } + } } /* @@ -4987,7 +5490,7 @@ Tcl_Seek(chan, offset, mode) statePtr->flags |= CHANNEL_NONBLOCKING; result = StackSetBlockMode(chanPtr, TCL_MODE_NONBLOCKING); if (result != 0) { - return -1; + return Tcl_LongAsWide(-1); } } @@ -5013,19 +5516,18 @@ Tcl_Seek(chan, offset, mode) *---------------------------------------------------------------------- */ -int +Tcl_WideInt Tcl_Tell(chan) Tcl_Channel chan; /* The channel to return pos for. */ { Channel *chanPtr = (Channel *) chan; /* The real IO channel. */ ChannelState *statePtr = chanPtr->state; /* state info for channel */ - ChannelBuffer *bufPtr; - int inputBuffered, outputBuffered; + int inputBuffered, outputBuffered; /* # bytes held in buffers. */ int result; /* Of calling device driver. */ - int curPos; /* Position on device. */ + Tcl_WideInt curPos; /* Position on device. */ if (CheckChannelErrors(statePtr, TCL_WRITABLE | TCL_READABLE) != 0) { - return -1; + return Tcl_LongAsWide(-1); } /* @@ -5036,7 +5538,7 @@ Tcl_Tell(chan) */ if (CheckForDeadChannel(NULL, statePtr)) { - return -1; + return Tcl_LongAsWide(-1); } /* @@ -5052,7 +5554,7 @@ Tcl_Tell(chan) if (chanPtr->typePtr->seekProc == (Tcl_DriverSeekProc *) NULL) { Tcl_SetErrno(EINVAL); - return -1; + return Tcl_LongAsWide(-1); } /* @@ -5060,43 +5562,78 @@ Tcl_Tell(chan) * output is buffered, cannot compute the current position. */ - for (bufPtr = statePtr->inQueueHead, inputBuffered = 0; - bufPtr != (ChannelBuffer *) NULL; - bufPtr = bufPtr->nextPtr) { - inputBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved); - } - for (bufPtr = statePtr->outQueueHead, outputBuffered = 0; - bufPtr != (ChannelBuffer *) NULL; - bufPtr = bufPtr->nextPtr) { - outputBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved); - } - if ((statePtr->curOutPtr != (ChannelBuffer *) NULL) && - (statePtr->curOutPtr->nextAdded > statePtr->curOutPtr->nextRemoved)) { - statePtr->flags |= BUFFER_READY; - outputBuffered += - (statePtr->curOutPtr->nextAdded - statePtr->curOutPtr->nextRemoved); - } + inputBuffered = Tcl_InputBuffered(chan); + outputBuffered = Tcl_OutputBuffered(chan); if ((inputBuffered != 0) && (outputBuffered != 0)) { Tcl_SetErrno(EFAULT); - return -1; + return Tcl_LongAsWide(-1); } /* * Get the current position in the device and compute the position - * where the next character will be read or written. + * where the next character will be read or written. Note that we + * prefer the wideSeekProc if that is available and non-NULL... */ - curPos = (chanPtr->typePtr->seekProc) (chanPtr->instanceData, - (long) 0, SEEK_CUR, &result); - if (curPos == -1) { + if (HaveVersion(chanPtr->typePtr, TCL_CHANNEL_VERSION_3) && + chanPtr->typePtr->wideSeekProc != NULL) { + curPos = (chanPtr->typePtr->wideSeekProc) (chanPtr->instanceData, + Tcl_LongAsWide(0), SEEK_CUR, &result); + } else { + curPos = Tcl_LongAsWide((chanPtr->typePtr->seekProc) ( + chanPtr->instanceData, 0, SEEK_CUR, &result)); + } + if (curPos == Tcl_LongAsWide(-1)) { Tcl_SetErrno(result); - return -1; + return Tcl_LongAsWide(-1); } if (inputBuffered != 0) { - return (curPos - inputBuffered); + return curPos - inputBuffered; } - return (curPos + outputBuffered); + return curPos + outputBuffered; +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_SeekOld, Tcl_TellOld -- + * + * Backward-compatability 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(chan, offset, mode) + 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(chan) + Tcl_Channel chan; /* The channel to return pos for. */ +{ + Tcl_WideInt wResult; + + wResult = Tcl_Tell(chan); + return (int)Tcl_WideAsLong(wResult); } /* @@ -5177,7 +5714,7 @@ CheckChannelErrors(statePtr, flags) * reading beyond the eofChar). Also, always clear the BLOCKED bit. * We want to discover these conditions anew in each operation. */ - + if ((statePtr->flags & CHANNEL_STICKY_EOF) == 0) { statePtr->flags &= ~CHANNEL_EOF; } @@ -5290,6 +5827,48 @@ Tcl_InputBuffered(chan) /* *---------------------------------------------------------------------- * + * Tcl_OutputBuffered -- + * + * Returns the number of bytes of output currently buffered in the + * common internal buffer of a channel. + * + * Results: + * The number of output bytes buffered, or zero if the channel is not + * open for writing. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_OutputBuffered(chan) + Tcl_Channel chan; /* The channel to query. */ +{ + ChannelState *statePtr = ((Channel *) chan)->state; + /* State of real channel structure. */ + ChannelBuffer *bufPtr; + int bytesBuffered; + + for (bytesBuffered = 0, bufPtr = statePtr->outQueueHead; + bufPtr != (ChannelBuffer *) NULL; + bufPtr = bufPtr->nextPtr) { + bytesBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved); + } + if ((statePtr->curOutPtr != (ChannelBuffer *) NULL) && + (statePtr->curOutPtr->nextAdded > statePtr->curOutPtr->nextRemoved)) { + statePtr->flags |= BUFFER_READY; + bytesBuffered += + (statePtr->curOutPtr->nextAdded - statePtr->curOutPtr->nextRemoved); + } + + return bytesBuffered; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_ChannelBuffered -- * * Returns the number of bytes of input currently buffered in the @@ -5431,8 +6010,8 @@ Tcl_GetChannelBufferSize(chan) int Tcl_BadChannelOption(interp, optionName, optionList) Tcl_Interp *interp; /* Current interpreter. (can be NULL)*/ - char *optionName; /* 'bad option' name */ - char *optionList; /* Specific options list to append + CONST char *optionName; /* 'bad option' name */ + CONST char *optionList; /* Specific options list to append * to the standard generic options. * can be NULL for generic options * only. @@ -5441,12 +6020,12 @@ Tcl_BadChannelOption(interp, optionName, optionList) if (interp) { CONST char *genericopt = "blocking buffering buffersize encoding eofchar translation"; - char **argv; + CONST char **argv; int argc, i; Tcl_DString ds; Tcl_DStringInit(&ds); - Tcl_DStringAppend(&ds, (char *) genericopt, -1); + Tcl_DStringAppend(&ds, genericopt, -1); if (optionList && (*optionList)) { Tcl_DStringAppend(&ds, " ", 1); Tcl_DStringAppend(&ds, optionList, -1); @@ -5494,7 +6073,7 @@ int Tcl_GetChannelOption(interp, chan, optionName, dsPtr) Tcl_Interp *interp; /* For error reporting - can be NULL. */ Tcl_Channel chan; /* Channel on which to get option. */ - char *optionName; /* Option to get. */ + CONST char *optionName; /* Option to get. */ Tcl_DString *dsPtr; /* Where to store value(s). */ { size_t len; /* Length of optionName string. */ @@ -5629,6 +6208,10 @@ Tcl_GetChannelOption(interp, chan, optionName, dsPtr) Tcl_DStringAppendElement(dsPtr, buf); } } + if ( !(flags & (TCL_READABLE|TCL_WRITABLE))) { + /* Not readable or writable (server socket) */ + Tcl_DStringAppendElement(dsPtr, ""); + } if (((flags & (TCL_READABLE|TCL_WRITABLE)) == (TCL_READABLE|TCL_WRITABLE)) && (len == 0)) { Tcl_DStringEndSublist(dsPtr); @@ -5669,6 +6252,10 @@ Tcl_GetChannelOption(interp, chan, optionName, dsPtr) Tcl_DStringAppendElement(dsPtr, "lf"); } } + if ( !(flags & (TCL_READABLE|TCL_WRITABLE))) { + /* Not readable or writable (server socket) */ + Tcl_DStringAppendElement(dsPtr, "auto"); + } if (((flags & (TCL_READABLE|TCL_WRITABLE)) == (TCL_READABLE|TCL_WRITABLE)) && (len == 0)) { Tcl_DStringEndSublist(dsPtr); @@ -5718,15 +6305,14 @@ int Tcl_SetChannelOption(interp, chan, optionName, newValue) Tcl_Interp *interp; /* For error reporting - can be NULL. */ Tcl_Channel chan; /* Channel on which to set mode. */ - char *optionName; /* Which option to set? */ - char *newValue; /* New value for option. */ + CONST char *optionName; /* Which option to set? */ + CONST char *newValue; /* New value for option. */ { - int newMode; /* New (numeric) mode to sert. */ Channel *chanPtr = (Channel *) chan; /* The real IO channel. */ ChannelState *statePtr = chanPtr->state; /* state info for channel */ size_t len; /* Length of optionName string. */ int argc; - char **argv; + CONST char **argv; /* * If the channel is in the middle of a background copy, fail. @@ -5762,6 +6348,7 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue) if ((len > 2) && (optionName[1] == 'b') && (strncmp(optionName, "-blocking", len) == 0)) { + int newMode; if (Tcl_GetBoolean(interp, newValue, &newMode) == TCL_ERROR) { return TCL_ERROR; } @@ -5812,6 +6399,15 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue) return TCL_ERROR; } } + /* + * When the channel has an escape sequence driven encoding such as + * iso2022, the terminated escape sequence must write to the buffer. + */ + if ((statePtr->encoding != NULL) && (statePtr->curOutPtr != NULL) + && (CheckChannelErrors(statePtr, TCL_WRITABLE) == 0)) { + statePtr->outputEncodingFlags |= TCL_ENCODING_END; + WriteChars(chanPtr, "", 0); + } Tcl_FreeEncoding(statePtr->encoding); statePtr->encoding = encoding; statePtr->inputEncodingState = NULL; @@ -5838,8 +6434,8 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue) } else if (argc != 2) { if (interp) { Tcl_AppendResult(interp, - "bad value for -eofchar: should be a list of one or", - " two elements", (char *) NULL); + "bad value for -eofchar: should be a list of zero,", + " one, or two elements", (char *) NULL); } ckfree((char *) argv); return TCL_ERROR; @@ -5851,13 +6447,13 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue) statePtr->outEofChar = (int) argv[1][0]; } } - if (argv != (char **) NULL) { + if (argv != NULL) { ckfree((char *) argv); } return TCL_OK; } else if ((len > 1) && (optionName[1] == 't') && (strncmp(optionName, "-translation", len) == 0)) { - char *readMode, *writeMode; + CONST char *readMode, *writeMode; if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) { return TCL_ERROR; @@ -5880,23 +6476,24 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue) } if (readMode) { + TclEolTranslation translation; if (*readMode == '\0') { - newMode = statePtr->inputTranslation; + translation = statePtr->inputTranslation; } else if (strcmp(readMode, "auto") == 0) { - newMode = TCL_TRANSLATE_AUTO; + translation = TCL_TRANSLATE_AUTO; } else if (strcmp(readMode, "binary") == 0) { - newMode = TCL_TRANSLATE_LF; + translation = TCL_TRANSLATE_LF; statePtr->inEofChar = 0; Tcl_FreeEncoding(statePtr->encoding); statePtr->encoding = NULL; } else if (strcmp(readMode, "lf") == 0) { - newMode = TCL_TRANSLATE_LF; + translation = TCL_TRANSLATE_LF; } else if (strcmp(readMode, "cr") == 0) { - newMode = TCL_TRANSLATE_CR; + translation = TCL_TRANSLATE_CR; } else if (strcmp(readMode, "crlf") == 0) { - newMode = TCL_TRANSLATE_CRLF; + translation = TCL_TRANSLATE_CRLF; } else if (strcmp(readMode, "platform") == 0) { - newMode = TCL_PLATFORM_TRANSLATION; + translation = TCL_PLATFORM_TRANSLATION; } else { if (interp) { Tcl_AppendResult(interp, @@ -5914,8 +6511,8 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue) * complete the line. */ - if (newMode != statePtr->inputTranslation) { - statePtr->inputTranslation = (Tcl_EolTranslation) newMode; + if (translation != statePtr->inputTranslation) { + statePtr->inputTranslation = translation; statePtr->flags &= ~(INPUT_SAW_CR); statePtr->flags &= ~(CHANNEL_NEED_MORE_DATA); UpdateInterest(chanPtr); @@ -5932,7 +6529,7 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue) * coded later. */ - if (strcmp(chanPtr->typePtr->typeName, "tcp") == 0) { + if (strcmp(Tcl_ChannelName(chanPtr->typePtr), "tcp") == 0) { statePtr->outputTranslation = TCL_TRANSLATE_CRLF; } else { statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION; @@ -6090,7 +6687,6 @@ Tcl_NotifyChannel(channel, mask) ChannelHandler *chPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); NextChannelHandler nh; -#ifdef TCL_CHANNEL_VERSION_2 Channel* upChanPtr; Tcl_ChannelType* upTypePtr; @@ -6107,17 +6703,13 @@ Tcl_NotifyChannel(channel, mask) */ while (mask && (chanPtr->upChanPtr != ((Channel*) NULL))) { + Tcl_DriverHandlerProc* upHandlerProc; + upChanPtr = chanPtr->upChanPtr; upTypePtr = upChanPtr->typePtr; - - if ((Tcl_ChannelVersion(upTypePtr) == TCL_CHANNEL_VERSION_2) && - (Tcl_ChannelHandlerProc(upTypePtr) != - ((Tcl_DriverHandlerProc *) NULL))) { - - Tcl_DriverHandlerProc* handlerProc = - Tcl_ChannelHandlerProc(upTypePtr); - - mask = (*handlerProc) (upChanPtr->instanceData, mask); + upHandlerProc = Tcl_ChannelHandlerProc(upTypePtr); + if (upHandlerProc != NULL) { + mask = (*upHandlerProc) (upChanPtr->instanceData, mask); } /* ELSE: @@ -6148,6 +6740,7 @@ Tcl_NotifyChannel(channel, mask) */ Tcl_Preserve((ClientData) channel); + Tcl_Preserve((ClientData) statePtr); /* * If we are flushing in the background, be sure to call FlushChannel @@ -6157,8 +6750,8 @@ Tcl_NotifyChannel(channel, mask) */ if ((statePtr->flags & BG_FLUSH_SCHEDULED) && (mask & TCL_WRITABLE)) { - FlushChannel(NULL, chanPtr, 1); - mask &= ~TCL_WRITABLE; + FlushChannel(NULL, chanPtr, 1); + mask &= ~TCL_WRITABLE; } /* @@ -6171,19 +6764,18 @@ Tcl_NotifyChannel(channel, mask) tsdPtr->nestedHandlerPtr = &nh; for (chPtr = statePtr->chPtr; chPtr != (ChannelHandler *) NULL; ) { + /* + * If this channel handler is interested in any of the events that + * have occurred on the channel, invoke its procedure. + */ - /* - * If this channel handler is interested in any of the events that - * have occurred on the channel, invoke its procedure. - */ - - if ((chPtr->mask & mask) != 0) { - nh.nextHandlerPtr = chPtr->nextPtr; - (*(chPtr->proc))(chPtr->clientData, mask); - chPtr = nh.nextHandlerPtr; - } else { - chPtr = chPtr->nextPtr; - } + if ((chPtr->mask & mask) != 0) { + nh.nextHandlerPtr = chPtr->nextPtr; + (*(chPtr->proc))(chPtr->clientData, mask); + chPtr = nh.nextHandlerPtr; + } else { + chPtr = chPtr->nextPtr; + } } /* @@ -6196,82 +6788,10 @@ Tcl_NotifyChannel(channel, mask) UpdateInterest(chanPtr); } + Tcl_Release((ClientData) statePtr); Tcl_Release((ClientData) channel); tsdPtr->nestedHandlerPtr = nh.nestedHandlerPtr; -#else - /* Walk all channels in a stack ! and notify them in order. - */ - - while (chanPtr != (Channel *) NULL) { - /* - * Preserve the channel struct in case the script closes it. - */ - - Tcl_Preserve((ClientData) channel); - - /* - * If we are flushing in the background, be sure to call FlushChannel - * for writable events. Note that we have to discard the writable - * event so we don't call any write handlers before the flush is - * complete. - */ - - if ((statePtr->flags & BG_FLUSH_SCHEDULED) && (mask & TCL_WRITABLE)) { - FlushChannel(NULL, chanPtr, 1); - mask &= ~TCL_WRITABLE; - } - - /* - * Add this invocation to the list of recursive invocations of - * ChannelHandlerEventProc. - */ - - nh.nextHandlerPtr = (ChannelHandler *) NULL; - nh.nestedHandlerPtr = tsdPtr->nestedHandlerPtr; - tsdPtr->nestedHandlerPtr = &nh; - - for (chPtr = statePtr->chPtr; chPtr != (ChannelHandler *) NULL; ) { - - /* - * If this channel handler is interested in any of the events that - * have occurred on the channel, invoke its procedure. - */ - - if ((chPtr->mask & mask) != 0) { - nh.nextHandlerPtr = chPtr->nextPtr; - (*(chPtr->proc))(chPtr->clientData, mask); - chPtr = nh.nextHandlerPtr; - } else { - chPtr = chPtr->nextPtr; - } - } - - /* - * Update the notifier interest, since it may have changed after - * invoking event handlers. Skip that if the channel was deleted - * in the call to the channel handler. - */ - - if (chanPtr->typePtr != NULL) { - UpdateInterest(chanPtr); - - /* Walk down the stack. - */ - chanPtr = chanPtr->downChanPtr; - } else { - /* Stop walking the chain, the whole stack was destroyed! - */ - chanPtr = (Channel *) NULL; - } - - Tcl_Release((ClientData) channel); - - tsdPtr->nestedHandlerPtr = nh.nestedHandlerPtr; - - channel = (Tcl_Channel) chanPtr; - } -#endif } /* @@ -6365,8 +6885,23 @@ ChannelTimerProc(clientData) statePtr->timer = Tcl_CreateTimerHandler(0, ChannelTimerProc, (ClientData) chanPtr); + + /* Set the TIMER flag to notify the higher levels that the + * driver might have no data for us. We do this only if we are + * in non-blocking mode and the driver has no BlockModeProc + * because only then we really don't know if the driver will + * block or not. A similar test is done in "PeekAhead". + */ + + if ((statePtr->flags & CHANNEL_NONBLOCKING) && + (Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL)) { + statePtr->flags |= CHANNEL_TIMER_FEV; + } + Tcl_Preserve((ClientData) statePtr); Tcl_NotifyChannel((Tcl_Channel)chanPtr, TCL_READABLE); - + + statePtr->flags &= ~CHANNEL_TIMER_FEV; + Tcl_Release((ClientData) statePtr); } else { statePtr->timer = NULL; UpdateInterest(chanPtr); @@ -6756,7 +7291,7 @@ Tcl_FileEventObjCmd(clientData, interp, objc, objv) char *chanName; int modeIndex; /* Index of mode argument. */ int mask; - static char *modeOptions[] = {"readable", "writable", NULL}; + static CONST char *modeOptions[] = {"readable", "writable", NULL}; static int maskArray[] = {TCL_READABLE, TCL_WRITABLE}; if ((objc != 3) && (objc != 4)) { @@ -6889,7 +7424,7 @@ TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr) if (inPtr != outPtr) { if (nonBlocking != (writeFlags & CHANNEL_NONBLOCKING)) { if (SetBlockMode(NULL, outPtr, - nonBlocking ? TCL_MODE_BLOCKING : TCL_MODE_NONBLOCKING) + nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING) != TCL_OK) { if (nonBlocking != (readFlags & CHANNEL_NONBLOCKING)) { SetBlockMode(NULL, inPtr, @@ -6960,12 +7495,14 @@ CopyData(csPtr, mask) int mask; /* Current channel event flags. */ { Tcl_Interp *interp; - Tcl_Obj *cmdPtr, *errObj = NULL; + Tcl_Obj *cmdPtr, *errObj = NULL, *bufObj = NULL; Tcl_Channel inChan, outChan; ChannelState *inStatePtr, *outStatePtr; - int result = TCL_OK; - int size; - int total; + int result = TCL_OK, size, total, sizeb; + char* buffer; + + int inBinary, outBinary, sameEncoding; /* Encoding control */ + int underflow; /* input underflow */ inChan = (Tcl_Channel) csPtr->readPtr; outChan = (Tcl_Channel) csPtr->writePtr; @@ -6982,8 +7519,16 @@ CopyData(csPtr, mask) * thus gets the bottom of the stack. */ - while (csPtr->toRead != 0) { + inBinary = (inStatePtr->encoding == NULL); + outBinary = (outStatePtr->encoding == NULL); + sameEncoding = (inStatePtr->encoding == outStatePtr->encoding); + + if (!(inBinary || sameEncoding)) { + bufObj = Tcl_NewObj (); + Tcl_IncrRefCount (bufObj); + } + while (csPtr->toRead != 0) { /* * Check for unreported background errors. */ @@ -7004,11 +7549,17 @@ CopyData(csPtr, mask) */ if ((csPtr->toRead == -1) || (csPtr->toRead > csPtr->bufSize)) { - size = csPtr->bufSize; + sizeb = csPtr->bufSize; } else { - size = csPtr->toRead; + sizeb = csPtr->toRead; } - size = DoRead(inStatePtr->topChanPtr, csPtr->buffer, size); + + if (inBinary || sameEncoding) { + size = DoRead(inStatePtr->topChanPtr, csPtr->buffer, sizeb); + } else { + size = DoReadChars(inStatePtr->topChanPtr, bufObj, sizeb, 0 /* No append */); + } + underflow = (size >= 0) && (size < sizeb); /* input underflow */ if (size < 0) { readError: @@ -7017,16 +7568,17 @@ CopyData(csPtr, mask) Tcl_GetChannelName(inChan), "\": ", Tcl_PosixError(interp), (char *) NULL); break; - } else if (size == 0) { + } else if (underflow) { /* * We had an underflow on the read side. If we are at EOF, * then the copying is done, otherwise set up a channel * handler to detect when the channel becomes readable again. */ - if (Tcl_Eof(inChan)) { + if ((size == 0) && Tcl_Eof(inChan)) { break; - } else if (!(mask & TCL_READABLE)) { + } + if (! Tcl_Eof(inChan) && !(mask & TCL_READABLE)) { if (mask & TCL_WRITABLE) { Tcl_DeleteChannelHandler(outChan, CopyEventProc, (ClientData) csPtr); @@ -7034,15 +7586,38 @@ CopyData(csPtr, mask) Tcl_CreateChannelHandler(inChan, TCL_READABLE, CopyEventProc, (ClientData) csPtr); } - return TCL_OK; + if (size == 0) { + if (bufObj != (Tcl_Obj*) NULL) { + Tcl_DecrRefCount (bufObj); + bufObj = (Tcl_Obj*) NULL; + } + return TCL_OK; + } } /* * Now write the buffer out. */ - size = DoWrite(outStatePtr->topChanPtr, csPtr->buffer, size); - if (size < 0) { + if (inBinary || sameEncoding) { + buffer = csPtr->buffer; + sizeb = size; + } else { + buffer = Tcl_GetStringFromObj (bufObj, &sizeb); + } + + if (outBinary || sameEncoding) { + sizeb = DoWrite(outStatePtr->topChanPtr, buffer, sizeb); + } else { + sizeb = DoWriteChars(outStatePtr->topChanPtr, buffer, sizeb); + } + + if (inBinary || sameEncoding) { + /* Both read and write counted bytes */ + size = sizeb; + } /* else : Read counted characters, write counted bytes, i.e. size != sizeb */ + + if (sizeb < 0) { writeError: errObj = Tcl_NewObj(); Tcl_AppendStringsToObj(errObj, "error writing \"", @@ -7052,32 +7627,49 @@ CopyData(csPtr, mask) } /* + * Update the current byte count. Do it now so the count is + * valid before a return or break takes us out of the loop. + * The invariant at the top of the loop should be that + * csPtr->toRead holds the number of bytes left to copy. + */ + + if (csPtr->toRead != -1) { + csPtr->toRead -= size; + } + csPtr->total += size; + + /* + * Break loop if EOF && (size>0) + */ + + if (Tcl_Eof(inChan)) { + break; + } + + /* * Check to see if the write is happening in the background. If so, * stop copying and wait for the channel to become writable again. + * After input underflow we already installed a readable handler + * therefore we don't need a writable handler. */ - if (outStatePtr->flags & BG_FLUSH_SCHEDULED) { + if ( ! underflow && (outStatePtr->flags & BG_FLUSH_SCHEDULED) ) { if (!(mask & TCL_WRITABLE)) { if (mask & TCL_READABLE) { - Tcl_DeleteChannelHandler(outChan, CopyEventProc, + Tcl_DeleteChannelHandler(inChan, CopyEventProc, (ClientData) csPtr); } Tcl_CreateChannelHandler(outChan, TCL_WRITABLE, CopyEventProc, (ClientData) csPtr); } + if (bufObj != (Tcl_Obj*) NULL) { + Tcl_DecrRefCount (bufObj); + bufObj = (Tcl_Obj*) NULL; + } return TCL_OK; } /* - * Update the current byte count if we care. - */ - - if (csPtr->toRead != -1) { - csPtr->toRead -= size; - } - csPtr->total += size; - - /* * For background copies, we only do one buffer per invocation so * we don't starve the rest of the system. */ @@ -7092,8 +7684,17 @@ CopyData(csPtr, mask) Tcl_CreateChannelHandler(outChan, TCL_WRITABLE, CopyEventProc, (ClientData) csPtr); } + if (bufObj != (Tcl_Obj*) NULL) { + Tcl_DecrRefCount (bufObj); + bufObj = (Tcl_Obj*) NULL; + } return TCL_OK; } + } /* while */ + + if (bufObj != (Tcl_Obj*) NULL) { + Tcl_DecrRefCount (bufObj); + bufObj = (Tcl_Obj*) NULL; } /* @@ -7144,6 +7745,8 @@ CopyData(csPtr, mask) * * Reads a given number of bytes from a channel. * + * No encoding conversions are applied to the bytes being read. + * * Results: * The number of characters read, or -1 on error. Use Tcl_GetErrno() * to retrieve the error code for the error that occurred. @@ -7568,14 +8171,14 @@ CopyBuffer(chanPtr, result, space) static int DoWrite(chanPtr, src, srcLen) Channel *chanPtr; /* The channel to buffer output for. */ - char *src; /* Data to write. */ + CONST char *src; /* Data to write. */ int srcLen; /* Number of bytes to write. */ { ChannelState *statePtr = chanPtr->state; /* state info for channel */ ChannelBuffer *outBufPtr; /* Current output buffer. */ int foundNewline; /* Did we find a newline in output? */ char *dPtr; - char *sPtr; /* Search variables for newline. */ + CONST char *sPtr; /* Search variables for newline. */ int crsent; /* In CRLF eol translation mode, * remember the fact that a CR was * output to the channel without @@ -7769,6 +8372,7 @@ StopCopy(csPtr) nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING); } if (csPtr->readPtr != csPtr->writePtr) { + nonBlocking = (csPtr->writeFlags & CHANNEL_NONBLOCKING); if (nonBlocking != (outStatePtr->flags & CHANNEL_NONBLOCKING)) { SetBlockMode(NULL, csPtr->writePtr, nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING); @@ -7926,17 +8530,32 @@ Tcl_GetChannelNames(interp) int Tcl_GetChannelNamesEx(interp, pattern) Tcl_Interp *interp; /* Interp for error reporting. */ - char *pattern; /* pattern to filter on. */ + CONST char *pattern; /* pattern to filter on. */ { - ChannelState *statePtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - char *name; - Tcl_Obj *resultPtr; + ChannelState *statePtr; + CONST char *name; /* name for channel */ + Tcl_Obj *resultPtr; /* pointer to result object */ + Tcl_HashTable *hTblPtr; /* Hash table of channels. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + Tcl_HashSearch hSearch; /* Search variable. */ - resultPtr = Tcl_GetObjResult(interp); - for (statePtr = tsdPtr->firstCSPtr; - statePtr != NULL; - statePtr = statePtr->nextCSPtr) { + if (interp == (Tcl_Interp *) NULL) { + return TCL_OK; + } + + /* + * Get the channel table that stores the channels registered + * for this interpreter. + */ + hTblPtr = GetChannelTable(interp); + resultPtr = Tcl_GetObjResult(interp); + + for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + + statePtr = ((Channel *) Tcl_GetHashValue(hPtr))->state; if (statePtr->topChanPtr == (Channel *) tsdPtr->stdinChannel) { name = "stdin"; } else if (statePtr->topChanPtr == (Channel *) tsdPtr->stdoutChannel) { @@ -7944,8 +8563,13 @@ Tcl_GetChannelNamesEx(interp, pattern) } else if (statePtr->topChanPtr == (Channel *) tsdPtr->stderrChannel) { name = "stderr"; } else { + /* + * This is also stored in Tcl_GetHashKey(hTblPtr, hPtr), + * but it's simpler to just grab the name from the statePtr. + */ name = statePtr->channelName; } + if (((pattern == NULL) || Tcl_StringMatch(name, pattern)) && (Tcl_ListObjAppendElement(interp, resultPtr, Tcl_NewStringObj(name, -1)) != TCL_OK)) { @@ -7958,6 +8582,131 @@ Tcl_GetChannelNamesEx(interp, pattern) /* *---------------------------------------------------------------------- * + * Tcl_IsChannelRegistered -- + * + * Checks whether the channel is associated with the interp. + * See also Tcl_RegisterChannel and Tcl_UnregisterChannel. + * + * Results: + * 0 if the channel is not registered in the interpreter, 1 else. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_IsChannelRegistered (interp, chan) + Tcl_Interp* interp; /* The interp to query of the channel */ + Tcl_Channel chan; /* The channel to check */ +{ + Tcl_HashTable *hTblPtr; /* Hash table of channels. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + Channel *chanPtr; /* The real IO channel. */ + ChannelState *statePtr; /* State of the real channel. */ + + /* + * Always check bottom-most channel in the stack. This is the one + * that gets registered. + */ + chanPtr = ((Channel *) chan)->state->bottomChanPtr; + statePtr = chanPtr->state; + + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + return 0; + } + hPtr = Tcl_FindHashEntry(hTblPtr, statePtr->channelName); + if (hPtr == (Tcl_HashEntry *) NULL) { + return 0; + } + if ((Channel *) Tcl_GetHashValue(hPtr) != chanPtr) { + return 0; + } + + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_IsChannelShared -- + * + * Checks whether the channel is shared by multiple interpreters. + * + * Results: + * A boolean value (0 = Not shared, 1 = Shared). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_IsChannelShared (chan) + Tcl_Channel chan; /* The channel to query */ +{ + ChannelState *statePtr = ((Channel *) chan)->state; + /* State of real channel structure. */ + + return ((statePtr->refCount > 1) ? 1 : 0); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_IsChannelExisting -- + * + * Checks whether a channel of the given name exists in the + * (thread)-global list of all channels. + * See Tcl_GetChannelNamesEx for function exposed at the Tcl level. + * + * Results: + * A boolean value (0 = Does not exist, 1 = Does exist). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_IsChannelExisting(chanName) + CONST char* chanName; /* The name of the channel to look for. */ +{ + ChannelState *statePtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + CONST char *name; + int chanNameLen; + + chanNameLen = strlen(chanName); + for (statePtr = tsdPtr->firstCSPtr; + statePtr != NULL; + statePtr = statePtr->nextCSPtr) { + if (statePtr->topChanPtr == (Channel *) tsdPtr->stdinChannel) { + name = "stdin"; + } else if (statePtr->topChanPtr == (Channel *) tsdPtr->stdoutChannel) { + name = "stdout"; + } else if (statePtr->topChanPtr == (Channel *) tsdPtr->stderrChannel) { + name = "stderr"; + } else { + name = statePtr->channelName; + } + + if ((*chanName == *name) && + (memcmp(name, chanName, (size_t) chanNameLen) == 0)) { + return 1; + } + } + + return 0; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_ChannelName -- * * Return the name of the channel type. @@ -7971,11 +8720,11 @@ Tcl_GetChannelNamesEx(interp, pattern) *---------------------------------------------------------------------- */ -char * +CONST char * Tcl_ChannelName(chanTypePtr) Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */ { - return (chanTypePtr->typeName); + return chanTypePtr->typeName; } /* @@ -7986,7 +8735,7 @@ Tcl_ChannelName(chanTypePtr) * Return the of version of the channel type. * * Results: - * TCL_CHANNEL_VERSION_2 or TCL_CHANNEL_VERSION_1. + * One of the TCL_CHANNEL_VERSION_* constants from tcl.h * * Side effects: * None. @@ -8000,6 +8749,8 @@ Tcl_ChannelVersion(chanTypePtr) { if (chanTypePtr->version == TCL_CHANNEL_VERSION_2) { return TCL_CHANNEL_VERSION_2; + } else if (chanTypePtr->version == TCL_CHANNEL_VERSION_3) { + return TCL_CHANNEL_VERSION_3; } else { /* * In <v2 channel versions, the version field is occupied @@ -8012,6 +8763,33 @@ Tcl_ChannelVersion(chanTypePtr) /* *---------------------------------------------------------------------- * + * HaveVersion -- + * + * Return whether a channel type is (at least) of a given version. + * + * Results: + * True if the minimum version is exceeded by the version actually + * present. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +HaveVersion(chanTypePtr, minimumVersion) + Tcl_ChannelType *chanTypePtr; + Tcl_ChannelTypeVersion minimumVersion; +{ + Tcl_ChannelTypeVersion actualVersion = Tcl_ChannelVersion(chanTypePtr); + + return ((int)actualVersion) >= ((int)minimumVersion); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_ChannelBlockModeProc -- * * Return the Tcl_DriverBlockModeProc of the channel type. @@ -8022,16 +8800,18 @@ Tcl_ChannelVersion(chanTypePtr) * Side effects: * None. * - *---------------------------------------------------------------------- - */ + *---------------------------------------------------------------------- */ Tcl_DriverBlockModeProc * Tcl_ChannelBlockModeProc(chanTypePtr) Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */ { - if (chanTypePtr->version == TCL_CHANNEL_VERSION_2) { - return (chanTypePtr->blockModeProc); + if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_2)) { + return chanTypePtr->blockModeProc; } else { + /* + * The v1 structure had the blockModeProc in a different place. + */ return (Tcl_DriverBlockModeProc *) (chanTypePtr->version); } } @@ -8056,7 +8836,7 @@ Tcl_DriverCloseProc * Tcl_ChannelCloseProc(chanTypePtr) Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */ { - return (chanTypePtr->closeProc); + return chanTypePtr->closeProc; } /* @@ -8079,7 +8859,7 @@ Tcl_DriverClose2Proc * Tcl_ChannelClose2Proc(chanTypePtr) Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */ { - return (chanTypePtr->close2Proc); + return chanTypePtr->close2Proc; } /* @@ -8102,7 +8882,7 @@ Tcl_DriverInputProc * Tcl_ChannelInputProc(chanTypePtr) Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */ { - return (chanTypePtr->inputProc); + return chanTypePtr->inputProc; } /* @@ -8125,7 +8905,7 @@ Tcl_DriverOutputProc * Tcl_ChannelOutputProc(chanTypePtr) Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */ { - return (chanTypePtr->outputProc); + return chanTypePtr->outputProc; } /* @@ -8148,7 +8928,7 @@ Tcl_DriverSeekProc * Tcl_ChannelSeekProc(chanTypePtr) Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */ { - return (chanTypePtr->seekProc); + return chanTypePtr->seekProc; } /* @@ -8171,7 +8951,7 @@ Tcl_DriverSetOptionProc * Tcl_ChannelSetOptionProc(chanTypePtr) Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */ { - return (chanTypePtr->setOptionProc); + return chanTypePtr->setOptionProc; } /* @@ -8194,7 +8974,7 @@ Tcl_DriverGetOptionProc * Tcl_ChannelGetOptionProc(chanTypePtr) Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */ { - return (chanTypePtr->getOptionProc); + return chanTypePtr->getOptionProc; } /* @@ -8217,7 +8997,7 @@ Tcl_DriverWatchProc * Tcl_ChannelWatchProc(chanTypePtr) Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */ { - return (chanTypePtr->watchProc); + return chanTypePtr->watchProc; } /* @@ -8240,7 +9020,7 @@ Tcl_DriverGetHandleProc * Tcl_ChannelGetHandleProc(chanTypePtr) Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */ { - return (chanTypePtr->getHandleProc); + return chanTypePtr->getHandleProc; } /* @@ -8263,7 +9043,11 @@ Tcl_DriverFlushProc * Tcl_ChannelFlushProc(chanTypePtr) Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */ { - return (chanTypePtr->flushProc); + if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_2)) { + return chanTypePtr->flushProc; + } else { + return NULL; + } } /* @@ -8286,6 +9070,36 @@ Tcl_DriverHandlerProc * Tcl_ChannelHandlerProc(chanTypePtr) Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */ { - return (chanTypePtr->handlerProc); + if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_2)) { + return chanTypePtr->handlerProc; + } else { + return NULL; + } } + +/* + *---------------------------------------------------------------------- + * + * Tcl_ChannelWideSeekProc -- + * + * Return the Tcl_DriverWideSeekProc of the channel type. + * + * Results: + * A pointer to the proc. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +Tcl_DriverWideSeekProc * +Tcl_ChannelWideSeekProc(chanTypePtr) + Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */ +{ + if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_3)) { + return chanTypePtr->wideSeekProc; + } else { + return NULL; + } +} diff --git a/tcl/generic/tclIO.h b/tcl/generic/tclIO.h index 6d93a9c290a..179b56d92b4 100644 --- a/tcl/generic/tclIO.h +++ b/tcl/generic/tclIO.h @@ -158,7 +158,7 @@ typedef struct Channel { */ typedef struct ChannelState { - char *channelName; /* The name of the channel instance in Tcl + CONST char *channelName; /* The name of the channel instance in Tcl * commands. Storage is owned by the generic IO * code, is dynamically allocated. */ int flags; /* ORed combination of the flags defined @@ -182,10 +182,10 @@ typedef struct ChannelState { * data bytes. May be TCL_ENCODING_START * before converting first byte and * TCL_ENCODING_END when EOF is seen. */ - Tcl_EolTranslation inputTranslation; + TclEolTranslation inputTranslation; /* What translation to apply for end of line * sequences on input? */ - Tcl_EolTranslation outputTranslation; + TclEolTranslation outputTranslation; /* What translation to use for generating * end of line sequences in output? */ int inEofChar; /* If nonzero, use this as a signal of EOF @@ -233,6 +233,8 @@ typedef struct ChannelState { * long as the channel state. Never NULL. */ struct ChannelState *nextCSPtr; /* Next in list of channels currently open. */ + Tcl_ThreadId managingThread; /* TIP #10: Id of the thread managing + * this stack of channels. */ } ChannelState; /* @@ -294,6 +296,17 @@ typedef struct ChannelState { * the state of the channel changes. */ #define CHANNEL_RAW_MODE (1<<16) /* When set, notes that the Raw API is * being used. */ +#define CHANNEL_TIMER_FEV (1<<17) /* When set the event we are + * notified by is a fileevent + * generated by a timer. We + * don't know if the driver + * has more data and should + * not try to read from it. If + * the system needs more than + * is in the buffers out read + * routines will simulate a + * short read (0 characters + * read) */ /* * For each channel handler registered in a call to Tcl_CreateChannelHandler, diff --git a/tcl/generic/tclIOCmd.c b/tcl/generic/tclIOCmd.c index 0e6b7bf81a3..76ca6d1662e 100644 --- a/tcl/generic/tclIOCmd.c +++ b/tcl/generic/tclIOCmd.c @@ -63,45 +63,62 @@ Tcl_PutsObjCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Channel chan; /* The channel to puts on. */ - int i; /* Counter. */ + Tcl_Obj *string; /* String to write. */ int newline; /* Add a newline at end? */ char *channelId; /* Name of channel for puts. */ int result; /* Result of puts operation. */ int mode; /* Mode in which channel is opened. */ - char *arg; - int length; - i = 1; - newline = 1; - if ((objc >= 2) && (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0)) { - newline = 0; - i++; - } - if ((i < (objc-3)) || (i >= objc)) { - Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channelId? string"); - return TCL_ERROR; - } + switch (objc) { + case 2: /* puts $x */ + string = objv[1]; + newline = 1; + channelId = "stdout"; + break; - /* - * The code below provides backwards compatibility with an old - * form of the command that is no longer recommended or documented. - */ + case 3: /* puts -nonewline $x or puts $chan $x */ + if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) { + newline = 0; + channelId = "stdout"; + } else { + newline = 1; + channelId = Tcl_GetString(objv[1]); + } + string = objv[2]; + break; - if (i == (objc-3)) { - arg = Tcl_GetStringFromObj(objv[i + 2], &length); - if (strncmp(arg, "nonewline", (size_t) length) != 0) { - Tcl_AppendResult(interp, "bad argument \"", arg, - "\": should be \"nonewline\"", (char *) NULL); - return TCL_ERROR; + case 4: /* puts -nonewline $chan $x or puts $chan $x nonewline */ + if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) { + channelId = Tcl_GetString(objv[2]); + string = objv[3]; + } else { + /* + * The code below provides backwards compatibility with an + * old form of the command that is no longer recommended + * or documented. + */ + + char *arg; + int length; + + arg = Tcl_GetStringFromObj(objv[3], &length); + if (strncmp(arg, "nonewline", (size_t) length) != 0) { + Tcl_AppendResult(interp, "bad argument \"", arg, + "\": should be \"nonewline\"", + (char *) NULL); + return TCL_ERROR; + } + channelId = Tcl_GetString(objv[1]); + string = objv[2]; } newline = 0; + break; + + default: /* puts or puts some bad number of arguments... */ + Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channelId? string"); + return TCL_ERROR; } - if (i == (objc - 1)) { - channelId = "stdout"; - } else { - channelId = Tcl_GetString(objv[i]); - i++; - } + chan = Tcl_GetChannel(interp, channelId, &mode); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; @@ -112,7 +129,7 @@ Tcl_PutsObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } - result = Tcl_WriteObj(chan, objv[i]); + result = Tcl_WriteObj(chan, string); if (result < 0) { goto error; } @@ -228,22 +245,12 @@ Tcl_GetsObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } - resultPtr = Tcl_GetObjResult(interp); - linePtr = resultPtr; - if (objc == 3) { - /* - * Variable gets line, interp get bytecount. - */ - - linePtr = Tcl_NewObj(); - } + linePtr = Tcl_NewObj(); lineLen = Tcl_GetsObj(chan, linePtr); if (lineLen < 0) { if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) { - if (linePtr != resultPtr) { - Tcl_DecrRefCount(linePtr); - } + Tcl_DecrRefCount(linePtr); Tcl_ResetResult(interp); Tcl_AppendResult(interp, "error reading \"", name, "\": ", Tcl_PosixError(interp), (char *) NULL); @@ -257,8 +264,11 @@ Tcl_GetsObjCmd(dummy, interp, objc, objv) Tcl_DecrRefCount(linePtr); return TCL_ERROR; } + resultPtr = Tcl_GetObjResult(interp); Tcl_SetIntObj(resultPtr, lineLen); return TCL_OK; + } else { + Tcl_SetObjResult(interp, linePtr); } return TCL_OK; } @@ -406,11 +416,14 @@ Tcl_SeekObjCmd(clientData, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Channel chan; /* The channel to tell on. */ - int offset, mode; /* Where to seek? */ - int result; /* Of calling Tcl_Seek. */ + Tcl_WideInt offset; /* Where to seek? */ + int mode; /* How to seek? */ + Tcl_WideInt result; /* Of calling Tcl_Seek. */ char *chanName; int optionIndex; - static char *originOptions[] = {"start", "current", "end", (char *) NULL}; + static CONST char *originOptions[] = { + "start", "current", "end", (char *) NULL + }; static int modeArray[] = {SEEK_SET, SEEK_CUR, SEEK_END}; if ((objc != 3) && (objc != 4)) { @@ -422,7 +435,7 @@ Tcl_SeekObjCmd(clientData, interp, objc, objv) if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } - if (Tcl_GetIntFromObj(interp, objv[2], &offset) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[2], &offset) != TCL_OK) { return TCL_ERROR; } mode = SEEK_SET; @@ -435,7 +448,7 @@ Tcl_SeekObjCmd(clientData, interp, objc, objv) } result = Tcl_Seek(chan, offset, mode); - if (result == -1) { + if (result == Tcl_LongAsWide(-1)) { Tcl_AppendResult(interp, "error during seek on \"", chanName, "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; @@ -485,7 +498,7 @@ Tcl_TellObjCmd(clientData, interp, objc, objv) if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } - Tcl_SetIntObj(Tcl_GetObjResult(interp), Tcl_Tell(chan)); + Tcl_SetWideIntObj(Tcl_GetObjResult(interp), Tcl_Tell(chan)); return TCL_OK; } @@ -712,12 +725,12 @@ Tcl_ExecObjCmd(dummy, interp, objc, objv) #define NUM_ARGS 20 Tcl_Obj *resultPtr; - char **argv; + CONST char **argv; char *string; Tcl_Channel chan; - char *argStorage[NUM_ARGS]; + CONST char *argStorage[NUM_ARGS]; int argc, background, i, index, keepNewline, result, skip, length; - static char *options[] = { + static CONST char *options[] = { "-keepnewline", "--", NULL }; enum options { @@ -770,7 +783,7 @@ Tcl_ExecObjCmd(dummy, interp, objc, objv) argv = argStorage; argc = objc - skip; if ((argc + 1) > sizeof(argv) / sizeof(argv[0])) { - argv = (char **) ckalloc((unsigned)(argc + 1) * sizeof(char *)); + argv = (CONST char **) ckalloc((unsigned)(argc + 1) * sizeof(char *)); } /* @@ -953,7 +966,7 @@ Tcl_OpenObjCmd(notUsed, interp, objc, objv) */ if (!pipeline) { - chan = Tcl_OpenFileChannel(interp, what, modeString, prot); + chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot); } else { #ifdef MAC_TCL Tcl_AppendResult(interp, @@ -962,7 +975,7 @@ Tcl_OpenObjCmd(notUsed, interp, objc, objv) return TCL_ERROR; #else int mode, seekFlag, cmdObjc; - char **cmdArgv; + CONST char **cmdArgv; if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) { return TCL_ERROR; @@ -1286,7 +1299,7 @@ Tcl_SocketObjCmd(notUsed, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - static char *socketOptions[] = { + static CONST char *socketOptions[] = { "-async", "-myaddr", "-myport","-server", (char *) NULL }; enum socketOptions { @@ -1481,7 +1494,7 @@ Tcl_FcopyObjCmd(dummy, interp, objc, objv) int mode, i; int toRead, index; Tcl_Obj *cmdPtr; - static char* switches[] = { "-size", "-command", NULL }; + static CONST char* switches[] = { "-size", "-command", NULL }; enum { FcopySize, FcopyCommand }; if ((objc < 3) || (objc > 7) || (objc == 4) || (objc == 6)) { diff --git a/tcl/generic/tclIOGT.c b/tcl/generic/tclIOGT.c index 73a902221f4..e63349aa61d 100644 --- a/tcl/generic/tclIOGT.c +++ b/tcl/generic/tclIOGT.c @@ -31,17 +31,17 @@ static int TransformInputProc _ANSI_ARGS_ (( ClientData instanceData, char* buf, int toRead, int* errorCodePtr)); static int TransformOutputProc _ANSI_ARGS_ (( - ClientData instanceData, - char* buf, int toWrite, int* errorCodePtr)); + ClientData instanceData, CONST char *buf, + int toWrite, int* errorCodePtr)); static int TransformSeekProc _ANSI_ARGS_ (( ClientData instanceData, long offset, int mode, int* errorCodePtr)); static int TransformSetOptionProc _ANSI_ARGS_(( ClientData instanceData, Tcl_Interp *interp, - char *optionName, char *value)); + CONST char *optionName, CONST char *value)); static int TransformGetOptionProc _ANSI_ARGS_(( ClientData instanceData, Tcl_Interp *interp, - char *optionName, Tcl_DString *dsPtr)); + CONST char *optionName, Tcl_DString *dsPtr)); static void TransformWatchProc _ANSI_ARGS_ (( ClientData instanceData, int mask)); static int TransformGetFileHandleProc _ANSI_ARGS_ (( @@ -49,6 +49,9 @@ static int TransformGetFileHandleProc _ANSI_ARGS_ (( ClientData* handlePtr)); static int TransformNotifyProc _ANSI_ARGS_ (( ClientData instanceData, int mask)); +static Tcl_WideInt TransformWideSeekProc _ANSI_ARGS_ (( + ClientData instanceData, Tcl_WideInt offset, + int mode, int* errorCodePtr)); /* * Forward declarations of internal procedures. @@ -141,6 +144,7 @@ static Tcl_ChannelType transformChannelType = { TransformBlockModeProc, /* Set blocking/nonblocking mode.*/ NULL, /* Flush proc. */ TransformNotifyProc, /* Handling of events bubbling up */ + TransformWideSeekProc, /* Wide seek proc */ }; /* @@ -156,8 +160,8 @@ static Tcl_ChannelType transformChannelType = { struct ResultBuffer { unsigned char* buf; /* Reference to the buffer area */ - int allocated; /* Allocated size of the buffer area */ - int used; /* Number of bytes in the buffer, <= allocated */ + int allocated; /* Allocated size of the buffer area */ + int used; /* Number of bytes in the buffer, <= allocated */ }; /* @@ -171,7 +175,7 @@ struct ResultBuffer { * out information waiting in buffers (fileevent support). */ -#define DELAY (5) +#define FLUSH_DELAY (5) /* * Convenience macro to make some casts easier to use. @@ -357,11 +361,11 @@ TclChannelTransform(interp, chan, cmdObjPtr) static int ExecuteCallback (dataPtr, interp, op, buf, bufLen, transmit, preserve) - TransformChannelData* dataPtr; /* Transformation with the callback */ + TransformChannelData* dataPtr; /* Transformation with the callback */ Tcl_Interp* interp; /* Current interpreter, possibly NULL */ unsigned char* op; /* Operation invoking the callback */ unsigned char* buf; /* Buffer to give to the script. */ - int bufLen; /* Ands its length */ + int bufLen; /* Ands its length */ int transmit; /* Flag, determines whether the result * of the callback is sent to the * underlying channel or not. */ @@ -377,16 +381,14 @@ ExecuteCallback (dataPtr, interp, op, buf, bufLen, transmit, preserve) * arguments. Feather's curried commands would come in handy here. */ - Tcl_Obj* resObj; /* See below, switch (transmit) */ - int resLen; - unsigned char* resBuf; + Tcl_Obj* resObj; /* See below, switch (transmit) */ + int resLen; + unsigned char* resBuf; Tcl_SavedResult ciSave; - int res = TCL_OK; Tcl_Obj* command = Tcl_DuplicateObj (dataPtr->command); Tcl_Obj* temp; - if (preserve) { Tcl_SaveResult (dataPtr->interp, &ciSave); } @@ -641,7 +643,7 @@ static int TransformInputProc (instanceData, buf, toRead, errorCodePtr) ClientData instanceData; char* buf; - int toRead; + int toRead; int* errorCodePtr; { TransformChannelData* dataPtr = (TransformChannelData*) instanceData; @@ -764,8 +766,7 @@ TransformInputProc (instanceData, buf, toRead, errorCodePtr) */ res = ExecuteCallback (dataPtr, NO_INTERP, A_READ, - UCHARP (buf), read, TRANSMIT_IBUF, - P_PRESERVE); + UCHARP (buf), read, TRANSMIT_IBUF, P_PRESERVE); if (res != TCL_OK) { *errorCodePtr = EINVAL; @@ -796,7 +797,7 @@ TransformInputProc (instanceData, buf, toRead, errorCodePtr) static int TransformOutputProc (instanceData, buf, toWrite, errorCodePtr) ClientData instanceData; - char* buf; + CONST char* buf; int toWrite; int* errorCodePtr; { @@ -848,12 +849,11 @@ TransformOutputProc (instanceData, buf, toWrite, errorCodePtr) static int TransformSeekProc (instanceData, offset, mode, errorCodePtr) - ClientData instanceData; /* The channel to manipulate */ - long offset; /* Size of movement. */ - int mode; /* How to move */ - int* errorCodePtr; /* Location of error flag. */ + ClientData instanceData; /* The channel to manipulate */ + long offset; /* Size of movement. */ + int mode; /* How to move */ + int* errorCodePtr; /* Location of error flag. */ { - int result; TransformChannelData* dataPtr = (TransformChannelData*) instanceData; Tcl_Channel parent = Tcl_GetStackedChannel(dataPtr->self); Tcl_ChannelType* parentType = Tcl_GetChannelType(parent); @@ -864,9 +864,8 @@ TransformSeekProc (instanceData, offset, mode, errorCodePtr) * location. Simply pass the request down. */ - result = (*parentSeekProc) (Tcl_GetChannelInstanceData(parent), + return (*parentSeekProc) (Tcl_GetChannelInstanceData(parent), offset, mode, errorCodePtr); - return result; } /* @@ -887,9 +886,104 @@ TransformSeekProc (instanceData, offset, mode, errorCodePtr) dataPtr->readIsFlushed = 0; } - result = (*parentSeekProc) (Tcl_GetChannelInstanceData(parent), + return (*parentSeekProc) (Tcl_GetChannelInstanceData(parent), offset, mode, errorCodePtr); - return result; +} + +/* + *---------------------------------------------------------------------- + * + * TransformWideSeekProc -- + * + * This procedure is called by the generic IO level to move the + * access point in a channel, with a (potentially) 64-bit offset. + * + * Side effects: + * Moves the location at which the channel will be accessed in + * future operations. Flushes all transformation buffers, then + * forwards it to the underlying channel. + * + * Result: + * -1 if failed, the new position if successful. An output + * argument contains the POSIX error code if an error occurred, + * or zero. + * + *---------------------------------------------------------------------- + */ + +static Tcl_WideInt +TransformWideSeekProc (instanceData, offset, mode, errorCodePtr) + ClientData instanceData; /* The channel to manipulate */ + Tcl_WideInt 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); + Tcl_ChannelType* parentType = + Tcl_GetChannelType(parent); + Tcl_DriverSeekProc* parentSeekProc = + Tcl_ChannelSeekProc(parentType); + Tcl_DriverWideSeekProc* parentWideSeekProc = + Tcl_ChannelWideSeekProc(parentType); + ClientData parentData = + Tcl_GetChannelInstanceData(parent); + + if ((offset == Tcl_LongAsWide(0)) && (mode == SEEK_CUR)) { + /* + * This is no seek but a request to tell the caller the current + * location. Simply pass the request down. + */ + + if (parentWideSeekProc != NULL) { + return (*parentWideSeekProc) (parentData, offset, mode, + errorCodePtr); + } + + return Tcl_LongAsWide((*parentSeekProc) (parentData, 0, mode, + errorCodePtr)); + } + + /* + * It is a real request to change the position. Flush all data waiting + * for output and discard everything in the input buffers. Then pass + * the request down, unchanged. + */ + + if (dataPtr->mode & TCL_WRITABLE) { + ExecuteCallback (dataPtr, NO_INTERP, A_FLUSH_WRITE, + NULL, 0, TRANSMIT_DOWN, P_NO_PRESERVE); + } + + if (dataPtr->mode & TCL_READABLE) { + ExecuteCallback (dataPtr, NO_INTERP, A_CLEAR_READ, + NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE); + ResultClear(&dataPtr->result); + dataPtr->readIsFlushed = 0; + } + + /* + * If we have a wide seek capability, we should stick with that. + */ + if (parentWideSeekProc != NULL) { + return (*parentWideSeekProc) (parentData, offset, mode, errorCodePtr); + } + + /* + * 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. + */ + if (offset<Tcl_LongAsWide(LONG_MIN) || offset>Tcl_LongAsWide(LONG_MAX)) { + *errorCodePtr = EOVERFLOW; + return Tcl_LongAsWide(-1); + } + return Tcl_LongAsWide((*parentSeekProc) (parentData, + Tcl_WideAsLong(offset), mode, errorCodePtr)); } /* @@ -915,8 +1009,8 @@ static int TransformSetOptionProc (instanceData, interp, optionName, value) ClientData instanceData; Tcl_Interp *interp; - char *optionName; - char *value; + CONST char *optionName; + CONST char *value; { TransformChannelData* dataPtr = (TransformChannelData*) instanceData; Tcl_Channel downChan = Tcl_GetStackedChannel(dataPtr->self); @@ -953,7 +1047,7 @@ static int TransformGetOptionProc (instanceData, interp, optionName, dsPtr) ClientData instanceData; Tcl_Interp* interp; - char* optionName; + CONST char* optionName; Tcl_DString* dsPtr; { TransformChannelData* dataPtr = (TransformChannelData*) instanceData; @@ -964,7 +1058,7 @@ TransformGetOptionProc (instanceData, interp, optionName, dsPtr) if (getOptionProc != NULL) { return (*getOptionProc)(Tcl_GetChannelInstanceData(downChan), interp, optionName, dsPtr); - } else if (optionName == (char*) NULL) { + } else if (optionName == (CONST char*) NULL) { /* * Request is query for all options, this is ok. */ @@ -1046,7 +1140,7 @@ TransformWatchProc (instanceData, mask) * to flush that. */ - dataPtr->timer = Tcl_CreateTimerHandler (DELAY, + dataPtr->timer = Tcl_CreateTimerHandler (FLUSH_DELAY, TransformChannelHandlerTimer, (ClientData) dataPtr); } } @@ -1274,7 +1368,7 @@ static int ResultCopy (r, buf, toRead) ResultBuffer* r; /* The buffer to read from */ unsigned char* buf; /* The buffer to copy into */ - int toRead; /* Number of requested bytes */ + int toRead; /* Number of requested bytes */ { if (r->used == 0) { /* Nothing to copy in the case of an empty buffer. @@ -1337,7 +1431,7 @@ static void ResultAdd (r, buf, toWrite) ResultBuffer* r; /* The buffer to extend */ unsigned char* buf; /* The buffer to read from */ - int toWrite; /* The number of bytes in 'buf' */ + int toWrite; /* The number of bytes in 'buf' */ { if ((r->used + toWrite) > r->allocated) { /* Extension of the internal buffer is required. diff --git a/tcl/generic/tclIOSock.c b/tcl/generic/tclIOSock.c index 031db7856dc..11228793149 100644 --- a/tcl/generic/tclIOSock.c +++ b/tcl/generic/tclIOSock.c @@ -43,7 +43,7 @@ TclSockGetPort(interp, string, proto, portPtr) { struct servent *sp; /* Protocol info for named services */ Tcl_DString ds; - char *native; + CONST char *native; if (Tcl_GetInt(NULL, string, portPtr) != TCL_OK) { /* @@ -91,10 +91,7 @@ TclSockMinimumBuffers(sock, size) int size; /* Minimum buffer size */ { int current; - /* - * Should be socklen_t, but HP10.20 (g)cc chokes - */ - size_t len; + socklen_t len; len = sizeof(int); getsockopt(sock, SOL_SOCKET, SO_SNDBUF, (char *)¤t, &len); @@ -110,4 +107,3 @@ TclSockMinimumBuffers(sock, size) } return TCL_OK; } - diff --git a/tcl/generic/tclIOUtil.c b/tcl/generic/tclIOUtil.c index 445a29d7108..af1bd03a837 100644 --- a/tcl/generic/tclIOUtil.c +++ b/tcl/generic/tclIOUtil.c @@ -1,8 +1,12 @@ /* * tclIOUtil.c -- * - * This file contains a collection of utility procedures that - * are shared by the platform specific IO drivers. + * 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. * * Parts of this file are based on code contributed by Karl * Lehenbauer, Mark Diekhans and Peter da Silva. @@ -18,7 +22,237 @@ #include "tclInt.h" #include "tclPort.h" +#ifdef MAC_TCL +#include "tclMacInt.h" +#endif +#ifdef __WIN32__ +/* for tclWinProcs->useWide */ +#include "tclWinInt.h" +#endif + +/* + * Prototypes for procedures defined later in this file. + */ + +static void DupFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr)); +static void FreeFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *listPtr)); +static int SetFsPathFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); +static Tcl_Obj* FSNormalizeAbsolutePath + _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj *pathPtr)); +static int TclNormalizeToUniquePath + _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr)); +static int SetFsPathFromAbsoluteNormalized + _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); +static int FindSplitPos _ANSI_ARGS_((char *path, char *separator)); +static Tcl_PathType FSGetPathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr, + Tcl_Filesystem **filesystemPtrPtr, + int *driveNameLengthPtr)); +static Tcl_PathType GetPathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr, + Tcl_Filesystem **filesystemPtrPtr, + int *driveNameLengthPtr, Tcl_Obj **driveNameRef)); + +/* + * Define the 'path' object type, which Tcl uses to represent + * file paths internally. + */ +Tcl_ObjType tclFsPathType = { + "path", /* name */ + FreeFsPathInternalRep, /* freeIntRepProc */ + DupFsPathInternalRep, /* dupIntRepProc */ + NULL, /* updateStringProc */ + SetFsPathFromAny /* setFromAnyProc */ +}; + +/* + * 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 mac/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. + */ +extern CONST char * tclpFileAttrStrings[]; +extern CONST TclFileAttrProcs tclpFileAttrProcs[]; + +/* + * The following functions are obsolete string based APIs, and should + * be removed in a future release (Tcl 9 would be a good time). + */ +/* Obsolete */ +int +Tcl_Stat(path, oldStyleBuf) + CONST char *path; /* Path of file to stat (in current CP). */ + struct stat *oldStyleBuf; /* Filled with results of stat call. */ +{ + int ret; + Tcl_StatBuf buf; + Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1); + + Tcl_IncrRefCount(pathPtr); + ret = Tcl_FSStat(pathPtr, &buf); + Tcl_DecrRefCount(pathPtr); + if (ret != -1) { +#ifndef TCL_WIDE_INT_IS_LONG +# define OUT_OF_RANGE(x) \ + (((Tcl_WideInt)(x)) < Tcl_LongAsWide(LONG_MIN) || \ + ((Tcl_WideInt)(x)) > Tcl_LongAsWide(LONG_MAX)) +# define OUT_OF_URANGE(x) \ + (((Tcl_WideUInt)(x)) > (Tcl_WideUInt)ULONG_MAX) + + /* + * Perform the result-buffer overflow check manually. + * + * Note that ino_t/ino64_t is unsigned... + */ + + if (OUT_OF_URANGE(buf.st_ino) || OUT_OF_RANGE(buf.st_size) +#ifdef HAVE_ST_BLOCKS + || OUT_OF_RANGE(buf.st_blocks) +#endif + ) { +#ifdef EFBIG + errno = EFBIG; +#else +# ifdef EOVERFLOW + errno = EOVERFLOW; +# else +# error "What status should be returned for file size out of range?" +# endif +#endif + return -1; + } + +# undef OUT_OF_RANGE +# undef OUT_OF_URANGE +#endif /* !TCL_WIDE_INT_IS_LONG */ + + /* + * Copy across all supported fields, with possible type + * coercions on those fields that change between the normal + * and lf64 versions of the stat structure (on Solaris at + * least.) This is slow when the structure sizes coincide, + * but that's what you get for using an obsolete interface. + */ + + oldStyleBuf->st_mode = buf.st_mode; + oldStyleBuf->st_ino = (ino_t) buf.st_ino; + oldStyleBuf->st_dev = buf.st_dev; + oldStyleBuf->st_rdev = buf.st_rdev; + oldStyleBuf->st_nlink = buf.st_nlink; + oldStyleBuf->st_uid = buf.st_uid; + oldStyleBuf->st_gid = buf.st_gid; + oldStyleBuf->st_size = (off_t) buf.st_size; + oldStyleBuf->st_atime = buf.st_atime; + oldStyleBuf->st_mtime = buf.st_mtime; + oldStyleBuf->st_ctime = buf.st_ctime; +#ifdef HAVE_ST_BLOCKS + oldStyleBuf->st_blksize = buf.st_blksize; + oldStyleBuf->st_blocks = (blkcnt_t) buf.st_blocks; +#endif + } + return ret; +} + +/* Obsolete */ +int +Tcl_Access(path, mode) + CONST char *path; /* Path of file to access (in current CP). */ + int mode; /* Permission setting. */ +{ + int ret; + Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1); + Tcl_IncrRefCount(pathPtr); + ret = Tcl_FSAccess(pathPtr,mode); + Tcl_DecrRefCount(pathPtr); + return ret; +} + +/* Obsolete */ +Tcl_Channel +Tcl_OpenFileChannel(interp, path, modeString, permissions) + Tcl_Interp *interp; /* Interpreter for error reporting; + * can be NULL. */ + CONST char *path; /* Name of file to open. */ + CONST char *modeString; /* A list of POSIX open modes or + * a string such as "rw". */ + int permissions; /* If the open involves creating a + * file, with what modes to create + * it? */ +{ + Tcl_Channel ret; + Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1); + Tcl_IncrRefCount(pathPtr); + ret = Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions); + Tcl_DecrRefCount(pathPtr); + return ret; + +} + +/* Obsolete */ +int +Tcl_Chdir(dirName) + CONST char *dirName; +{ + int ret; + Tcl_Obj *pathPtr = Tcl_NewStringObj(dirName,-1); + Tcl_IncrRefCount(pathPtr); + ret = Tcl_FSChdir(pathPtr); + Tcl_DecrRefCount(pathPtr); + return ret; +} + +/* Obsolete */ +char * +Tcl_GetCwd(interp, cwdPtr) + Tcl_Interp *interp; + Tcl_DString *cwdPtr; +{ + Tcl_Obj *cwd; + cwd = Tcl_FSGetCwd(interp); + if (cwd == NULL) { + return NULL; + } else { + Tcl_DStringInit(cwdPtr); + Tcl_DStringAppend(cwdPtr, Tcl_GetString(cwd), -1); + Tcl_DecrRefCount(cwd); + return Tcl_DStringValue(cwdPtr); + } +} + +/* Obsolete */ +int +Tcl_EvalFile(interp, fileName) + 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. */ +{ + int ret; + Tcl_Obj *pathPtr = Tcl_NewStringObj(fileName,-1); + Tcl_IncrRefCount(pathPtr); + ret = Tcl_FSEvalFile(interp, pathPtr); + Tcl_DecrRefCount(pathPtr); + return ret; +} + + +/* + * The 3 hooks for Stat, Access and OpenFileChannel are obsolete. The + * complete, general hooked filesystem APIs should be used instead. + * This define decides whether to include the obsolete hooks and + * related code. If these are removed, we'll also want to remove them + * from stubs/tclInt. The only known users of these APIs are prowrap + * and mktclapp. New code/extensions should not use them, since they + * do not provide as full support as the full filesystem API. + * + * As soon as prowrap and mktclapp are updated to use the full + * filesystem support, I suggest all these hooks are removed. + */ +#define USE_OBSOLETE_FS_HOOKS + + +#ifdef USE_OBSOLETE_FS_HOOKS /* * The following typedef declarations allow for hooking into the chain * of functions maintained for 'Tcl_Stat(...)', 'Tcl_Access(...)' & @@ -45,10 +279,10 @@ typedef struct OpenFileChannelProc { } OpenFileChannelProc; /* - * For each type of hookable function, a static node is declared to - * hold the function pointer for the "built-in" routine (e.g. - * 'TclpStat(...)') and the respective list is initialized as a pointer - * to that node. + * For each type of (obsolete) hookable function, a static node is + * declared to hold the function pointer for the "built-in" routine + * (e.g. 'TclpStat(...)') and the respective list is initialized as a + * pointer to that node. * * The "delete" functions (e.g. 'TclStatDeleteProc(...)') ensure that * these statically declared list entry cannot be inadvertently removed. @@ -56,26 +290,829 @@ typedef struct OpenFileChannelProc { * This method avoids the need to call any sort of "initialization" * function. * - * All three lists are protected by a global hookMutex. + * All three lists are protected by a global obsoleteFsHookMutex. */ -static StatProc defaultStatProc = { - &TclpStat, NULL -}; -static StatProc *statProcList = &defaultStatProc; +static StatProc *statProcList = NULL; +static AccessProc *accessProcList = NULL; +static OpenFileChannelProc *openFileChannelProcList = NULL; + +TCL_DECLARE_MUTEX(obsoleteFsHookMutex) + +#endif /* USE_OBSOLETE_FS_HOOKS */ -static AccessProc defaultAccessProc = { - &TclpAccess, NULL +/* + * A filesystem record is used to keep track of each + * filesystem currently registered with the core, + * in a linked list. + */ +typedef struct FilesystemRecord { + ClientData clientData; /* Client specific data for the new + * filesystem (can be NULL) */ + Tcl_Filesystem *fsPtr; /* Pointer to filesystem dispatch + * table. */ + int fileRefCount; /* How many Tcl_Obj's use this + * filesystem. */ + struct FilesystemRecord *nextPtr; + /* The next filesystem registered + * to Tcl, or NULL if no more. */ +} FilesystemRecord; + +static FilesystemRecord* GetFilesystemRecord + _ANSI_ARGS_((Tcl_Filesystem *fromFilesystem, int *epoch)); + +/* + * Declare the native filesystem support. These functions should + * be considered private to Tcl, and should really not be called + * directly by any code other than this file (i.e. neither by + * Tcl's core nor by extensions). Similarly, the old string-based + * Tclp... native filesystem functions should not be called. + * + * The correct API to use now is the Tcl_FS... set of functions, + * which ensure correct and complete virtual filesystem support. + * + * We cannot make all of these static, since some of them + * are implemented in the platform-specific directories. + */ +static Tcl_FSPathInFilesystemProc NativePathInFilesystem; +static Tcl_FSFilesystemSeparatorProc NativeFilesystemSeparator; +static Tcl_FSFreeInternalRepProc NativeFreeInternalRep; +static Tcl_FSDupInternalRepProc NativeDupInternalRep; +static Tcl_FSCreateInternalRepProc NativeCreateNativeRep; +static Tcl_FSFileAttrStringsProc NativeFileAttrStrings; +static Tcl_FSFileAttrsGetProc NativeFileAttrsGet; +static Tcl_FSFileAttrsSetProc NativeFileAttrsSet; +static Tcl_FSUtimeProc NativeUtime; + +/* + * The only reason these functions are not static is that they + * are either called by code in the native (win/unix/mac) directories + * or they are actually implemented in those directories. They + * should simply not be called by code outside Tcl's native + * filesystem core. i.e. they should be considered 'static' to + * Tcl's filesystem code (if we ever built the native filesystem + * support into a separate code library, this could actually be + * enforced). + */ +Tcl_FSFilesystemPathTypeProc TclpFilesystemPathType; +Tcl_FSInternalToNormalizedProc TclpNativeToNormalized; +Tcl_FSStatProc TclpObjStat; +Tcl_FSAccessProc TclpObjAccess; +Tcl_FSMatchInDirectoryProc TclpMatchInDirectory; +Tcl_FSGetCwdProc TclpObjGetCwd; +Tcl_FSChdirProc TclpObjChdir; +Tcl_FSLstatProc TclpObjLstat; +Tcl_FSCopyFileProc TclpObjCopyFile; +Tcl_FSDeleteFileProc TclpObjDeleteFile; +Tcl_FSRenameFileProc TclpObjRenameFile; +Tcl_FSCreateDirectoryProc TclpObjCreateDirectory; +Tcl_FSCopyDirectoryProc TclpObjCopyDirectory; +Tcl_FSRemoveDirectoryProc TclpObjRemoveDirectory; +Tcl_FSUnloadFileProc TclpUnloadFile; +Tcl_FSLinkProc TclpObjLink; +Tcl_FSListVolumesProc TclpObjListVolumes; + +/* + * Define the native filesystem dispatch table. If necessary, it + * is ok to make this non-static, but it should only be accessed + * by the functions actually listed within it (or perhaps other + * helper functions of them). Anything which is not part of this + * 'native filesystem implementation' should not be delving inside + * here! + */ +static Tcl_Filesystem tclNativeFilesystem = { + "native", + sizeof(Tcl_Filesystem), + TCL_FILESYSTEM_VERSION_1, + &NativePathInFilesystem, + &NativeDupInternalRep, + &NativeFreeInternalRep, + &TclpNativeToNormalized, + &NativeCreateNativeRep, + &TclpObjNormalizePath, + &TclpFilesystemPathType, + &NativeFilesystemSeparator, + &TclpObjStat, + &TclpObjAccess, + &TclpOpenFileChannel, + &TclpMatchInDirectory, + &NativeUtime, +#ifndef S_IFLNK + NULL, +#else + &TclpObjLink, +#endif /* S_IFLNK */ + &TclpObjListVolumes, + &NativeFileAttrStrings, + &NativeFileAttrsGet, + &NativeFileAttrsSet, + &TclpObjCreateDirectory, + &TclpObjRemoveDirectory, + &TclpObjDeleteFile, + &TclpObjCopyFile, + &TclpObjRenameFile, + &TclpObjCopyDirectory, + &TclpObjLstat, + &TclpDlopen, + &TclpObjGetCwd, + &TclpObjChdir }; -static AccessProc *accessProcList = &defaultAccessProc; -static OpenFileChannelProc defaultOpenFileChannelProc = { - &TclpOpenFileChannel, NULL +/* + * Define the tail of the linked list. Note that for unconventional + * uses of Tcl without a native filesystem, we may in the future wish + * to modify the current approach of hard-coding the native filesystem + * in the lookup list 'filesystemList' below. + * + * We initialize the record so that it thinks one file uses it. This + * means it will never be freed. + */ +static FilesystemRecord nativeFilesystemRecord = { + NULL, + &tclNativeFilesystem, + 1, + NULL }; -static OpenFileChannelProc *openFileChannelProcList = - &defaultOpenFileChannelProc; -TCL_DECLARE_MUTEX(hookMutex) +/* + * The following few variables are protected by the + * filesystemMutex just below. + */ + +/* + * 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. + */ +static int theFilesystemEpoch = 0; + +/* + * Stores the linked list of filesystems. + */ +static FilesystemRecord *filesystemList = &nativeFilesystemRecord; + +/* + * The number of loops which are currently iterating over the linked + * list. If this is greater than zero, we can't modify the list. + */ +static int filesystemIteratorsInProgress = 0; + +/* + * Someone wants to modify the list of filesystems if this is set. + */ +static int filesystemWantToModify = 0; + +#ifdef TCL_THREADS +static Tcl_Condition filesystemOkToModify = NULL; +#endif + +TCL_DECLARE_MUTEX(filesystemMutex) + +/* + * 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 'normPathPtr' can be a circular reference to the + * container Tcl_Obj of this FsPath. + */ +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. */ + ClientData nativePathPtr; /* Native representation of this path, + * which is filesystem dependent. */ + int filesystemEpoch; /* Used to ensure the path representation + * was generated during the correct + * filesystem epoch. The epoch changes + * when filesystem-mounts are changed. */ + struct FilesystemRecord *fsRecPtr; + /* Pointer to the filesystem record + * entry to use for this path. */ +} FsPath; + +/* + * Used to implement Tcl_FSGetCwd in a file-system independent way. + * This is protected by the cwdMutex below. + */ +static Tcl_Obj* cwdPathPtr = NULL; +TCL_DECLARE_MUTEX(cwdMutex) + +/* + * Declare fallback support function and + * information for Tcl_FSLoadFile + */ +static Tcl_FSUnloadFileProc FSUnloadTempFile; + +/* + * One of these structures is used each time we successfully load a + * file from a file system by way of making a temporary copy of the + * file on the native filesystem. We need to store both the actual + * unloadProc/clientData combination which was used, and the original + * and modified filenames, so that we can correctly undo the entire + * operation when we want to unload the code. + */ +typedef struct FsDivertLoad { + Tcl_LoadHandle loadHandle; + Tcl_FSUnloadFileProc *unloadProcPtr; + Tcl_Obj *divertedFile; + Tcl_Filesystem *divertedFilesystem; + ClientData divertedFileNativeRep; +} FsDivertLoad; + +/* Now move on to the basic filesystem implementation */ + + +static int +FsCwdPointerEquals(objPtr) + Tcl_Obj* objPtr; +{ + Tcl_MutexLock(&cwdMutex); + if (cwdPathPtr == objPtr) { + Tcl_MutexUnlock(&cwdMutex); + return 1; + } else { + Tcl_MutexUnlock(&cwdMutex); + return 0; + } +} + + +static FilesystemRecord* +FsGetIterator(void) { + Tcl_MutexLock(&filesystemMutex); + filesystemIteratorsInProgress++; + Tcl_MutexUnlock(&filesystemMutex); + /* Now we know the list of filesystems cannot be modified */ + return filesystemList; +} + +static void +FsReleaseIterator(void) { + Tcl_MutexLock(&filesystemMutex); + filesystemIteratorsInProgress--; + if (filesystemIteratorsInProgress == 0) { + /* Notify any waiting threads that things are ok now */ + if (filesystemWantToModify > 0) { + Tcl_ConditionNotify(&filesystemOkToModify); + } + } + Tcl_MutexUnlock(&filesystemMutex); +} + +/* + *---------------------------------------------------------------------- + * + * TclFinalizeFilesystem -- + * + * Clean up the filesystem. After this, calls to all Tcl_FS... + * functions will fail. + * + * Note that, since 'TclFinalizeLoad' may unload extensions + * which implement other filesystems, and which may therefore + * contain a 'freeProc' for those filesystems, at this stage + * we _must_ have freed all objects of "path" type, or we may + * end up with segfaults if we try to free them later. + * + * Results: + * None. + * + * Side effects: + * Frees any memory allocated by the filesystem. Unloads any + * extensions which have been loaded. + * + *---------------------------------------------------------------------- + */ + +void +TclFinalizeFilesystem() { + /* + * Assumption that only one thread is active now. Otherwise + * we would need to put various mutexes around this code. + */ + + if (cwdPathPtr != NULL) { + Tcl_DecrRefCount(cwdPathPtr); + cwdPathPtr = NULL; + } + + /* + * We defer unloading of packages until very late + * to avoid memory access issues. Both exit callbacks and + * synchronization variables may be stored in packages. + * + * Note that TclFinalizeLoad unloads packages in the reverse + * of the order they were loaded in (i.e. last to be loaded + * is the first to be unloaded). This can be important for + * correct unloading when dependencies exist. + */ + + TclFinalizeLoad(); + + /* Remove all filesystems, freeing any allocated memory */ + while (filesystemList != NULL) { + FilesystemRecord *tmpFsRecPtr = filesystemList->nextPtr; + if (filesystemList->fileRefCount > 1) { + /* + * We are freeing a filesystem which actually has + * path objects still around which belong to it. + * This is probably bad, but since we are exiting, + * we don't do anything about it. + */ + } + /* The native filesystem is static, so we don't free it */ + if (filesystemList != &nativeFilesystemRecord) { + ckfree((char *)filesystemList); + } + filesystemList = tmpFsRecPtr; + } + /* Now filesystemList is NULL */ +} + +/* + *---------------------------------------------------------------------- + * + * 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. + * + * 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. + * + * Results: + * Normally TCL_OK; TCL_ERROR if memory for a new node in the list + * could not be allocated. + * + * Side effects: + * Memory allocated and modifies the link list for filesystems. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_FSRegister(clientData, fsPtr) + ClientData clientData; /* Client specific data for this fs */ + Tcl_Filesystem *fsPtr; /* The filesystem record for the new fs. */ +{ + FilesystemRecord *newFilesystemPtr; + + if (fsPtr == NULL) { + return TCL_ERROR; + } + + newFilesystemPtr = (FilesystemRecord *) ckalloc(sizeof(FilesystemRecord)); + + newFilesystemPtr->clientData = clientData; + newFilesystemPtr->fsPtr = fsPtr; + /* + * We start with a refCount of 1. If this drops to zero, then + * anyone is welcome to ckfree us. + */ + newFilesystemPtr->fileRefCount = 1; + + /* + * 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); + if (filesystemIteratorsInProgress) { + filesystemWantToModify++; + Tcl_ConditionWait(&filesystemOkToModify, &filesystemMutex, NULL); + filesystemWantToModify--; + } + + newFilesystemPtr->nextPtr = filesystemList; + filesystemList = newFilesystemPtr; + /* + * Increment the filesystem epoch counter, since existing paths + * might conceivably now belong to different filesystems. + */ + theFilesystemEpoch++; + Tcl_MutexUnlock(&filesystemMutex); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * 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). + * + * Results: + * TCL_OK if the procedure pointer was successfully removed, + * 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. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_FSUnregister(fsPtr) + Tcl_Filesystem *fsPtr; /* The filesystem record to remove. */ +{ + int retVal = TCL_ERROR; + FilesystemRecord *tmpFsRecPtr; + FilesystemRecord *prevFsRecPtr = NULL; + + Tcl_MutexLock(&filesystemMutex); + if (filesystemIteratorsInProgress) { + filesystemWantToModify++; + Tcl_ConditionWait(&filesystemOkToModify, &filesystemMutex, NULL); + filesystemWantToModify--; + } + tmpFsRecPtr = filesystemList; + /* + * 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. + */ + + while ((retVal == TCL_ERROR) && (tmpFsRecPtr != &nativeFilesystemRecord)) { + if (tmpFsRecPtr->fsPtr == fsPtr) { + if (prevFsRecPtr == NULL) { + filesystemList = filesystemList->nextPtr; + } else { + prevFsRecPtr->nextPtr = tmpFsRecPtr->nextPtr; + } + /* + * 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). + */ + theFilesystemEpoch++; + + tmpFsRecPtr->fileRefCount--; + if (tmpFsRecPtr->fileRefCount <= 0) { + ckfree((char *)tmpFsRecPtr); + } + + retVal = TCL_OK; + } else { + prevFsRecPtr = tmpFsRecPtr; + tmpFsRecPtr = tmpFsRecPtr->nextPtr; + } + } + + Tcl_MutexUnlock(&filesystemMutex); + return (retVal); +} + +/* + *---------------------------------------------------------------------- + * + * 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. + * + * 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: + * + * (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. + * + * (2) when additional mount points are established inside any + * existing filesystem (except the native fs) + * + * (3) when any filesystem (except the native fs) changes the list + * of available volumes. + * + * (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. + * + * Tcl has no control over (2) and (3), so any registered filesystem + * must make sure it calls this function when those situations + * occur. + * + * (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). + * + *---------------------------------------------------------------------- + */ + +void +Tcl_FSMountsChanged(fsPtr) + 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. + */ + (void)fsPtr; + /* + * Increment the filesystem epoch counter, since existing paths + * might now belong to different filesystems. + */ + Tcl_MutexLock(&filesystemMutex); + theFilesystemEpoch++; + Tcl_MutexUnlock(&filesystemMutex); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FSData -- + * + * Retrieve the clientData field for the filesystem given, + * or NULL if that filesystem is not registered. + * + * 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. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +ClientData +Tcl_FSData(fsPtr) + Tcl_Filesystem *fsPtr; /* The filesystem record to query. */ +{ + ClientData retVal = NULL; + FilesystemRecord *tmpFsRecPtr; + + tmpFsRecPtr = FsGetIterator(); + /* + * 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. + */ + + while ((retVal == NULL) && (tmpFsRecPtr != NULL)) { + if (tmpFsRecPtr->fsPtr == fsPtr) { + retVal = tmpFsRecPtr->clientData; + } + tmpFsRecPtr = tmpFsRecPtr->nextPtr; + } + + FsReleaseIterator(); + return (retVal); +} + +/* + *--------------------------------------------------------------------------- + * + * FSNormalizeAbsolutePath -- + * + * Description: + * Takes an absolute path specification and computes a 'normalized' + * path from it. + * + * A normalized path is one which has all '../', './' removed. + * Also it is one which is in the 'standard' format for the native + * platform. On MacOS, 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). + * + * The behaviour of this function if passed a non-absolute path + * is NOT defined. + * + * 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. + * + * Side effects: + * None (beyond the memory allocation for the result). + * + * Special note: + * This code is based on code from Matt Newman and Jean-Claude + * Wippler, with additions from Vince Darley and is copyright + * those respective authors. + * + *--------------------------------------------------------------------------- + */ +static Tcl_Obj* +FSNormalizeAbsolutePath(interp, pathPtr) + Tcl_Interp* interp; /* Interpreter to use */ + Tcl_Obj *pathPtr; /* Absolute path to normalize */ +{ + int splen = 0, nplen, i; + Tcl_Obj *retVal; + Tcl_Obj *split; + + /* Split has refCount zero */ + split = Tcl_FSSplitPath(pathPtr, &splen); + + /* + * Modify the list of entries in place, by removing '.', and + * removing '..' and the entry before -- unless that entry before + * is the top-level entry, i.e. the name of a volume. + */ + nplen = 0; + for (i = 0;i < splen;i++) { + Tcl_Obj *elt; + Tcl_ListObjIndex(NULL, split, nplen, &elt); + + if (strcmp(Tcl_GetString(elt), ".") == 0) { + Tcl_ListObjReplace(NULL, split, nplen, 1, 0, NULL); + } else if (strcmp(Tcl_GetString(elt), "..") == 0) { + if (nplen > 1) { + nplen--; + Tcl_ListObjReplace(NULL, split, nplen, 2, 0, NULL); + } else { + Tcl_ListObjReplace(NULL, split, nplen, 1, 0, NULL); + } + } else { + nplen++; + } + } + if (nplen > 0) { + retVal = Tcl_FSJoinPath(split, nplen); + /* + * Now we have an absolute path, with no '..', '.' sequences, + * but it still may not be in 'unique' form, depending on the + * platform. For instance, Unix is case-sensitive, so the + * path is ok. Windows is case-insensitive, and also has the + * weird 'longname/shortname' thing (e.g. C:/Program Files/ and + * C:/Progra~1/ are equivalent). MacOS is case-insensitive. + * + * Virtual file systems which may be registered may have + * other criteria for normalizing a path. + */ + Tcl_IncrRefCount(retVal); + TclNormalizeToUniquePath(interp, retVal); + /* + * Since we know it is a normalized path, we can + * actually convert this object into an FsPath for + * greater efficiency + */ + SetFsPathFromAbsoluteNormalized(interp, retVal); + } else { + /* Init to an empty string */ + retVal = Tcl_NewStringObj("",0); + Tcl_IncrRefCount(retVal); + } + /* + * We increment and then decrement the refCount of split to free + * it. We do this right at the end, in case there are + * optimisations in Tcl_FSJoinPath(split, nplen) above which would + * let it make use of split more effectively if it has a refCount + * of zero. Also we can't just decrement the ref count, in case + * 'split' was actually returned by the join call above, in a + * single-element optimisation when nplen == 1. + */ + Tcl_IncrRefCount(split); + Tcl_DecrRefCount(split); + + /* This has a refCount of 1 for the caller */ + return retVal; +} + +/* + *--------------------------------------------------------------------------- + * + * TclNormalizeToUniquePath -- + * + * Description: + * Takes a path specification containing no ../, ./ sequences, + * and converts it into a unique path for the given platform. + * On MacOS, 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). + * + * 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. + * + * Side effects: + * None (beyond the memory allocation for the result). + * + * Special note: + * This is only used by the above function. Also 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/macos. + * + *--------------------------------------------------------------------------- + */ +static int +TclNormalizeToUniquePath(interp, pathPtr) + Tcl_Interp *interp; + Tcl_Obj *pathPtr; +{ + FilesystemRecord *fsRecPtr; + int retVal = 0; + + /* + * 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). + */ + + fsRecPtr = FsGetIterator(); + while (fsRecPtr != NULL) { + if (fsRecPtr == &nativeFilesystemRecord) { + Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc; + if (proc != NULL) { + retVal = (*proc)(interp, pathPtr, retVal); + } + break; + } + fsRecPtr = fsRecPtr->nextPtr; + } + FsReleaseIterator(); + + fsRecPtr = FsGetIterator(); + while (fsRecPtr != NULL) { + /* Skip the native system next time through */ + if (fsRecPtr != &nativeFilesystemRecord) { + Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc; + if (proc != NULL) { + retVal = (*proc)(interp, pathPtr, retVal); + } + /* + * We could add an efficiency check like this: + * + * if (retVal == length-of(pathPtr)) {break;} + * + * but there's not much benefit. + */ + } + fsRecPtr = fsRecPtr->nextPtr; + } + FsReleaseIterator(); + + return (retVal); +} /* *--------------------------------------------------------------------------- @@ -107,14 +1144,14 @@ int TclGetOpenMode(interp, string, seekFlagPtr) Tcl_Interp *interp; /* Interpreter to use for error * reporting - may be NULL. */ - char *string; /* Mode string, e.g. "r+" or + CONST char *string; /* 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 mode, modeArgc, c, i, gotRW; - char **modeArgv, *flag; + CONST char **modeArgv, *flag; #define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR) /* @@ -255,7 +1292,7 @@ TclGetOpenMode(interp, string, seekFlagPtr) /* *---------------------------------------------------------------------- * - * Tcl_EvalFile -- + * Tcl_FSEvalFile -- * * Read in a file and process the entire file as one gigantic * Tcl command. @@ -265,50 +1302,60 @@ TclGetOpenMode(interp, string, seekFlagPtr) * the file or an error indicating why the file couldn't be read. * * Side effects: - * Depends on the commands in the file. + * 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). * *---------------------------------------------------------------------- */ int -Tcl_EvalFile(interp, fileName) +Tcl_FSEvalFile(interp, pathPtr) Tcl_Interp *interp; /* Interpreter in which to process file. */ - char *fileName; /* Name of file to process. Tilde-substitution + Tcl_Obj *pathPtr; /* Path of file to process. Tilde-substitution * will be performed on this name. */ { int result, length; - struct stat statBuf; - char *oldScriptFile; + Tcl_StatBuf statBuf; + Tcl_Obj *oldScriptFile; Interp *iPtr; - Tcl_DString nameString; - char *name, *string; + char *string; Tcl_Channel chan; Tcl_Obj *objPtr; - name = Tcl_TranslateFileName(interp, fileName, &nameString); - if (name == NULL) { + if (Tcl_FSGetTranslatedPath(interp, pathPtr) == NULL) { return TCL_ERROR; } result = TCL_ERROR; objPtr = Tcl_NewObj(); - if (TclStat(name, &statBuf) == -1) { + if (Tcl_FSStat(pathPtr, &statBuf) == -1) { Tcl_SetErrno(errno); - Tcl_AppendResult(interp, "couldn't read file \"", fileName, + Tcl_AppendResult(interp, "couldn't read file \"", + Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), (char *) NULL); goto end; } - chan = Tcl_OpenFileChannel(interp, name, "r", 0644); + chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644); if (chan == (Tcl_Channel) NULL) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't read file \"", fileName, + Tcl_AppendResult(interp, "couldn't read file \"", + Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), (char *) NULL); goto end; } + /* + * The eofchar is \32 (^Z). This is the usual on Windows, but we + * effect this cross-platform to allow for scripted documents. + * [Bug: 2040] + */ + Tcl_SetChannelOption(interp, chan, "-eofchar", "\32"); if (Tcl_ReadChars(chan, objPtr, -1, 0) < 0) { Tcl_Close(interp, chan); - Tcl_AppendResult(interp, "couldn't read file \"", fileName, + Tcl_AppendResult(interp, "couldn't read file \"", + Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), (char *) NULL); goto end; } @@ -318,9 +1365,18 @@ Tcl_EvalFile(interp, fileName) iPtr = (Interp *) interp; oldScriptFile = iPtr->scriptFile; - iPtr->scriptFile = fileName; + iPtr->scriptFile = pathPtr; + Tcl_IncrRefCount(iPtr->scriptFile); string = Tcl_GetStringFromObj(objPtr, &length); result = Tcl_EvalEx(interp, string, length, 0); + /* + * Now we have to be careful; the script may have changed the + * iPtr->scriptFile value, so we must reset it without + * assuming it still points to 'pathPtr'. + */ + if (iPtr->scriptFile != NULL) { + Tcl_DecrRefCount(iPtr->scriptFile); + } iPtr->scriptFile = oldScriptFile; if (result == TCL_RETURN) { @@ -332,14 +1388,13 @@ Tcl_EvalFile(interp, fileName) * Record information telling where the error occurred. */ - sprintf(msg, "\n (file \"%.150s\" line %d)", fileName, + sprintf(msg, "\n (file \"%.150s\" line %d)", Tcl_GetString(pathPtr), interp->errorLine); Tcl_AddErrorInfo(interp, msg); } end: Tcl_DecrRefCount(objPtr); - Tcl_DStringFree(&nameString); return result; } @@ -411,12 +1466,12 @@ Tcl_SetErrno(err) *---------------------------------------------------------------------- */ -char * +CONST char * Tcl_PosixError(interp) Tcl_Interp *interp; /* Interpreter whose $errorCode variable * is to be changed. */ { - char *id, *msg; + CONST char *id, *msg; msg = Tcl_ErrnoMsg(errno); id = Tcl_ErrnoId(); @@ -427,12 +1482,12 @@ Tcl_PosixError(interp) /* *---------------------------------------------------------------------- * - * TclStat -- + * Tcl_FSStat -- * * This procedure replaces the library version of stat and lsat. - * The chain of functions that have been "inserted" into the - * 'statProcList' will be called in succession until either - * a value of zero is returned, or the entire list is visited. + * + * The appropriate function for the filesystem to which pathPtr + * belongs will be called. * * Results: * See stat documentation. @@ -444,38 +1499,118 @@ Tcl_PosixError(interp) */ int -TclStat(path, buf) - CONST char *path; /* Path of file to stat (in current CP). */ - struct stat *buf; /* Filled with results of stat call. */ +Tcl_FSStat(pathPtr, buf) + Tcl_Obj *pathPtr; /* Path of file to stat (in current CP). */ + Tcl_StatBuf *buf; /* Filled with results of stat call. */ { + Tcl_Filesystem *fsPtr; +#ifdef USE_OBSOLETE_FS_HOOKS StatProc *statProcPtr; + struct stat oldStyleStatBuffer; int retVal = -1; + char *path; + Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); + if (transPtr == NULL) { + path = NULL; + } else { + path = Tcl_GetString(transPtr); + } /* * Call each of the "stat" function in succession. A non-return * value of -1 indicates the particular function has succeeded. */ - Tcl_MutexLock(&hookMutex); + Tcl_MutexLock(&obsoleteFsHookMutex); statProcPtr = statProcList; while ((retVal == -1) && (statProcPtr != NULL)) { - retVal = (*statProcPtr->proc)(path, buf); + retVal = (*statProcPtr->proc)(path, &oldStyleStatBuffer); statProcPtr = statProcPtr->nextPtr; } - Tcl_MutexUnlock(&hookMutex); + Tcl_MutexUnlock(&obsoleteFsHookMutex); + if (retVal != -1) { + /* + * Note that EOVERFLOW is not a problem here, and these + * assignments should all be widening (if not identity.) + */ + buf->st_mode = oldStyleStatBuffer.st_mode; + buf->st_ino = oldStyleStatBuffer.st_ino; + buf->st_dev = oldStyleStatBuffer.st_dev; + buf->st_rdev = oldStyleStatBuffer.st_rdev; + buf->st_nlink = oldStyleStatBuffer.st_nlink; + buf->st_uid = oldStyleStatBuffer.st_uid; + buf->st_gid = oldStyleStatBuffer.st_gid; + buf->st_size = Tcl_LongAsWide(oldStyleStatBuffer.st_size); + buf->st_atime = oldStyleStatBuffer.st_atime; + buf->st_mtime = oldStyleStatBuffer.st_mtime; + buf->st_ctime = oldStyleStatBuffer.st_ctime; +#ifdef HAVE_ST_BLOCKS + buf->st_blksize = oldStyleStatBuffer.st_blksize; + buf->st_blocks = Tcl_LongAsWide(oldStyleStatBuffer.st_blocks); +#endif + return retVal; + } +#endif /* USE_OBSOLETE_FS_HOOKS */ + fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + Tcl_FSStatProc *proc = fsPtr->statProc; + if (proc != NULL) { + return (*proc)(pathPtr, buf); + } + } + Tcl_SetErrno(ENOENT); + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FSLstat -- + * + * This procedure 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. + * + * Results: + * See lstat documentation. + * + * Side effects: + * See lstat documentation. + * + *---------------------------------------------------------------------- + */ - return (retVal); +int +Tcl_FSLstat(pathPtr, buf) + Tcl_Obj *pathPtr; /* Path of file to stat (in current CP). */ + Tcl_StatBuf *buf; /* Filled with results of stat call. */ +{ + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + Tcl_FSLstatProc *proc = fsPtr->lstatProc; + if (proc != NULL) { + return (*proc)(pathPtr, buf); + } else { + Tcl_FSStatProc *sproc = fsPtr->statProc; + if (sproc != NULL) { + return (*sproc)(pathPtr, buf); + } + } + } + Tcl_SetErrno(ENOENT); + return -1; } /* *---------------------------------------------------------------------- * - * TclAccess -- + * Tcl_FSAccess -- * * This procedure replaces the library version of access. - * The chain of functions that have been "inserted" into the - * 'accessProcList' will be called in succession until either - * a value of zero is returned, or the entire list is visited. + * The appropriate function for the filesystem to which pathPtr + * belongs will be called. * * Results: * See access documentation. @@ -487,38 +1622,57 @@ TclStat(path, buf) */ int -TclAccess(path, mode) - CONST char *path; /* Path of file to access (in current CP). */ +Tcl_FSAccess(pathPtr, mode) + Tcl_Obj *pathPtr; /* Path of file to access (in current CP). */ int mode; /* Permission setting. */ { + Tcl_Filesystem *fsPtr; +#ifdef USE_OBSOLETE_FS_HOOKS AccessProc *accessProcPtr; int retVal = -1; + char *path; + Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); + if (transPtr == NULL) { + path = NULL; + } else { + path = Tcl_GetString(transPtr); + } /* * Call each of the "access" function in succession. A non-return * value of -1 indicates the particular function has succeeded. */ - Tcl_MutexLock(&hookMutex); + Tcl_MutexLock(&obsoleteFsHookMutex); accessProcPtr = accessProcList; while ((retVal == -1) && (accessProcPtr != NULL)) { retVal = (*accessProcPtr->proc)(path, mode); accessProcPtr = accessProcPtr->nextPtr; } - Tcl_MutexUnlock(&hookMutex); + Tcl_MutexUnlock(&obsoleteFsHookMutex); + if (retVal != -1) { + return retVal; + } +#endif /* USE_OBSOLETE_FS_HOOKS */ + fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + Tcl_FSAccessProc *proc = fsPtr->accessProc; + if (proc != NULL) { + return (*proc)(pathPtr, mode); + } + } - return (retVal); + Tcl_SetErrno(ENOENT); + return -1; } /* *---------------------------------------------------------------------- * - * Tcl_OpenFileChannel -- + * Tcl_FSOpenFileChannel -- * - * The chain of functions that have been "inserted" into the - * 'openFileChannelProcList' will be called in succession until - * either a valid file channel is returned, or the entire list is - * visited. + * The appropriate function for the filesystem to which pathPtr + * belongs will be called. * * Results: * The new channel or NULL, if the named file could not be opened. @@ -531,18 +1685,32 @@ TclAccess(path, mode) */ Tcl_Channel -Tcl_OpenFileChannel(interp, fileName, modeString, permissions) +Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions) Tcl_Interp *interp; /* Interpreter for error reporting; * can be NULL. */ - char *fileName; /* Name of file to open. */ - char *modeString; /* A list of POSIX open modes or + Tcl_Obj *pathPtr; /* Name of file to open. */ + CONST char *modeString; /* A list of POSIX open modes or * a string such as "rw". */ int permissions; /* If the open involves creating a * file, with what modes to create * it? */ { + Tcl_Filesystem *fsPtr; +#ifdef USE_OBSOLETE_FS_HOOKS OpenFileChannelProc *openFileChannelProcPtr; Tcl_Channel retVal = NULL; + char *path; +#endif /* USE_OBSOLETE_FS_HOOKS */ + Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr); + if (transPtr == NULL) { + return NULL; + } +#ifdef USE_OBSOLETE_FS_HOOKS + if (transPtr == NULL) { + path = NULL; + } else { + path = Tcl_GetString(transPtr); + } /* * Call each of the "Tcl_OpenFileChannel" function in succession. @@ -550,27 +1718,3301 @@ Tcl_OpenFileChannel(interp, fileName, modeString, permissions) * succeeded. */ - Tcl_MutexLock(&hookMutex); + Tcl_MutexLock(&obsoleteFsHookMutex); openFileChannelProcPtr = openFileChannelProcList; while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) { - retVal = (*openFileChannelProcPtr->proc)(interp, fileName, + retVal = (*openFileChannelProcPtr->proc)(interp, path, modeString, permissions); openFileChannelProcPtr = openFileChannelProcPtr->nextPtr; } - Tcl_MutexUnlock(&hookMutex); + Tcl_MutexUnlock(&obsoleteFsHookMutex); + if (retVal != NULL) { + return retVal; + } +#endif /* USE_OBSOLETE_FS_HOOKS */ + fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + Tcl_FSOpenFileChannelProc *proc = fsPtr->openFileChannelProc; + if (proc != NULL) { + int mode, seekFlag; + mode = TclGetOpenMode(interp, modeString, &seekFlag); + if (mode == -1) { + return NULL; + } + retVal = (*proc)(interp, pathPtr, mode, permissions); + if (retVal != NULL) { + if (seekFlag) { + if (Tcl_Seek(retVal, (Tcl_WideInt)0, + SEEK_END) < (Tcl_WideInt)0) { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, + "could not seek to end of file while opening \"", + Tcl_GetString(pathPtr), "\": ", + Tcl_PosixError(interp), (char *) NULL); + } + Tcl_Close(NULL, retVal); + return NULL; + } + } + } + return retVal; + } + } + /* File doesn't belong to any filesystem that can open it */ + Tcl_SetErrno(ENOENT); + if (interp != NULL) { + Tcl_AppendResult(interp, "couldn't open \"", + Tcl_GetString(pathPtr), "\": ", + Tcl_PosixError(interp), (char *) NULL); + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * 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 each + * filesystem's Tcl_FSMatchInDirectoryProc having to deal with + * this issue, we create a pathPtr on the fly, 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. + * + * 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. + * + * Side effects: + * The interpreter may have an error message inserted into it. + * + *---------------------------------------------------------------------- + */ +int +Tcl_FSMatchInDirectory(interp, result, pathPtr, pattern, types) + Tcl_Interp *interp; /* Interpreter to receive error messages. */ + Tcl_Obj *result; /* 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_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + Tcl_FSMatchInDirectoryProc *proc = fsPtr->matchInDirectoryProc; + if (proc != NULL) { + return (*proc)(interp, result, pathPtr, pattern, types); + } + } else { + Tcl_Obj* cwd; + int ret = -1; + if (pathPtr != NULL) { + int len; + Tcl_GetStringFromObj(pathPtr,&len); + if (len != 0) { + /* + * We have no idea how to match files in a directory + * which belongs to no known filesystem + */ + 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. + */ + cwd = Tcl_FSGetCwd(NULL); + if (cwd == NULL) { + if (interp != NULL) { + Tcl_SetResult(interp, "glob couldn't determine " + "the current working directory", TCL_STATIC); + } + return TCL_ERROR; + } + fsPtr = Tcl_FSGetFileSystemForPath(cwd); + if (fsPtr != NULL) { + Tcl_FSMatchInDirectoryProc *proc = fsPtr->matchInDirectoryProc; + if (proc != NULL) { + int cwdLen; + Tcl_Obj *cwdDir; + char *cwdStr; + char sep = 0; + Tcl_Obj* tmpResultPtr = Tcl_NewListObj(0, NULL); + /* + * We know the cwd is a normalised object which does + * not end in a directory delimiter, unless the cwd + * is the name of a volume, in which case it will + * end in a delimiter! We handle this situation here. + * A better test than the '!= sep' might be to simply + * check if 'cwd' is a root volume. + * + * Note that if we get this wrong, we will strip off + * either too much or too little below, leading to + * wrong answers returned by glob. + */ + cwdDir = Tcl_DuplicateObj(cwd); + Tcl_IncrRefCount(cwdDir); + cwdStr = Tcl_GetStringFromObj(cwdDir, &cwdLen); + /* + * Should we perhaps use 'Tcl_FSPathSeparator'? + * But then what about the Windows special case? + * Perhaps we should just check if cwd is a root + * volume. + */ + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: + if (cwdStr[cwdLen-1] != '/') { + sep = '/'; + } + break; + case TCL_PLATFORM_WINDOWS: + if (cwdStr[cwdLen-1] != '/' && cwdStr[cwdLen-1] != '\\') { + sep = '/'; + } + break; + case TCL_PLATFORM_MAC: + if (cwdStr[cwdLen-1] != ':') { + sep = ':'; + } + break; + } + if (sep != 0) { + Tcl_AppendToObj(cwdDir, &sep, 1); + cwdLen++; + /* Note: cwdStr may no longer be a valid pointer now */ + } + ret = (*proc)(interp, tmpResultPtr, cwdDir, pattern, types); + Tcl_DecrRefCount(cwdDir); + if (ret == TCL_OK) { + int resLength; + + ret = Tcl_ListObjLength(interp, tmpResultPtr, &resLength); + if (ret == TCL_OK) { + Tcl_Obj *elt, *cutElt; + char *eltStr; + int eltLen, i; + + for (i = 0; i < resLength; i++) { + Tcl_ListObjIndex(interp, tmpResultPtr, i, &elt); + eltStr = Tcl_GetStringFromObj(elt,&eltLen); + cutElt = Tcl_NewStringObj(eltStr + cwdLen, + eltLen - cwdLen); + Tcl_ListObjAppendElement(interp, result, cutElt); + } + } + } + Tcl_DecrRefCount(tmpResultPtr); + } + } + Tcl_DecrRefCount(cwd); + return ret; + } + Tcl_SetErrno(ENOENT); + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * 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 synchronise this with the cwd's containing filesystem, + * if that filesystem provides a cwdProc (e.g. the native filesystem). + * + * 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. + * + * If a global cwdPathPtr already exists, it 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. + * + * 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. + * + * The result already has its refCount incremented for the caller. + * When it is no longer needed, that refCount should be decremented. + * This is needed for thread-safety purposes, to allow multiple + * threads to access this and related functions, while ensuring the + * results are always valid. + * + * Of course it is probably a bad idea for multiple threads to + * be *setting* the cwd anyway, but we can at least try to + * help the case of multiple reads with occasional sets. + * + * Side effects: + * Various objects may be freed and allocated. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj* +Tcl_FSGetCwd(interp) + Tcl_Interp *interp; +{ + Tcl_Obj *cwdToReturn; + + if (FsCwdPointerEquals(NULL)) { + FilesystemRecord *fsRecPtr; + 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. + */ + + fsRecPtr = FsGetIterator(); + while ((retVal == NULL) && (fsRecPtr != NULL)) { + Tcl_FSGetCwdProc *proc = fsRecPtr->fsPtr->getCwdProc; + if (proc != NULL) { + retVal = (*proc)(interp); + } + fsRecPtr = fsRecPtr->nextPtr; + } + FsReleaseIterator(); + /* + * 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) { + Tcl_Obj *norm = FSNormalizeAbsolutePath(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. + * + * Threading issue: note that multiple threads at system + * startup could in principle call this procedure + * 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. + */ + Tcl_MutexLock(&cwdMutex); + /* Just in case the pointer has been set by another + * thread between now and the test above */ + if (cwdPathPtr != NULL) { + Tcl_DecrRefCount(cwdPathPtr); + } + cwdPathPtr = norm; + Tcl_MutexUnlock(&cwdMutex); + } + Tcl_DecrRefCount(retVal); + } + } 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. + */ + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(cwdPathPtr); + /* + * 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) { + Tcl_FSGetCwdProc *proc = fsPtr->getCwdProc; + if (proc != NULL) { + Tcl_Obj *retVal = (*proc)(interp); + if (retVal != NULL) { + Tcl_Obj *norm = FSNormalizeAbsolutePath(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) { + /* Do nothing */ + } else if (Tcl_FSEqualPaths(cwdPathPtr, norm)) { + /* + * 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. + */ + Tcl_DecrRefCount(norm); + } else { + /* The cwd has in fact changed, so we must + * lock down the cwdMutex to modify. */ + Tcl_MutexLock(&cwdMutex); + Tcl_DecrRefCount(cwdPathPtr); + cwdPathPtr = norm; + Tcl_MutexUnlock(&cwdMutex); + } + Tcl_DecrRefCount(retVal); + } else { + /* The 'cwd' function returned an error, so we + * reset the cwd after locking down the mutex. */ + Tcl_MutexLock(&cwdMutex); + Tcl_DecrRefCount(cwdPathPtr); + cwdPathPtr = NULL; + Tcl_MutexUnlock(&cwdMutex); + } + } + } + } + + /* + * The paths all eventually fall through to here. Note that + * we use a bunch of separate mutex locks throughout this + * code to help prevent deadlocks between threads. Really + * the only weirdness will arise if multiple threads are setting + * and reading the cwd, and that behaviour is always going to be + * a little suspect. + */ + Tcl_MutexLock(&cwdMutex); + cwdToReturn = cwdPathPtr; + if (cwdToReturn != NULL) { + Tcl_IncrRefCount(cwdToReturn); + } + Tcl_MutexUnlock(&cwdMutex); + + return (cwdToReturn); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FSUtime -- + * + * This procedure replaces the library version of utime. + * The appropriate function for the filesystem to which pathPtr + * belongs will be called. + * + * Results: + * See utime documentation. + * + * Side effects: + * See utime documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_FSUtime (pathPtr, tval) + Tcl_Obj *pathPtr; /* File to change access/modification times */ + struct utimbuf *tval; /* Structure containing access/modification + * times to use. Should not be modified. */ +{ + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + Tcl_FSUtimeProc *proc = fsPtr->utimeProc; + if (proc != NULL) { + return (*proc)(pathPtr, tval); + } + } + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * NativeFileAttrStrings -- + * + * This procedure 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, MacOS and Windows code. + * + * Results: + * An array of strings + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static CONST char** +NativeFileAttrStrings(pathPtr, objPtrRef) + Tcl_Obj *pathPtr; + Tcl_Obj** objPtrRef; +{ + return tclpFileAttrStrings; +} + +/* + *---------------------------------------------------------------------- + * + * NativeFileAttrsGet -- + * + * This procedure 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, MacOS and Windows code. + * + * 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 +NativeFileAttrsGet(interp, index, pathPtr, objPtrRef) + 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. */ +{ + return (*tclpFileAttrProcs[index].getProc)(interp, index, + pathPtr, objPtrRef); +} + +/* + *---------------------------------------------------------------------- + * + * NativeFileAttrsSet -- + * + * This procedure 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, MacOS and Windows code. + * + * Results: + * Standard Tcl return code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +NativeFileAttrsSet(interp, index, pathPtr, objPtr) + 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. */ +{ + return (*tclpFileAttrProcs[index].setProc)(interp, index, + pathPtr, objPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FSFileAttrStrings -- + * + * This procedure implements part of the hookable 'file + * attributes' subcommand. The appropriate function for the + * filesystem to which pathPtr belongs will be called. + * + * Results: + * The called procedure 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. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +CONST char ** +Tcl_FSFileAttrStrings(pathPtr, objPtrRef) + Tcl_Obj* pathPtr; + Tcl_Obj** objPtrRef; +{ + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + Tcl_FSFileAttrStringsProc *proc = fsPtr->fileAttrStringsProc; + if (proc != NULL) { + return (*proc)(pathPtr, objPtrRef); + } + } + Tcl_SetErrno(ENOENT); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FSFileAttrsGet -- + * + * This procedure implements read access for the hookable 'file + * attributes' subcommand. The appropriate function for the + * filesystem to which pathPtr belongs will be called. + * + * 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. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_FSFileAttrsGet(interp, index, pathPtr, objPtrRef) + 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. */ +{ + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + Tcl_FSFileAttrsGetProc *proc = fsPtr->fileAttrsGetProc; + if (proc != NULL) { + return (*proc)(interp, index, pathPtr, objPtrRef); + } + } + Tcl_SetErrno(ENOENT); + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FSFileAttrsSet -- + * + * This procedure implements write access for the hookable 'file + * attributes' subcommand. The appropriate function for the + * filesystem to which pathPtr belongs will be called. + * + * Results: + * Standard Tcl return code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_FSFileAttrsSet(interp, index, pathPtr, objPtr) + 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. */ +{ + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + Tcl_FSFileAttrsSetProc *proc = fsPtr->fileAttrsSetProc; + if (proc != NULL) { + return (*proc)(interp, index, pathPtr, objPtr); + } + } + Tcl_SetErrno(ENOENT); + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FSChdir -- + * + * This function replaces the library version of chdir(). + * + * The path is normalized and then passed to the filesystem + * which claims it. + * + * Results: + * See chdir() documentation. If successful, we keep a + * record of the successful path in cwdPathPtr for subsequent + * calls to getcwd. + * + * Side effects: + * See chdir() documentation. The global cwdPathPtr may + * change value. + * + *---------------------------------------------------------------------- + */ +int +Tcl_FSChdir(pathPtr) + Tcl_Obj *pathPtr; +{ + Tcl_Filesystem *fsPtr; + int retVal = -1; + + if (Tcl_FSGetNormalizedPath(NULL, pathPtr) == NULL) { + return TCL_ERROR; + } + + fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + Tcl_FSChdirProc *proc = fsPtr->chdirProc; + if (proc != NULL) { + retVal = (*proc)(pathPtr); + } else { + /* Fallback on 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 ((Tcl_FSStat(pathPtr, &buf) == 0) + && (S_ISDIR(buf.st_mode)) + && (Tcl_FSAccess(pathPtr, R_OK) == 0)) { + /* We allow the chdir */ + retVal = 0; + } + } + } + + if (retVal != -1) { + /* + * 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 (retVal == TCL_OK) { + /* + * 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). + */ + Tcl_Obj *normDirName = Tcl_FSGetNormalizedPath(NULL, pathPtr); + if (normDirName == NULL) { + return TCL_ERROR; + } + /* + * We will be adding a reference to this object when + * we store it in the cwdPathPtr. + */ + Tcl_IncrRefCount(normDirName); + /* Get a lock on the cwd while we modify it */ + Tcl_MutexLock(&cwdMutex); + /* Free up the previous cwd we stored */ + if (cwdPathPtr != NULL) { + Tcl_DecrRefCount(cwdPathPtr); + } + /* Now remember the current cwd */ + cwdPathPtr = normDirName; + Tcl_MutexUnlock(&cwdMutex); + } + } + return (retVal); } /* *---------------------------------------------------------------------- * + * Tcl_FSLoadFile -- + * + * Dynamically loads a binary code file into memory and returns + * the addresses of two procedures 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 filename is either + * a path or just the name 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. + * + * Results: + * A standard Tcl completion code. If an error occurs, an error + * message is left in the interp's result. + * + * Side effects: + * New code suddenly appears in memory. This may later be + * unloaded by passing the clientData to the unloadProc. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_FSLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, + handlePtr, unloadProcPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Obj *pathPtr; /* Name of the file containing the desired + * code. */ + CONST char *sym1, *sym2; /* Names of two procedures to look up in + * the file's symbol table. */ + Tcl_PackageInitProc **proc1Ptr, **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 + * (*unloadProcPtr)() to unload the file. */ + Tcl_FSUnloadFileProc **unloadProcPtr; + /* Filled with address of Tcl_FSUnloadFileProc + * function which should be used for + * this file. */ +{ + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + Tcl_FSLoadFileProc *proc = fsPtr->loadFileProc; + if (proc != NULL) { + int retVal = (*proc)(interp, pathPtr, handlePtr, unloadProcPtr); + if (retVal != TCL_OK) { + return retVal; + } + if (*handlePtr == NULL) { + return TCL_ERROR; + } + if (sym1 != NULL) { + *proc1Ptr = TclpFindSymbol(interp, *handlePtr, sym1); + } + if (sym2 != NULL) { + *proc2Ptr = TclpFindSymbol(interp, *handlePtr, sym2); + } + return retVal; + } else { + Tcl_Filesystem *copyFsPtr; + Tcl_Obj *copyToPtr; + + /* First check if it is readable -- and exists! */ + if (Tcl_FSAccess(pathPtr, R_OK) != 0) { + Tcl_AppendResult(interp, "couldn't load library \"", + Tcl_GetString(pathPtr), "\": ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + + /* + * Get a temporary filename to use, first to + * copy the file into, and then to load. + */ + copyToPtr = TclpTempFileName(); + if (copyToPtr == NULL) { + return -1; + } + Tcl_IncrRefCount(copyToPtr); + + 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_FSDeleteFile(copyToPtr); + Tcl_DecrRefCount(copyToPtr); + return -1; + } + + if (TclCrossFilesystemCopy(interp, pathPtr, + copyToPtr) == TCL_OK) { + /* + * 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 0777. Or directly: + * + * Tcl_Obj* perm = Tcl_NewStringObj("0777",-1); + * Tcl_IncrRefCount(perm); + * Tcl_FSFileAttrsSet(NULL, 2, copyToPtr, perm); + * Tcl_DecrRefCount(perm); + * + */ + Tcl_LoadHandle newLoadHandle = NULL; + Tcl_FSUnloadFileProc *newUnloadProcPtr = NULL; + FsDivertLoad *tvdlPtr; + int retVal; + + retVal = Tcl_FSLoadFile(interp, copyToPtr, sym1, sym2, + proc1Ptr, proc2Ptr, + &newLoadHandle, + &newUnloadProcPtr); + 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. + */ + if (Tcl_FSDeleteFile(copyToPtr) == TCL_OK) { + Tcl_DecrRefCount(copyToPtr); + (*handlePtr) = NULL; + (*unloadProcPtr) = NULL; + return TCL_OK; + } + /* + * When we unload this file, we need to divert the + * unloading so we can unload and cleanup the + * temporary file correctly. + */ + 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. + */ + tvdlPtr->loadHandle = newLoadHandle; + tvdlPtr->unloadProcPtr = newUnloadProcPtr; + /* copyToPtr is already incremented for this reference */ + tvdlPtr->divertedFile = copyToPtr; + /* + * This is the filesystem we loaded it into. It is + * almost certainly the tclNativeFilesystem, but we don't + * want to make that assumption. 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. + */ + tvdlPtr->divertedFilesystem = copyFsPtr; + /* Get the native representation of the file path */ + tvdlPtr->divertedFileNativeRep = Tcl_FSGetInternalRep(copyToPtr, + copyFsPtr); + copyToPtr = NULL; + (*handlePtr) = (Tcl_LoadHandle) tvdlPtr; + (*unloadProcPtr) = &FSUnloadTempFile; + + return retVal; + } else { + /* Cross-platform copy failed */ + Tcl_FSDeleteFile(copyToPtr); + Tcl_DecrRefCount(copyToPtr); + return TCL_ERROR; + } + } + } + Tcl_SetErrno(ENOENT); + return -1; +} +/* + * This function used to be in the platform specific directories, but it + * has now been made to work cross-platform + */ +int +TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, + clientDataPtr, unloadProcPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Obj *pathPtr; /* Name of the file containing the desired + * code (UTF-8). */ + CONST char *sym1, *sym2; /* Names of two procedures to look up in + * the file's symbol table. */ + Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; + /* Where to return the addresses corresponding + * to sym1 and sym2. */ + ClientData *clientDataPtr; /* Filled with token for dynamically loaded + * file which will be passed back to + * (*unloadProcPtr)() to unload the file. */ + Tcl_FSUnloadFileProc **unloadProcPtr; + /* Filled with address of Tcl_FSUnloadFileProc + * function which should be used for + * this file. */ +{ + Tcl_LoadHandle handle = NULL; + int res; + + res = TclpDlopen(interp, pathPtr, &handle, unloadProcPtr); + + if (res != TCL_OK) { + return res; + } + + if (handle == NULL) { + return TCL_ERROR; + } + + *clientDataPtr = (ClientData)handle; + + *proc1Ptr = TclpFindSymbol(interp, handle, sym1); + *proc2Ptr = TclpFindSymbol(interp, handle, sym2); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * FSUnloadTempFile -- + * + * 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. + * + * Results: + * None. + * + * Side effects: + * The effects of the 'unload' function called, and of course + * the temporary file will be deleted. + * + *--------------------------------------------------------------------------- + */ +static void +FSUnloadTempFile(loadHandle) + Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call + * to Tcl_FSLoadFile(). The loadHandle is + * a token that represents the loaded + * file. */ +{ + FsDivertLoad *tvdlPtr = (FsDivertLoad*)loadHandle; + /* + * This test should never trigger, since we give + * the client data in the function above. + */ + if (tvdlPtr == NULL) { 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) { + (*tvdlPtr->unloadProcPtr)(tvdlPtr->loadHandle); + } + + /* Remove the temporary file we created. */ + if (Tcl_FSDeleteFile(tvdlPtr->divertedFile) != TCL_OK) { + /* + * The above may have failed because the filesystem, or something + * it depends upon (e.g. encodings) are being taken down because + * Tcl is exiting. + * + * Therefore we try to call the filesystem's 'delete file proc' + * directly. Note that this call may still cause problems, because + * it will ask for the native representation of the divertedFile, + * and that may need to be _recalculated_, in which case this + * call isn't very different to the above. What we could do + * instead is generate a new Tcl_Obj (pure native) by calling: + * + * Tcl_Obj *tmp = Tcl_FSNewNativePath(tvdlPtr->divertedFile, + * tvdlPtr->divertedFileNativeRep); + * Tcl_IncrRefCount(tmp); + * tvdlPtr->divertedFilesystem->deleteFileProc(tmp); + * Tcl_DecrRefCount(tmp); + * + * and then use that in this call. This approach would potentially + * work even if the encodings and everything else have been + * deconstructed. For the moment, however, we simply assume + * Tcl_FSDeleteFile has worked correctly. + */ + } + + /* + * And free up the allocations. This will also of course remove + * a refCount from the Tcl_Filesystem to which this file belongs, + * which could then free up the filesystem if we are exiting. + */ + Tcl_DecrRefCount(tvdlPtr->divertedFile); + ckfree((char*)tvdlPtr); +} + +/* + *--------------------------------------------------------------------------- + * + * 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. + * + * 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 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: + * + * 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. + * + * Side effects: + * See readlink() documentation. A new filesystem link + * object may appear + * + *--------------------------------------------------------------------------- + */ + +Tcl_Obj * +Tcl_FSLink(pathPtr, toPtr, linkAction) + Tcl_Obj *pathPtr; /* Path of file to readlink or link */ + Tcl_Obj *toPtr; /* NULL or path to be linked to */ + int linkAction; /* Action to perform */ +{ + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + Tcl_FSLinkProc *proc = fsPtr->linkProc; + if (proc != NULL) { + return (*proc)(pathPtr, toPtr, linkAction); + } + } + /* + * 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. + */ +#ifndef S_IFLNK + errno = EINVAL; +#else + Tcl_SetErrno(ENOENT); +#endif /* S_IFLNK */ + return NULL; +} + +/* + *--------------------------------------------------------------------------- + * + * 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. + * + * Results: + * The list of volumes, in an object which has refCount 0. + * + * Side effects: + * None + * + *--------------------------------------------------------------------------- + */ + +Tcl_Obj* +Tcl_FSListVolumes(void) +{ + FilesystemRecord *fsRecPtr; + Tcl_Obj *resultPtr = Tcl_NewObj(); + + /* + * 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. + */ + + fsRecPtr = FsGetIterator(); + while (fsRecPtr != NULL) { + Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc; + if (proc != NULL) { + Tcl_Obj *thisFsVolumes = (*proc)(); + if (thisFsVolumes != NULL) { + Tcl_ListObjAppendList(NULL, resultPtr, thisFsVolumes); + Tcl_DecrRefCount(thisFsVolumes); + } + } + fsRecPtr = fsRecPtr->nextPtr; + } + FsReleaseIterator(); + + return resultPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FSGetPathType -- + * + * Determines whether a given path is relative to the current + * directory, relative to the current volume, or absolute. + * + * Results: + * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or + * TCL_PATH_VOLUME_RELATIVE. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_PathType +Tcl_FSGetPathType(pathObjPtr) + Tcl_Obj *pathObjPtr; +{ + return FSGetPathType(pathObjPtr, NULL, NULL); +} + +/* + *---------------------------------------------------------------------- + * + * FSGetPathType -- + * + * Determines whether a given path is relative to the current + * directory, relative to the current volume, or absolute. If the + * caller wishes to know which filesystem claimed the path (in the + * case for which the path is absolute), then a reference to a + * filesystem pointer can be passed in (but passing NULL is + * acceptable). + * + * 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. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tcl_PathType +FSGetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr) + Tcl_Obj *pathObjPtr; + Tcl_Filesystem **filesystemPtrPtr; + int *driveNameLengthPtr; +{ + if (Tcl_FSConvertToPathType(NULL, pathObjPtr) != TCL_OK) { + return GetPathType(pathObjPtr, filesystemPtrPtr, + driveNameLengthPtr, NULL); + } else { + FsPath *fsPathPtr = (FsPath*) pathObjPtr->internalRep.otherValuePtr; + if (fsPathPtr->cwdPtr != NULL) { + return TCL_PATH_RELATIVE; + } else { + return GetPathType(pathObjPtr, filesystemPtrPtr, + driveNameLengthPtr, NULL); + } + } +} + +/* + *--------------------------------------------------------------------------- + * + * 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. + * + * 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. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +Tcl_Obj* +Tcl_FSSplitPath(pathPtr, lenPtr) + Tcl_Obj *pathPtr; /* Path to split. */ + int *lenPtr; /* int to store number of path elements. */ +{ + Tcl_Obj *result = NULL; /* Needed only to prevent gcc warnings. */ + Tcl_Filesystem *fsPtr; + char separator = '/'; + int driveNameLength; + char *p; + + /* + * Perform platform specific splitting. + */ + + if (FSGetPathType(pathPtr, &fsPtr, &driveNameLength) + == TCL_PATH_ABSOLUTE) { + if (fsPtr == &tclNativeFilesystem) { + return TclpNativeSplitPath(pathPtr, lenPtr); + } + } else { + return TclpNativeSplitPath(pathPtr, lenPtr); + } + + /* We assume separators are single characters */ + if (fsPtr->filesystemSeparatorProc != NULL) { + Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(pathPtr); + if (sep != NULL) { + separator = Tcl_GetString(sep)[0]; + } + } + + /* + * 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) + */ + result = Tcl_NewObj(); + p = Tcl_GetString(pathPtr); + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(p, driveNameLength)); + p+= driveNameLength; + + /* Add the remaining path elements to the list */ + for (;;) { + char *elementStart = p; + int length; + while ((*p != '\0') && (*p != separator)) { + p++; + } + length = p - elementStart; + if (length > 0) { + Tcl_Obj *nextElt; + if (elementStart[0] == '~') { + nextElt = Tcl_NewStringObj("./",2); + Tcl_AppendToObj(nextElt, elementStart, length); + } else { + nextElt = Tcl_NewStringObj(elementStart, length); + } + Tcl_ListObjAppendElement(NULL, result, nextElt); + } + if (*p++ == '\0') { + break; + } + } + + /* + * Compute the number of elements in the result. + */ + + if (lenPtr != NULL) { + Tcl_ListObjLength(NULL, result, lenPtr); + } + return result; +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_FSJoinPath -- + * + * This function takes the given Tcl_Obj, which should be a valid + * list, and returns the path object given by considering the + * first 'elements' elements as valid path segments. If elements < 0, + * we use the entire list. + * + * Results: + * Returns object with refCount of zero. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ +Tcl_Obj* +Tcl_FSJoinPath(listObj, elements) + Tcl_Obj *listObj; + int elements; +{ + Tcl_Obj *res; + int i; + Tcl_Filesystem *fsPtr = NULL; + + if (elements < 0) { + if (Tcl_ListObjLength(NULL, listObj, &elements) != TCL_OK) { + return NULL; + } + } else { + /* Just make sure it is a valid list */ + int listTest; + if (Tcl_ListObjLength(NULL, listObj, &listTest) != TCL_OK) { + return NULL; + } + /* + * Correct this if it is too large, otherwise we will + * waste our timing joining null elements to the path + */ + if (elements > listTest) { + elements = listTest; + } + } + + res = Tcl_NewObj(); + + for (i = 0; i < elements; i++) { + Tcl_Obj *elt; + int driveNameLength; + Tcl_PathType type; + char *strElt; + int strEltLen; + int length; + char *ptr; + Tcl_Obj *driveName = NULL; + + Tcl_ListObjIndex(NULL, listObj, i, &elt); + strElt = Tcl_GetStringFromObj(elt, &strEltLen); + type = GetPathType(elt, &fsPtr, &driveNameLength, &driveName); + if (type != TCL_PATH_RELATIVE) { + /* Zero out the current result */ + Tcl_DecrRefCount(res); + if (driveName != NULL) { + res = Tcl_DuplicateObj(driveName); + Tcl_DecrRefCount(driveName); + } else { + res = Tcl_NewStringObj(strElt, driveNameLength); + } + strElt += driveNameLength; + } + + ptr = Tcl_GetStringFromObj(res, &length); + + /* + * Strip off any './' before a tilde, unless this is the + * beginning of the path. + */ + if (length > 0 && strEltLen > 0) { + if ((strElt[0] == '.') && (strElt[1] == '/') + && (strElt[2] == '~')) { + strElt += 2; + } + } + + /* + * A NULL value for fsPtr at this stage basically means + * we're trying to join a relative path onto something + * which is also relative (or empty). There's nothing + * particularly wrong with that. + */ + if (*strElt == '\0') continue; + + if (fsPtr == &tclNativeFilesystem || fsPtr == NULL) { + TclpNativeJoinPath(res, strElt); + } else { + char separator = '/'; + int needsSep = 0; + + if (fsPtr->filesystemSeparatorProc != NULL) { + Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(res); + if (sep != NULL) { + separator = Tcl_GetString(sep)[0]; + } + } + + if (length > 0 && ptr[length -1] != '/') { + Tcl_AppendToObj(res, &separator, 1); + length++; + } + Tcl_SetObjLength(res, length + (int) strlen(strElt)); + + ptr = Tcl_GetString(res) + length; + for (; *strElt != '\0'; strElt++) { + if (*strElt == separator) { + while (strElt[1] == separator) { + strElt++; + } + if (strElt[1] != '\0') { + if (needsSep) { + *ptr++ = separator; + } + } + } else { + *ptr++ = *strElt; + needsSep = 1; + } + } + length = ptr - Tcl_GetString(res); + Tcl_SetObjLength(res, length); + } + } + return res; +} + +/* + *---------------------------------------------------------------------- + * + * GetPathType -- + * + * Helper function used by FSGetPathType. + * + * 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. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tcl_PathType +GetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr, driveNameRef) + Tcl_Obj *pathObjPtr; + Tcl_Filesystem **filesystemPtrPtr; + int *driveNameLengthPtr; + Tcl_Obj **driveNameRef; +{ + FilesystemRecord *fsRecPtr; + int pathLen; + char *path; + Tcl_PathType type = TCL_PATH_RELATIVE; + + path = Tcl_GetStringFromObj(pathObjPtr, &pathLen); + + /* + * 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). + */ + + fsRecPtr = FsGetIterator(); + while (fsRecPtr != NULL) { + Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc; + /* + * We want to skip the native filesystem in this loop because + * otherwise we won't necessarily pass all the Tcl testsuite -- + * this is because some of the tests artificially change the + * current platform (between mac, win, unix) but the list + * of volumes we get by calling (*proc) will reflect the current + * (real) platform only and this may cause some tests to fail. + * In particular, on unix '/' will match the beginning of + * certain absolute Windows paths starting '//' and those tests + * will go wrong. + * + * 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. + */ + if ((fsRecPtr->fsPtr != &tclNativeFilesystem) && (proc != NULL)) { + int numVolumes; + Tcl_Obj *thisFsVolumes = (*proc)(); + if (thisFsVolumes != NULL) { + if (Tcl_ListObjLength(NULL, thisFsVolumes, + &numVolumes) != TCL_OK) { + /* + * This is VERY bad; the Tcl_FSListVolumesProc + * didn't return a valid list. Set numVolumes to + * -1 so that we skip the while loop below and just + * return with the current value of 'type'. + * + * It would be better if we could signal an error + * here (but panic seems a bit excessive). + */ + numVolumes = -1; + } + while (numVolumes > 0) { + Tcl_Obj *vol; + int len; + char *strVol; + + numVolumes--; + Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol); + strVol = Tcl_GetStringFromObj(vol,&len); + if (pathLen < len) { + continue; + } + if (strncmp(strVol, path, (size_t) len) == 0) { + type = TCL_PATH_ABSOLUTE; + if (filesystemPtrPtr != NULL) { + *filesystemPtrPtr = fsRecPtr->fsPtr; + } + if (driveNameLengthPtr != NULL) { + *driveNameLengthPtr = len; + } + if (driveNameRef != NULL) { + *driveNameRef = vol; + Tcl_IncrRefCount(vol); + } + break; + } + } + Tcl_DecrRefCount(thisFsVolumes); + if (type == TCL_PATH_ABSOLUTE) { + /* We don't need to examine any more filesystems */ + break; + } + } + } + fsRecPtr = fsRecPtr->nextPtr; + } + FsReleaseIterator(); + + if (type != TCL_PATH_ABSOLUTE) { + type = TclpGetNativePathType(pathObjPtr, driveNameLengthPtr, + driveNameRef); + if ((type == TCL_PATH_ABSOLUTE) && (filesystemPtrPtr != NULL)) { + *filesystemPtrPtr = &tclNativeFilesystem; + } + } + return type; +} + +/* + *--------------------------------------------------------------------------- + * + * 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. + * + * Results: + * Standard Tcl error code if a function was called. + * + * Side effects: + * A file may be renamed. + * + *--------------------------------------------------------------------------- + */ + +int +Tcl_FSRenameFile(srcPathPtr, destPathPtr) + Tcl_Obj* srcPathPtr; /* Pathname of file or dir to be renamed + * (UTF-8). */ + Tcl_Obj *destPathPtr; /* New pathname of file or directory + * (UTF-8). */ +{ + int retVal = -1; + Tcl_Filesystem *fsPtr, *fsPtr2; + fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr); + fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr); + + if (fsPtr == fsPtr2 && fsPtr != NULL) { + Tcl_FSRenameFileProc *proc = fsPtr->renameFileProc; + if (proc != NULL) { + retVal = (*proc)(srcPathPtr, destPathPtr); + } + } + if (retVal == -1) { + Tcl_SetErrno(EXDEV); + } + return retVal; +} + +/* + *--------------------------------------------------------------------------- + * + * 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. + * + * 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). + * + * Results: + * Standard Tcl error code if a function was called. + * + * Side effects: + * A file may be copied. + * + *--------------------------------------------------------------------------- + */ + +int +Tcl_FSCopyFile(srcPathPtr, destPathPtr) + Tcl_Obj* srcPathPtr; /* Pathname of file to be copied (UTF-8). */ + Tcl_Obj *destPathPtr; /* Pathname of file to copy to (UTF-8). */ +{ + int retVal = -1; + Tcl_Filesystem *fsPtr, *fsPtr2; + fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr); + fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr); + + if (fsPtr == fsPtr2 && fsPtr != NULL) { + Tcl_FSCopyFileProc *proc = fsPtr->copyFileProc; + if (proc != NULL) { + retVal = (*proc)(srcPathPtr, destPathPtr); + } + } + if (retVal == -1) { + Tcl_SetErrno(EXDEV); + } + return retVal; +} + +/* + *--------------------------------------------------------------------------- + * + * 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. + * + * Results: + * Standard Tcl error code. + * + * Side effects: + * A file may be created. + * + *--------------------------------------------------------------------------- + */ +int +TclCrossFilesystemCopy(interp, source, target) + 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). */ +{ + int result = TCL_ERROR; + int prot = 0666; + + Tcl_Channel out = Tcl_FSOpenFileChannel(interp, target, "w", prot); + if (out != NULL) { + /* It looks like we can copy it over */ + Tcl_Channel in = Tcl_FSOpenFileChannel(interp, source, + "r", prot); + if (in == NULL) { + /* This is very strange, we checked this above */ + Tcl_Close(interp, out); + } else { + Tcl_StatBuf sourceStatBuf; + struct utimbuf tval; + /* + * Copy it synchronously. We might wish to add an + * asynchronous option to support vfs's which are + * slow (e.g. network sockets). + */ + Tcl_SetChannelOption(interp, in, "-translation", "binary"); + Tcl_SetChannelOption(interp, out, "-translation", "binary"); + + if (TclCopyChannel(interp, in, out, -1, NULL) == TCL_OK) { + result = TCL_OK; + } + /* + * If the copy failed, assume that copy channel left + * a good error message. + */ + Tcl_Close(interp, in); + Tcl_Close(interp, out); + + /* Set modification date of copied file */ + if (Tcl_FSLstat(source, &sourceStatBuf) != 0) { + tval.actime = sourceStatBuf.st_atime; + tval.modtime = sourceStatBuf.st_mtime; + Tcl_FSUtime(source, &tval); + } + } + } + return result; +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_FSDeleteFile -- + * + * The appropriate function for the filesystem to which pathPtr + * belongs will be called. + * + * Results: + * Standard Tcl error code. + * + * Side effects: + * A file may be deleted. + * + *--------------------------------------------------------------------------- + */ + +int +Tcl_FSDeleteFile(pathPtr) + Tcl_Obj *pathPtr; /* Pathname of file to be removed (UTF-8). */ +{ + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + Tcl_FSDeleteFileProc *proc = fsPtr->deleteFileProc; + if (proc != NULL) { + return (*proc)(pathPtr); + } + } + Tcl_SetErrno(ENOENT); + return -1; +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_FSCreateDirectory -- + * + * The appropriate function for the filesystem to which pathPtr + * belongs will be called. + * + * Results: + * Standard Tcl error code. + * + * Side effects: + * A directory may be created. + * + *--------------------------------------------------------------------------- + */ + +int +Tcl_FSCreateDirectory(pathPtr) + Tcl_Obj *pathPtr; /* Pathname of directory to create (UTF-8). */ +{ + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + Tcl_FSCreateDirectoryProc *proc = fsPtr->createDirectoryProc; + if (proc != NULL) { + return (*proc)(pathPtr); + } + } + Tcl_SetErrno(ENOENT); + return -1; +} + +/* + *--------------------------------------------------------------------------- + * + * 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. + * + * Results: + * Standard Tcl error code if a function was called. + * + * Side effects: + * A directory may be copied. + * + *--------------------------------------------------------------------------- + */ + +int +Tcl_FSCopyDirectory(srcPathPtr, destPathPtr, errorPtr) + 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. */ +{ + int retVal = -1; + Tcl_Filesystem *fsPtr, *fsPtr2; + fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr); + fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr); + + if (fsPtr == fsPtr2 && fsPtr != NULL) { + Tcl_FSCopyDirectoryProc *proc = fsPtr->copyDirectoryProc; + if (proc != NULL) { + retVal = (*proc)(srcPathPtr, destPathPtr, errorPtr); + } + } + if (retVal == -1) { + Tcl_SetErrno(EXDEV); + } + return retVal; +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_FSRemoveDirectory -- + * + * The appropriate function for the filesystem to which pathPtr + * belongs will be called. + * + * Results: + * Standard Tcl error code. + * + * Side effects: + * A directory may be deleted. + * + *--------------------------------------------------------------------------- + */ + +int +Tcl_FSRemoveDirectory(pathPtr, recursive, errorPtr) + 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_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + if (fsPtr != NULL) { + Tcl_FSRemoveDirectoryProc *proc = fsPtr->removeDirectoryProc; + if (proc != NULL) { + if (recursive) { + /* + * We check whether the cwd lies inside this directory + * and move it if it does. + */ + Tcl_Obj *cwdPtr = Tcl_FSGetCwd(NULL); + if (cwdPtr != NULL) { + char *cwdStr, *normPathStr; + int cwdLen, normLen; + Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr); + if (normPath != NULL) { + normPathStr = Tcl_GetStringFromObj(normPath, &normLen); + cwdStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen); + if ((cwdLen >= normLen) && (strncmp(normPathStr, + cwdStr, (size_t) normLen) == 0)) { + /* + * the cwd is inside the directory, so we + * perform a 'cd [file dirname $path]' + */ + Tcl_Obj *dirPtr = TclFileDirname(NULL, pathPtr); + Tcl_FSChdir(dirPtr); + Tcl_DecrRefCount(dirPtr); + } + } + Tcl_DecrRefCount(cwdPtr); + } + } + return (*proc)(pathPtr, recursive, errorPtr); + } + } + Tcl_SetErrno(ENOENT); + return -1; +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_FSConvertToPathType -- + * + * This function tries to convert the given Tcl_Obj to a valid + * Tcl path type, taking account of the fact that the cwd may + * have changed even if this object is already supposedly of + * the correct type. + * + * The filename may begin with "~" (to indicate current user's + * home directory) or "~<user>" (to indicate any user's home + * directory). + * + * Results: + * Standard Tcl error code. + * + * Side effects: + * The old representation may be freed, and new memory allocated. + * + *--------------------------------------------------------------------------- + */ + +int +Tcl_FSConvertToPathType(interp, objPtr) + Tcl_Interp *interp; /* Interpreter in which to store error + * message (if necessary). */ + Tcl_Obj *objPtr; /* Object to convert to a valid, current + * path type. */ +{ + /* + * While it is bad practice to examine an object's type directly, + * this is actually the best thing to do here. The reason is that + * if we are converting this object to FsPath type for the first + * time, we don't need to worry whether the 'cwd' has changed. + * On the other hand, if this object is already of FsPath type, + * and is a relative path, we do have to worry about the cwd. + * If the cwd has changed, we must recompute the path. + */ + if (objPtr->typePtr == &tclFsPathType) { + FsPath *fsPathPtr = (FsPath*) objPtr->internalRep.otherValuePtr; + if (fsPathPtr->filesystemEpoch != theFilesystemEpoch) { + FreeFsPathInternalRep(objPtr); + objPtr->typePtr = NULL; + return Tcl_ConvertToType(interp, objPtr, &tclFsPathType); + } + if (fsPathPtr->cwdPtr == NULL) { + return TCL_OK; + } else { + if (FsCwdPointerEquals(fsPathPtr->cwdPtr)) { + return TCL_OK; + } else { + FreeFsPathInternalRep(objPtr); + objPtr->typePtr = NULL; + return Tcl_ConvertToType(interp, objPtr, &tclFsPathType); + } + } + } else { + return Tcl_ConvertToType(interp, objPtr, &tclFsPathType); + } +} + + +/* + * Helper function for SetFsPathFromAny. Returns position of first + * directory delimiter in the path. + */ +static int +FindSplitPos(path, separator) + char *path; + char *separator; +{ + int count = 0; + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: + case TCL_PLATFORM_MAC: + while (path[count] != 0) { + if (path[count] == *separator) { + return count; + } + count++; + } + break; + + case TCL_PLATFORM_WINDOWS: + while (path[count] != 0) { + if (path[count] == *separator || path[count] == '\\') { + return count; + } + count++; + } + break; + } + return count; +} + +/* + *--------------------------------------------------------------------------- + * + * SetFsPathFromAbsoluteNormalized -- + * + * Like SetFsPathFromAny, but assumes the given object is an + * absolute normalized path. Only for internal use. + * + * Results: + * Standard Tcl error code. + * + * Side effects: + * The old representation may be freed, and new memory allocated. + * + *--------------------------------------------------------------------------- + */ + +static int +SetFsPathFromAbsoluteNormalized(interp, objPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr; /* The object to convert. */ +{ + FsPath *fsPathPtr; + + if (objPtr->typePtr == &tclFsPathType) { + return TCL_OK; + } + + /* Free old representation */ + if (objPtr->typePtr != NULL) { + if (objPtr->bytes == NULL) { + if (objPtr->typePtr->updateStringProc == NULL) { + if (interp != NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "can't find object", + "string representation", (char *) NULL); + } + return TCL_ERROR; + } + objPtr->typePtr->updateStringProc(objPtr); + } + if ((objPtr->typePtr->freeIntRepProc) != NULL) { + (*objPtr->typePtr->freeIntRepProc)(objPtr); + } + } + + fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); + /* It's a pure normalized absolute path */ + fsPathPtr->translatedPathPtr = NULL; + fsPathPtr->normPathPtr = objPtr; + fsPathPtr->cwdPtr = NULL; + fsPathPtr->nativePathPtr = NULL; + fsPathPtr->fsRecPtr = NULL; + fsPathPtr->filesystemEpoch = theFilesystemEpoch; + + objPtr->internalRep.otherValuePtr = (VOID *) fsPathPtr; + objPtr->typePtr = &tclFsPathType; + + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * SetFsPathFromAny -- + * + * This function tries to convert the given Tcl_Obj to a valid + * Tcl path type. + * + * The filename may begin with "~" (to indicate current user's + * home directory) or "~<user>" (to indicate any user's home + * directory). + * + * Results: + * Standard Tcl error code. + * + * Side effects: + * The old representation may be freed, and new memory allocated. + * + *--------------------------------------------------------------------------- + */ + +static int +SetFsPathFromAny(interp, objPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr; /* The object to convert. */ +{ + int len; + FsPath *fsPathPtr; + Tcl_Obj *transPtr; + char *name; + + if (objPtr->typePtr == &tclFsPathType) { + return TCL_OK; + } + + /* + * First step is to translate the filename. This is similar to + * Tcl_TranslateFilename, but shouldn't convert everything to + * windows backslashes on that platform. The current + * implementation of this piece is a slightly optimised version + * of the various Tilde/Split/Join stuff to avoid multiple + * split/join operations. + * + * We remove any trailing directory separator. + * + * However, the split/join routines are quite complex, and + * one has to make sure not to break anything on Unix, Win + * or MacOS (fCmd.test, fileName.test and cmdAH.test exercise + * most of the code). + */ + name = Tcl_GetStringFromObj(objPtr,&len); + + /* + * Handle tilde substitutions, if needed. + */ + if (name[0] == '~') { + char *expandedUser; + Tcl_DString temp; + int split; + char separator='/'; + + if (tclPlatform==TCL_PLATFORM_MAC) { + if (strchr(name, ':') != NULL) separator = ':'; + } + + split = FindSplitPos(name, &separator); + if (split != len) { + /* We have multiple pieces '~user/foo/bar...' */ + name[split] = '\0'; + } + /* Do some tilde substitution */ + if (name[1] == '\0') { + /* We have just '~' */ + CONST char *dir; + Tcl_DString dirString; + if (split != len) { name[split] = separator; } + + dir = TclGetEnv("HOME", &dirString); + if (dir == NULL) { + if (interp) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "couldn't find HOME environment ", + "variable to expand path", (char *) NULL); + } + return TCL_ERROR; + } + Tcl_DStringInit(&temp); + Tcl_JoinPath(1, &dir, &temp); + Tcl_DStringFree(&dirString); + } else { + /* We have a user name '~user' */ + Tcl_DStringInit(&temp); + if (TclpGetUserHome(name+1, &temp) == NULL) { + if (interp != NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "user \"", (name+1), + "\" doesn't exist", (char *) NULL); + } + Tcl_DStringFree(&temp); + if (split != len) { name[split] = separator; } + return TCL_ERROR; + } + if (split != len) { name[split] = separator; } + } + + expandedUser = Tcl_DStringValue(&temp); + transPtr = Tcl_NewStringObj(expandedUser, Tcl_DStringLength(&temp)); + + if (split != len) { + /* Join up the tilde substitution with the rest */ + if (name[split+1] == separator) { + + /* + * Somewhat tricky case like ~//foo/bar. + * Make use of Split/Join machinery to get it right. + * Assumes all paths beginning with ~ are part of the + * native filesystem. + */ + + int objc; + Tcl_Obj **objv; + Tcl_Obj *parts = TclpNativeSplitPath(objPtr, NULL); + Tcl_ListObjGetElements(NULL, parts, &objc, &objv); + /* Skip '~'. It's replaced by its expansion */ + objc--; objv++; + while (objc--) { + TclpNativeJoinPath(transPtr, Tcl_GetString(*objv++)); + } + Tcl_DecrRefCount(parts); + } else { + /* Simple case. "rest" is relative path. Just join it. */ + Tcl_Obj *rest = Tcl_NewStringObj(name+split+1,-1); + transPtr = Tcl_FSJoinToPath(transPtr, 1, &rest); + } + } + Tcl_DStringFree(&temp); + } else { + transPtr = Tcl_FSJoinToPath(objPtr,0,NULL); + } + + /* + * Now we have a translated filename in 'transPtr'. This will have + * forward slashes on Windows, and will not contain any ~user + * sequences. + */ + + fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); + fsPathPtr->translatedPathPtr = transPtr; + Tcl_IncrRefCount(fsPathPtr->translatedPathPtr); + fsPathPtr->normPathPtr = NULL; + fsPathPtr->cwdPtr = NULL; + fsPathPtr->nativePathPtr = NULL; + fsPathPtr->fsRecPtr = NULL; + fsPathPtr->filesystemEpoch = theFilesystemEpoch; + + /* + * Free old representation before installing our new one. + */ + if (objPtr->typePtr != NULL && objPtr->typePtr->freeIntRepProc != NULL) { + (objPtr->typePtr->freeIntRepProc)(objPtr); + } + objPtr->internalRep.otherValuePtr = (VOID *) fsPathPtr; + objPtr->typePtr = &tclFsPathType; + + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_FSNewNativePath -- + * + * This function performs the something like that 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 efficient way of creating the appropriate + * path object type. + * + * Any memory which is allocated for 'clientData' should be retained + * until clientData is passed to the filesystem's freeInternalRepProc + * when it can be freed. The built in platform-specific filesystems + * use 'ckalloc' to allocate clientData, and ckfree to free it. + * + * Results: + * NULL or a valid path object pointer, with refCount zero. + * + * Side effects: + * New memory may be allocated. + * + *--------------------------------------------------------------------------- + */ + +Tcl_Obj * +Tcl_FSNewNativePath(fromFilesystem, clientData) + Tcl_Filesystem* fromFilesystem; + ClientData clientData; +{ + Tcl_Obj *objPtr; + FsPath *fsPathPtr; + FilesystemRecord *fsFromPtr; + Tcl_FSInternalToNormalizedProc *proc; + int epoch; + + fsFromPtr = GetFilesystemRecord(fromFilesystem, &epoch); + + if (fsFromPtr == NULL) { + return NULL; + } + + proc = fsFromPtr->fsPtr->internalToNormalizedProc; + + if (proc == NULL) { + return NULL; + } + + objPtr = (*proc)(clientData); + if (objPtr == NULL) { + return NULL; + } + + /* + * Free old representation; shouldn't normally be any, + * but best to be safe. + */ + if (objPtr->typePtr != NULL) { + if (objPtr->bytes == NULL) { + if (objPtr->typePtr->updateStringProc == NULL) { + return NULL; + } + objPtr->typePtr->updateStringProc(objPtr); + } + if ((objPtr->typePtr->freeIntRepProc) != NULL) { + (*objPtr->typePtr->freeIntRepProc)(objPtr); + } + } + + fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); + fsPathPtr->translatedPathPtr = NULL; + /* Circular reference, by design */ + fsPathPtr->normPathPtr = objPtr; + fsPathPtr->cwdPtr = NULL; + fsPathPtr->nativePathPtr = clientData; + fsPathPtr->fsRecPtr = fsFromPtr; + /* We must increase the refCount for this filesystem. */ + fsPathPtr->fsRecPtr->fileRefCount++; + fsPathPtr->filesystemEpoch = epoch; + + objPtr->internalRep.otherValuePtr = (VOID *) fsPathPtr; + objPtr->typePtr = &tclFsPathType; + return objPtr; +} + +static void +FreeFsPathInternalRep(pathObjPtr) + Tcl_Obj *pathObjPtr; /* Path object with internal rep to free. */ +{ + register FsPath* fsPathPtr = + (FsPath*) pathObjPtr->internalRep.otherValuePtr; + + if (fsPathPtr->translatedPathPtr != NULL) { + Tcl_DecrRefCount(fsPathPtr->translatedPathPtr); + } + if (fsPathPtr->normPathPtr != NULL) { + if (fsPathPtr->normPathPtr != pathObjPtr) { + Tcl_DecrRefCount(fsPathPtr->normPathPtr); + } + fsPathPtr->normPathPtr = NULL; + } + if (fsPathPtr->cwdPtr != NULL) { + Tcl_DecrRefCount(fsPathPtr->cwdPtr); + } + if (fsPathPtr->nativePathPtr != NULL) { + if (fsPathPtr->fsRecPtr != NULL) { + if (fsPathPtr->fsRecPtr->fsPtr->freeInternalRepProc != NULL) { + (*fsPathPtr->fsRecPtr->fsPtr + ->freeInternalRepProc)(fsPathPtr->nativePathPtr); + fsPathPtr->nativePathPtr = NULL; + } + } + } + if (fsPathPtr->fsRecPtr != NULL) { + fsPathPtr->fsRecPtr->fileRefCount--; + if (fsPathPtr->fsRecPtr->fileRefCount <= 0) { + /* It has been unregistered already */ + ckfree((char *)fsPathPtr->fsRecPtr); + } + } + + ckfree((char*) fsPathPtr); +} + +static void +DupFsPathInternalRep(srcPtr, copyPtr) + Tcl_Obj *srcPtr; /* Path obj with internal rep to copy. */ + Tcl_Obj *copyPtr; /* Path obj with internal rep to set. */ +{ + register FsPath* srcFsPathPtr = + (FsPath*) srcPtr->internalRep.otherValuePtr; + register FsPath* copyFsPathPtr = + (FsPath*) ckalloc((unsigned)sizeof(FsPath)); + Tcl_FSDupInternalRepProc *dupProc; + + copyPtr->internalRep.otherValuePtr = (VOID *) copyFsPathPtr; + + if (srcFsPathPtr->translatedPathPtr != NULL) { + copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr; + Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr); + } else { + copyFsPathPtr->translatedPathPtr = NULL; + } + + if (srcFsPathPtr->normPathPtr != NULL) { + copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr; + if (copyFsPathPtr->normPathPtr != copyPtr) { + Tcl_IncrRefCount(copyFsPathPtr->normPathPtr); + } + } else { + copyFsPathPtr->normPathPtr = NULL; + } + + if (srcFsPathPtr->cwdPtr != NULL) { + copyFsPathPtr->cwdPtr = srcFsPathPtr->cwdPtr; + Tcl_IncrRefCount(copyFsPathPtr->cwdPtr); + } else { + copyFsPathPtr->cwdPtr = NULL; + } + + if (srcFsPathPtr->fsRecPtr != NULL + && srcFsPathPtr->nativePathPtr != NULL) { + dupProc = srcFsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc; + if (dupProc != NULL) { + copyFsPathPtr->nativePathPtr = + (*dupProc)(srcFsPathPtr->nativePathPtr); + } else { + copyFsPathPtr->nativePathPtr = NULL; + } + } else { + copyFsPathPtr->nativePathPtr = NULL; + } + copyFsPathPtr->fsRecPtr = srcFsPathPtr->fsRecPtr; + copyFsPathPtr->filesystemEpoch = srcFsPathPtr->filesystemEpoch; + if (copyFsPathPtr->fsRecPtr != NULL) { + copyFsPathPtr->fsRecPtr->fileRefCount++; + } + + copyPtr->typePtr = &tclFsPathType; +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_FSGetTranslatedPath -- + * + * This function 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) + * + * Results: + * NULL or a valid Tcl_Obj pointer. + * + * Side effects: + * Only those of 'Tcl_FSConvertToPathType' + * + *--------------------------------------------------------------------------- + */ + +Tcl_Obj* +Tcl_FSGetTranslatedPath(interp, pathPtr) + Tcl_Interp *interp; + Tcl_Obj* pathPtr; +{ + register FsPath* srcFsPathPtr; + if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) { + return NULL; + } + srcFsPathPtr = (FsPath*) pathPtr->internalRep.otherValuePtr; + if (srcFsPathPtr->translatedPathPtr == NULL) { + /* + * 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. + */ + return srcFsPathPtr->normPathPtr; + } else { + /* It is an ordinary path object */ + return srcFsPathPtr->translatedPathPtr; + } +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_FSGetTranslatedStringPath -- + * + * This function attempts to extract the translated path + * from the given Tcl_Obj. If the translation succeeds (i.e. the + * object is a valid path), then the path is returned. Otherwise NULL + * will be returned, and an error message may be left in the + * interpreter (if it is non-NULL) + * + * Results: + * NULL or a valid string. + * + * Side effects: + * Only those of 'Tcl_FSConvertToPathType' + * + *--------------------------------------------------------------------------- + */ +CONST char* +Tcl_FSGetTranslatedStringPath(interp, pathPtr) +Tcl_Interp *interp; +Tcl_Obj* pathPtr; +{ + Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr); + if (transPtr == NULL) { + return NULL; + } else { + return Tcl_GetString(transPtr); + } +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_FSGetNormalizedPath -- + * + * This important function attempts to extract from the given Tcl_Obj + * a unique normalised path representation, whose string value can + * be used as a unique identifier for the file. + * + * Results: + * NULL or a valid path object pointer. + * + * Side effects: + * New memory may be allocated. The Tcl 'errno' may be modified + * in the process of trying to examine various path possibilities. + * + *--------------------------------------------------------------------------- + */ + +Tcl_Obj* +Tcl_FSGetNormalizedPath(interp, pathObjPtr) + Tcl_Interp *interp; + Tcl_Obj* pathObjPtr; +{ + register FsPath* srcFsPathPtr; + if (Tcl_FSConvertToPathType(interp, pathObjPtr) != TCL_OK) { + return NULL; + } + srcFsPathPtr = (FsPath*) pathObjPtr->internalRep.otherValuePtr; + if (srcFsPathPtr->normPathPtr == NULL) { + int relative = 0; + /* + * Since normPathPtr is NULL, but this is a valid path + * object, we know that the translatedPathPtr cannot be NULL. + */ + Tcl_Obj *absolutePath = srcFsPathPtr->translatedPathPtr; + char *path = Tcl_GetString(absolutePath); + + /* + * We have to be a little bit careful here to avoid infinite loops + * we're asking Tcl_FSGetPathType to return the path's type, but + * that call can actually result in a lot of other filesystem + * action, which might loop back through here. + */ + if ((path[0] != '\0') && + (Tcl_FSGetPathType(pathObjPtr) == TCL_PATH_RELATIVE)) { + Tcl_Obj *cwd = Tcl_FSGetCwd(interp); + + if (cwd == NULL) { + return NULL; + } + + absolutePath = Tcl_FSJoinToPath(cwd, 1, &absolutePath); + Tcl_IncrRefCount(absolutePath); + Tcl_DecrRefCount(cwd); + + relative = 1; + } + /* Already has refCount incremented */ + srcFsPathPtr->normPathPtr = FSNormalizeAbsolutePath(interp, absolutePath); + if (!strcmp(Tcl_GetString(srcFsPathPtr->normPathPtr), + Tcl_GetString(pathObjPtr))) { + /* + * The path was already normalized. + * Get rid of the duplicate. + */ + Tcl_DecrRefCount(srcFsPathPtr->normPathPtr); + /* + * We do *not* increment the refCount for + * this circular reference + */ + srcFsPathPtr->normPathPtr = pathObjPtr; + } + if (relative) { + /* This was returned by Tcl_FSJoinToPath above */ + Tcl_DecrRefCount(absolutePath); + + /* Get a quick, temporary lock on the cwd while we copy it */ + Tcl_MutexLock(&cwdMutex); + srcFsPathPtr->cwdPtr = cwdPathPtr; + Tcl_IncrRefCount(srcFsPathPtr->cwdPtr); + Tcl_MutexUnlock(&cwdMutex); + } + } + return srcFsPathPtr->normPathPtr; +} + +/* + *--------------------------------------------------------------------------- + * + * 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. + * + * If the internal representation is currently NULL, we attempt + * to generate it, by calling the filesystem's + * 'Tcl_FSCreateInternalRepProc'. + * + * Results: + * NULL or a valid internal representation. + * + * Side effects: + * An attempt may be made to convert the object. + * + *--------------------------------------------------------------------------- + */ + +ClientData +Tcl_FSGetInternalRep(pathObjPtr, fsPtr) + Tcl_Obj* pathObjPtr; + Tcl_Filesystem *fsPtr; +{ + register FsPath* srcFsPathPtr; + + if (Tcl_FSConvertToPathType(NULL, pathObjPtr) != TCL_OK) { + return NULL; + } + srcFsPathPtr = (FsPath*) pathObjPtr->internalRep.otherValuePtr; + + /* + * 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. + * + * 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. + */ + if (srcFsPathPtr->fsRecPtr == 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(pathObjPtr); + + /* + * 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 = (FsPath*) pathObjPtr->internalRep.otherValuePtr; + if (srcFsPathPtr->fsRecPtr == NULL) { + return NULL; + } + } + + if (fsPtr != srcFsPathPtr->fsRecPtr->fsPtr) { + /* + * 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. + */ + Tcl_Filesystem *actualFs = Tcl_FSGetFileSystemForPath(pathObjPtr); + if (actualFs == fsPtr) { + return Tcl_FSGetInternalRep(pathObjPtr, fsPtr); + } + return NULL; + } + + if (srcFsPathPtr->nativePathPtr == NULL) { + Tcl_FSCreateInternalRepProc *proc; + proc = srcFsPathPtr->fsRecPtr->fsPtr->createInternalRepProc; + + if (proc == NULL) { + return NULL; + } + srcFsPathPtr->nativePathPtr = (*proc)(pathObjPtr); + } + return srcFsPathPtr->nativePathPtr; +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_FSGetNativePath -- + * + * This function is for use by the Win/Unix/MacOS native filesystems, + * so that they can easily retrieve the native (char* or TCHAR*) + * 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 procedures 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 procedures + * not in this file), then one cannot necessarily guarantee that + * the path object pointer is from the correct filesystem. + * + * Note: in the future it might be desireable to have separate + * versions of this function with different signatures, for + * example Tcl_FSGetNativeMacPath, Tcl_FSGetNativeUnixPath etc. + * Right now, since native paths are all string based, we use just + * one function. On MacOS we could possibly use an FSSpec or + * FSRef as the native representation. + * + * Results: + * NULL or a valid native path. + * + * Side effects: + * See Tcl_FSGetInternalRep. + * + *--------------------------------------------------------------------------- + */ + +CONST char * +Tcl_FSGetNativePath(pathObjPtr) + Tcl_Obj *pathObjPtr; +{ + return (CONST char *)Tcl_FSGetInternalRep(pathObjPtr, &tclNativeFilesystem); +} + +/* + *--------------------------------------------------------------------------- + * + * NativeCreateNativeRep -- + * + * Create a native representation for the given path. + * + * Results: + * None. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ +static ClientData +NativeCreateNativeRep(pathObjPtr) + Tcl_Obj* pathObjPtr; +{ + char *nativePathPtr; + Tcl_DString ds; + Tcl_Obj* normPtr; + int len; + char *str; + + /* Make sure the normalized path is set */ + normPtr = Tcl_FSGetNormalizedPath(NULL, pathObjPtr); + + str = Tcl_GetStringFromObj(normPtr,&len); +#ifdef __WIN32__ + Tcl_WinUtfToTChar(str, len, &ds); + if (tclWinProcs->useWide) { + nativePathPtr = ckalloc((unsigned)(sizeof(WCHAR)+Tcl_DStringLength(&ds))); + memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds), + (size_t) (sizeof(WCHAR)+Tcl_DStringLength(&ds))); + } else { + nativePathPtr = ckalloc((unsigned)(sizeof(char)+Tcl_DStringLength(&ds))); + memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds), + (size_t) (sizeof(char)+Tcl_DStringLength(&ds))); + } +#else + Tcl_UtfToExternalDString(NULL, str, len, &ds); + nativePathPtr = ckalloc((unsigned)(sizeof(char)+Tcl_DStringLength(&ds))); + memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds), + (size_t) (sizeof(char)+Tcl_DStringLength(&ds))); +#endif + + Tcl_DStringFree(&ds); + return (ClientData)nativePathPtr; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpNativeToNormalized -- + * + * Convert native format to a normalized path object, with refCount + * of zero. + * + * Results: + * A valid normalized path. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ +Tcl_Obj* +TclpNativeToNormalized(clientData) + ClientData clientData; +{ + Tcl_DString ds; + Tcl_Obj *objPtr; + CONST char *copy; + int len; + +#ifdef __WIN32__ + Tcl_WinTCharToUtf((CONST char*)clientData, -1, &ds); +#else + Tcl_ExternalToUtfDString(NULL, (CONST char*)clientData, -1, &ds); +#endif + + copy = Tcl_DStringValue(&ds); + len = Tcl_DStringLength(&ds); + +#ifdef __WIN32__ + /* + * Certain native path representations on Windows have this special + * prefix to indicate that they are to be treated specially. For + * example extremely long paths, or symlinks + */ + if (*copy == '\\') { + if (0 == strncmp(copy,"\\??\\",4)) { + copy += 4; + len -= 4; + } else if (0 == strncmp(copy,"\\\\?\\",4)) { + copy += 4; + len -= 4; + } + } +#endif + + objPtr = Tcl_NewStringObj(copy,len); + Tcl_DStringFree(&ds); + + return objPtr; +} + + +/* + *--------------------------------------------------------------------------- + * + * NativeDupInternalRep -- + * + * Duplicate the native representation. + * + * Results: + * The copied native representation, or NULL if it is not possible + * to copy the representation. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ +static ClientData +NativeDupInternalRep(clientData) + ClientData clientData; +{ + ClientData copy; + size_t len; + + if (clientData == NULL) { + return NULL; + } + +#ifdef __WIN32__ + if (tclWinProcs->useWide) { + /* unicode representation when running on NT/2K/XP */ + len = sizeof(WCHAR) + (wcslen((CONST WCHAR*)clientData) * sizeof(WCHAR)); + } else { + /* ansi representation when running on 95/98/ME */ + len = sizeof(char) + (strlen((CONST char*)clientData) * sizeof(char)); + } +#else + /* ansi representation when running on Unix/MacOS */ + len = sizeof(char) + (strlen((CONST char*)clientData) * sizeof(char)); +#endif + + copy = (ClientData) ckalloc(len); + memcpy((VOID*)copy, (VOID*)clientData, len); + return copy; +} + +/* + *--------------------------------------------------------------------------- + * + * NativePathInFilesystem -- + * + * Any path object is acceptable to the native filesystem, by + * default (we will throw errors when illegal paths are actually + * tried to be used). + * + * However, this behavior means the native filesystem must be + * the last filesystem in the lookup list (otherwise it will + * claim all files belong to it, and other filesystems will + * never get a look in). + * + * Results: + * TCL_OK, to indicate 'yes', -1 to indicate no. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ +static int +NativePathInFilesystem(pathPtr, clientDataPtr) + Tcl_Obj *pathPtr; + ClientData *clientDataPtr; +{ + int len; + Tcl_GetStringFromObj(pathPtr,&len); + if (len == 0) { + return -1; + } else { + /* We accept any path as valid */ + return TCL_OK; + } +} + +/* + *--------------------------------------------------------------------------- + * + * NativeFreeInternalRep -- + * + * Free a native internal representation, which will be non-NULL. + * + * Results: + * None. + * + * Side effects: + * Memory is released. + * + *--------------------------------------------------------------------------- + */ +static void +NativeFreeInternalRep(clientData) + ClientData clientData; +{ + ckfree((char*)clientData); +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_FSFileSystemInfo -- + * + * 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. + * + * Side effects: + * The object may be converted to a path type. + * + *--------------------------------------------------------------------------- + */ +Tcl_Obj* +Tcl_FSFileSystemInfo(pathObjPtr) + Tcl_Obj* pathObjPtr; +{ + Tcl_Obj *resPtr; + Tcl_FSFilesystemPathTypeProc *proc; + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathObjPtr); + + if (fsPtr == NULL) { + return NULL; + } + + resPtr = Tcl_NewListObj(0,NULL); + + Tcl_ListObjAppendElement(NULL, resPtr, + Tcl_NewStringObj(fsPtr->typeName,-1)); + + proc = fsPtr->filesystemPathTypeProc; + if (proc != NULL) { + Tcl_Obj *typePtr = (*proc)(pathObjPtr); + if (typePtr != NULL) { + Tcl_ListObjAppendElement(NULL, resPtr, typePtr); + } + } + + return resPtr; +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_FSPathSeparator -- + * + * 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. + * + * Side effects: + * The path object may be converted to a path type. + * + *--------------------------------------------------------------------------- + */ +Tcl_Obj* +Tcl_FSPathSeparator(pathObjPtr) + Tcl_Obj* pathObjPtr; +{ + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathObjPtr); + + if (fsPtr == NULL) { + return NULL; + } + if (fsPtr->filesystemSeparatorProc != NULL) { + return (*fsPtr->filesystemSeparatorProc)(pathObjPtr); + } + + return NULL; +} + +/* + *--------------------------------------------------------------------------- + * + * NativeFilesystemSeparator -- + * + * This function is part of the native filesystem support, and + * returns the separator for the given path. + * + * Results: + * String object containing the separator character. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ +static Tcl_Obj* +NativeFilesystemSeparator(pathObjPtr) + Tcl_Obj* pathObjPtr; +{ + char *separator = NULL; /* lint */ + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: + separator = "/"; + break; + case TCL_PLATFORM_WINDOWS: + separator = "\\"; + break; + case TCL_PLATFORM_MAC: + separator = ":"; + break; + } + return Tcl_NewStringObj(separator,1); +} + +/* + *--------------------------------------------------------------------------- + * + * 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. + * + * Results: +.* NULL or a filesystem which will accept this path. + * + * Side effects: + * The object may be converted to a path type. + * + *--------------------------------------------------------------------------- + */ + +Tcl_Filesystem* +Tcl_FSGetFileSystemForPath(pathObjPtr) + Tcl_Obj* pathObjPtr; +{ + FilesystemRecord *fsRecPtr; + Tcl_Filesystem* retVal = NULL; + FsPath* srcFsPathPtr; + + /* + * 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 (pathObjPtr->refCount == 0) { + return NULL; + } + + /* + * This will ensure the pathObjPtr 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. + */ + + if (Tcl_FSGetNormalizedPath(NULL, pathObjPtr) == NULL) { + return NULL; + } + + /* + * Get a lock on theFilesystemEpoch and the filesystemList + * + * While we don't need the fsRecPtr until the while loop below, we + * do want to make sure the theFilesystemEpoch doesn't change + * between the 'if' and 'while' blocks, getting this iterator will + * ensure that everything is consistent + */ + fsRecPtr = FsGetIterator(); + + /* Make sure pathObjPtr is of the correct epoch */ + + srcFsPathPtr = (FsPath*) pathObjPtr->internalRep.otherValuePtr; + + /* + * Check if the filesystem has changed in some way since + * this object's internal representation was calculated. + */ + if (srcFsPathPtr->filesystemEpoch != theFilesystemEpoch) { + /* + * We have to discard the stale representation and + * recalculate it + */ + FreeFsPathInternalRep(pathObjPtr); + pathObjPtr->typePtr = NULL; + if (SetFsPathFromAny(NULL, pathObjPtr) != TCL_OK) { + goto done; + } + srcFsPathPtr = (FsPath*) pathObjPtr->internalRep.otherValuePtr; + } + + /* Check whether the object is already assigned to a fs */ + if (srcFsPathPtr->fsRecPtr != NULL) { + retVal = srcFsPathPtr->fsRecPtr->fsPtr; + goto done; + } + + /* + * Call each of the "pathInFilesystem" functions in succession. A + * non-return value of -1 indicates the particular function has + * succeeded. + */ + + while ((retVal == NULL) && (fsRecPtr != NULL)) { + Tcl_FSPathInFilesystemProc *proc = fsRecPtr->fsPtr->pathInFilesystemProc; + if (proc != NULL) { + ClientData clientData = NULL; + int ret = (*proc)(pathObjPtr, &clientData); + if (ret != -1) { + /* + * We assume the srcFsPathPtr hasn't been changed + * by the above call to the pathInFilesystemProc. + */ + srcFsPathPtr->fsRecPtr = fsRecPtr; + srcFsPathPtr->nativePathPtr = clientData; + srcFsPathPtr->filesystemEpoch = theFilesystemEpoch; + fsRecPtr->fileRefCount++; + retVal = fsRecPtr->fsPtr; + } + } + fsRecPtr = fsRecPtr->nextPtr; + } + + done: + FsReleaseIterator(); + return retVal; +} + +/* Simple helper function */ +static FilesystemRecord* +GetFilesystemRecord(fromFilesystem, epoch) + Tcl_Filesystem *fromFilesystem; + int *epoch; +{ + FilesystemRecord *fsRecPtr = FsGetIterator(); + while (fsRecPtr != NULL) { + if (fsRecPtr->fsPtr == fromFilesystem) { + *epoch = theFilesystemEpoch; + break; + } + fsRecPtr = fsRecPtr->nextPtr; + } + FsReleaseIterator(); + return fsRecPtr; +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_FSEqualPaths -- + * + * This function tests whether the two paths given are equal path + * objects. If either or both is NULL, 0 is always returned. + * + * Results: + * 1 or 0. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +int +Tcl_FSEqualPaths(firstPtr, secondPtr) + Tcl_Obj* firstPtr; + Tcl_Obj* secondPtr; +{ + if (firstPtr == secondPtr) { + return 1; + } else { + int tempErrno; + + if (firstPtr == NULL || secondPtr == NULL) { + return 0; + } + if (!(strcmp(Tcl_GetString(firstPtr), Tcl_GetString(secondPtr)))) { + return 1; + } + /* + * Try the most thorough, correct method of comparing fully + * normalized paths + */ + + tempErrno = Tcl_GetErrno(); + firstPtr = Tcl_FSGetNormalizedPath(NULL, firstPtr); + secondPtr = Tcl_FSGetNormalizedPath(NULL, secondPtr); + Tcl_SetErrno(tempErrno); + + if (firstPtr == NULL || secondPtr == NULL) { + return 0; + } + if (!(strcmp(Tcl_GetString(firstPtr), Tcl_GetString(secondPtr)))) { + return 1; + } + } + return 0; +} + +/* + * utime wants a normalized, NOT native path. I assume a native + * version of 'utime' doesn't exist (at least under that name) on NT/2000. + * If a native function does exist somewhere, then we could use: + * + * return native_utime(Tcl_FSGetNativePath(pathPtr),tval); + * + * This seems rather strange when compared with stat, lstat, access, etc. + * all of which want a native path. + */ +static int +NativeUtime(pathPtr, tval) + Tcl_Obj *pathPtr; + struct utimbuf *tval; +{ +#ifdef MAC_TCL + long gmt_offset=TclpGetGMTOffset(); + struct utimbuf local_tval; + local_tval.actime=tval->actime+gmt_offset; + local_tval.modtime=tval->modtime+gmt_offset; + return utime(Tcl_GetString(Tcl_FSGetNormalizedPath(NULL,pathPtr)), + &local_tval); +#else + return utime(Tcl_GetString(Tcl_FSGetNormalizedPath(NULL,pathPtr)),tval); +#endif +} + +/* Everything from here on is contained in this obsolete ifdef */ +#ifdef USE_OBSOLETE_FS_HOOKS + +/* + *---------------------------------------------------------------------- + * * TclStatInsertProc -- * * Insert the passed procedure pointer at the head of the list of * functions which are used during a call to 'TclStat(...)'. The - * passed function should be have exactly like 'TclStat' when called - * during that time (see 'TclStat(...)' for more informatin). + * passed function should behave exactly like 'TclStat' when called + * during that time (see 'TclStat(...)' for more information). * The function will be added even if it already in the list. * * Results: @@ -578,7 +5020,7 @@ Tcl_OpenFileChannel(interp, fileName, modeString, permissions) * could not be allocated. * * Side effects: - * Memory allocataed and modifies the link list for 'TclStat' + * Memory allocated and modifies the link list for 'TclStat' * functions. * *---------------------------------------------------------------------- @@ -597,10 +5039,10 @@ TclStatInsertProc (proc) if (newStatProcPtr != NULL) { newStatProcPtr->proc = proc; - Tcl_MutexLock(&hookMutex); + Tcl_MutexLock(&obsoleteFsHookMutex); newStatProcPtr->nextPtr = statProcList; statProcList = newStatProcPtr; - Tcl_MutexUnlock(&hookMutex); + Tcl_MutexUnlock(&obsoleteFsHookMutex); retVal = TCL_OK; } @@ -636,7 +5078,7 @@ TclStatDeleteProc (proc) StatProc *tmpStatProcPtr; StatProc *prevStatProcPtr = NULL; - Tcl_MutexLock(&hookMutex); + Tcl_MutexLock(&obsoleteFsHookMutex); tmpStatProcPtr = statProcList; /* * Traverse the 'statProcList' looking for the particular node @@ -644,7 +5086,7 @@ TclStatDeleteProc (proc) * the list. Ensure that the "default" node cannot be removed. */ - while ((retVal == TCL_ERROR) && (tmpStatProcPtr != &defaultStatProc)) { + while ((retVal == TCL_ERROR) && (tmpStatProcPtr != NULL)) { if (tmpStatProcPtr->proc == proc) { if (prevStatProcPtr == NULL) { statProcList = tmpStatProcPtr->nextPtr; @@ -652,7 +5094,7 @@ TclStatDeleteProc (proc) prevStatProcPtr->nextPtr = tmpStatProcPtr->nextPtr; } - Tcl_Free((char *)tmpStatProcPtr); + ckfree((char *)tmpStatProcPtr); retVal = TCL_OK; } else { @@ -661,7 +5103,7 @@ TclStatDeleteProc (proc) } } - Tcl_MutexUnlock(&hookMutex); + Tcl_MutexUnlock(&obsoleteFsHookMutex); return (retVal); } @@ -671,17 +5113,18 @@ TclStatDeleteProc (proc) * TclAccessInsertProc -- * * Insert the passed procedure pointer at the head of the list of - * functions which are used during a call to 'TclAccess(...)'. The - * passed function should be have exactly like 'TclAccess' when - * called during that time (see 'TclAccess(...)' for more informatin). - * The function will be added even if it already in the list. + * functions which are used during a call to 'TclAccess(...)'. + * The passed function should behave exactly like 'TclAccess' when + * called during that time (see 'TclAccess(...)' for more + * information). The function will be added even if it already in + * the list. * * Results: * Normally TCL_OK; TCL_ERROR if memory for a new node in the list * could not be allocated. * * Side effects: - * Memory allocataed and modifies the link list for 'TclAccess' + * Memory allocated and modifies the link list for 'TclAccess' * functions. * *---------------------------------------------------------------------- @@ -700,10 +5143,10 @@ TclAccessInsertProc(proc) if (newAccessProcPtr != NULL) { newAccessProcPtr->proc = proc; - Tcl_MutexLock(&hookMutex); + Tcl_MutexLock(&obsoleteFsHookMutex); newAccessProcPtr->nextPtr = accessProcList; accessProcList = newAccessProcPtr; - Tcl_MutexUnlock(&hookMutex); + Tcl_MutexUnlock(&obsoleteFsHookMutex); retVal = TCL_OK; } @@ -745,9 +5188,9 @@ TclAccessDeleteProc(proc) * the list. Ensure that the "default" node cannot be removed. */ - Tcl_MutexLock(&hookMutex); + Tcl_MutexLock(&obsoleteFsHookMutex); tmpAccessProcPtr = accessProcList; - while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != &defaultAccessProc)) { + while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != NULL)) { if (tmpAccessProcPtr->proc == proc) { if (prevAccessProcPtr == NULL) { accessProcList = tmpAccessProcPtr->nextPtr; @@ -755,7 +5198,7 @@ TclAccessDeleteProc(proc) prevAccessProcPtr->nextPtr = tmpAccessProcPtr->nextPtr; } - Tcl_Free((char *)tmpAccessProcPtr); + ckfree((char *)tmpAccessProcPtr); retVal = TCL_OK; } else { @@ -763,7 +5206,7 @@ TclAccessDeleteProc(proc) tmpAccessProcPtr = tmpAccessProcPtr->nextPtr; } } - Tcl_MutexUnlock(&hookMutex); + Tcl_MutexUnlock(&obsoleteFsHookMutex); return (retVal); } @@ -775,9 +5218,9 @@ TclAccessDeleteProc(proc) * * Insert the passed procedure pointer at the head of the list of * functions which are used during a call to - * 'Tcl_OpenFileChannel(...)'. The passed function should be have + * 'Tcl_OpenFileChannel(...)'. The passed function should behave * exactly like 'Tcl_OpenFileChannel' when called during that time - * (see 'Tcl_OpenFileChannel(...)' for more informatin). The + * (see 'Tcl_OpenFileChannel(...)' for more information). The * function will be added even if it already in the list. * * Results: @@ -785,7 +5228,7 @@ TclAccessDeleteProc(proc) * could not be allocated. * * Side effects: - * Memory allocataed and modifies the link list for + * Memory allocated and modifies the link list for * 'Tcl_OpenFileChannel' functions. * *---------------------------------------------------------------------- @@ -805,10 +5248,10 @@ TclOpenFileChannelInsertProc(proc) if (newOpenFileChannelProcPtr != NULL) { newOpenFileChannelProcPtr->proc = proc; - Tcl_MutexLock(&hookMutex); + Tcl_MutexLock(&obsoleteFsHookMutex); newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList; openFileChannelProcList = newOpenFileChannelProcPtr; - Tcl_MutexUnlock(&hookMutex); + Tcl_MutexUnlock(&obsoleteFsHookMutex); retVal = TCL_OK; } @@ -824,7 +5267,7 @@ TclOpenFileChannelInsertProc(proc) * * Removed the passed function pointer from the list of * 'Tcl_OpenFileChannel' functions. Ensures that the built-in - * open file channel function is not removvable. + * open file channel function is not removable. * * Results: * TCL_OK if the procedure pointer was successfully removed, @@ -847,13 +5290,13 @@ TclOpenFileChannelDeleteProc(proc) /* * Traverse the 'openFileChannelProcList' looking for the particular * node whose 'proc' member matches 'proc' and remove that one from - * the list. Ensure that the "default" node cannot be removed. + * the list. */ - Tcl_MutexLock(&hookMutex); + Tcl_MutexLock(&obsoleteFsHookMutex); tmpOpenFileChannelProcPtr = openFileChannelProcList; while ((retVal == TCL_ERROR) && - (tmpOpenFileChannelProcPtr != &defaultOpenFileChannelProc)) { + (tmpOpenFileChannelProcPtr != NULL)) { if (tmpOpenFileChannelProcPtr->proc == proc) { if (prevOpenFileChannelProcPtr == NULL) { openFileChannelProcList = tmpOpenFileChannelProcPtr->nextPtr; @@ -862,7 +5305,7 @@ TclOpenFileChannelDeleteProc(proc) tmpOpenFileChannelProcPtr->nextPtr; } - Tcl_Free((char *)tmpOpenFileChannelProcPtr); + ckfree((char *)tmpOpenFileChannelProcPtr); retVal = TCL_OK; } else { @@ -870,7 +5313,8 @@ TclOpenFileChannelDeleteProc(proc) tmpOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr->nextPtr; } } - Tcl_MutexUnlock(&hookMutex); + Tcl_MutexUnlock(&obsoleteFsHookMutex); return (retVal); } +#endif /* USE_OBSOLETE_FS_HOOKS */ diff --git a/tcl/generic/tclIndexObj.c b/tcl/generic/tclIndexObj.c index 3187de62c0a..b8ebd014bb9 100644 --- a/tcl/generic/tclIndexObj.c +++ b/tcl/generic/tclIndexObj.c @@ -14,6 +14,7 @@ */ #include "tclInt.h" +#include "tclPort.h" /* * Prototypes for procedures defined later in this file: @@ -21,6 +22,10 @@ static int SetIndexFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); +static void UpdateStringOfIndex _ANSI_ARGS_((Tcl_Obj *objPtr)); +static void DupIndex _ANSI_ARGS_((Tcl_Obj *srcPtr, + Tcl_Obj *dupPtr)); +static void FreeIndex _ANSI_ARGS_((Tcl_Obj *objPtr)); /* * The structure below defines the index Tcl object type by means of @@ -29,18 +34,36 @@ static int SetIndexFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_ObjType tclIndexType = { "index", /* name */ - (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ - (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ - (Tcl_UpdateStringProc *) NULL, /* updateStringProc */ + FreeIndex, /* freeIntRepProc */ + DupIndex, /* dupIntRepProc */ + UpdateStringOfIndex, /* updateStringProc */ SetIndexFromAny /* setFromAnyProc */ }; /* - * Boolean flag indicating whether or not the tclIndexType object - * type has been registered with the Tcl compiler. + * The definition of the internal representation of the "index" + * object; The internalRep.otherValuePtr field of an object of "index" + * type will be a pointer to one of these structures. + * + * Keep this structure declaration in sync with tclTestObj.c + */ + +typedef struct { + VOID *tablePtr; /* Pointer to the table of strings */ + int offset; /* Offset between table entries */ + int index; /* Selected index into table. */ +} IndexRep; + +/* + * The following macros greatly simplify moving through a table... */ +#define STRING_AT(table, offset, index) \ + (*((CONST char * CONST *)(((char *)(table)) + ((offset) * (index))))) +#define NEXT_ENTRY(table, offset) \ + (&(STRING_AT(table, offset, 1))) +#define EXPAND_OF(indexRep) \ + STRING_AT((indexRep)->tablePtr, (indexRep)->offset, (indexRep)->index) -static int indexTypeInitialized = 0; /* *---------------------------------------------------------------------- @@ -73,10 +96,10 @@ int Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr) Tcl_Interp *interp; /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr; /* Object containing the string to lookup. */ - char **tablePtr; /* Array of strings to compare against the + CONST char **tablePtr; /* Array of strings to compare against the * value of objPtr; last entry must be NULL * and there must not be duplicate entries. */ - char *msg; /* Identifying word to use in error messages. */ + CONST char *msg; /* Identifying word to use in error messages. */ int flags; /* 0 or TCL_EXACT */ int *indexPtr; /* Place to store resulting integer index. */ { @@ -88,10 +111,17 @@ Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr) * is cached). */ - if ((objPtr->typePtr == &tclIndexType) - && (objPtr->internalRep.twoPtrValue.ptr1 == (VOID *) tablePtr)) { - *indexPtr = (int) objPtr->internalRep.twoPtrValue.ptr2; - return TCL_OK; + if (objPtr->typePtr == &tclIndexType) { + IndexRep *indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr; + /* + * Here's hoping we don't get hit by unfortunate packing + * constraints on odd platforms like a Cray PVP... + */ + if (indexRep->tablePtr == (VOID *)tablePtr && + indexRep->offset == sizeof(char *)) { + *indexPtr = indexRep->index; + return TCL_OK; + } } return Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, sizeof(char *), msg, flags, indexPtr); @@ -131,28 +161,33 @@ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) Tcl_Interp *interp; /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr; /* Object containing the string to lookup. */ - char **tablePtr; /* The first string in the table. The second + CONST VOID *tablePtr; /* The first string in the table. The second * string will be at this address plus the * offset, the third plus the offset again, * etc. The last entry must be NULL * and there must not be duplicate entries. */ int offset; /* The number of bytes between entries */ - char *msg; /* Identifying word to use in error messages. */ + 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 index, length, i, numAbbrev; - char *key, *p1, *p2, **entryPtr; + char *key, *p1; + CONST char *p2; + CONST char * CONST *entryPtr; Tcl_Obj *resultPtr; + IndexRep *indexRep; /* * See if there is a valid cached result from a previous lookup. */ - if ((objPtr->typePtr == &tclIndexType) - && (objPtr->internalRep.twoPtrValue.ptr1 == (VOID *) tablePtr)) { - *indexPtr = (int) objPtr->internalRep.twoPtrValue.ptr2; - return TCL_OK; + if (objPtr->typePtr == &tclIndexType) { + indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr; + if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) { + *indexPtr = indexRep->index; + return TCL_OK; + } } /* @@ -160,16 +195,6 @@ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, * abbreviations unless TCL_EXACT is set in flags. */ - if (!indexTypeInitialized) { - /* - * This is the first time we've done a lookup. Register the - * tclIndexType. - */ - - Tcl_RegisterObjType(&tclIndexType); - indexTypeInitialized = 1; - } - key = Tcl_GetStringFromObj(objPtr, &length); index = -1; numAbbrev = 0; @@ -182,15 +207,21 @@ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, goto error; } + /* + * Scan the table looking for one of: + * - An exact match (always preferred) + * - A single abbreviation (allowed depending on flags) + * - Several abbreviations (never allowed, but overridden by exact match) + */ for (entryPtr = tablePtr, i = 0; *entryPtr != NULL; - entryPtr = (char **) ((long) entryPtr + offset), i++) { + entryPtr = NEXT_ENTRY(entryPtr, offset), i++) { for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) { - if (*p1 == 0) { + if (*p1 == '\0') { index = i; goto done; } } - if (*p1 == 0) { + if (*p1 == '\0') { /* * The value is an abbreviation for this entry. Continue * checking other entries to make sure it's unique. If we @@ -203,36 +234,51 @@ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, index = i; } } + /* + * Check if we were instructed to disallow abbreviations. + */ if ((flags & TCL_EXACT) || (numAbbrev != 1)) { goto error; } done: - if ((objPtr->typePtr != NULL) - && (objPtr->typePtr->freeIntRepProc != NULL)) { - objPtr->typePtr->freeIntRepProc(objPtr); - } - objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) tablePtr; /* - * Make sure to account for offsets != sizeof(char *). [Bug 5153] + * Cache the found representation. Note that we want to avoid + * allocating a new internal-rep if at all possible since that is + * potentially a slow operation. */ - objPtr->internalRep.twoPtrValue.ptr2 = - (VOID *) (index * (offset / sizeof(char *))); - objPtr->typePtr = &tclIndexType; + if (objPtr->typePtr == &tclIndexType) { + indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr; + } else { + if ((objPtr->typePtr != NULL) + && (objPtr->typePtr->freeIntRepProc != NULL)) { + objPtr->typePtr->freeIntRepProc(objPtr); + } + indexRep = (IndexRep *) ckalloc(sizeof(IndexRep)); + objPtr->internalRep.otherValuePtr = (VOID *) indexRep; + objPtr->typePtr = &tclIndexType; + } + indexRep->tablePtr = (VOID*) tablePtr; + indexRep->offset = offset; + indexRep->index = index; + *indexPtr = index; return TCL_OK; error: if (interp != NULL) { + /* + * Produce a fancy error message. + */ int count; resultPtr = Tcl_GetObjResult(interp); Tcl_AppendStringsToObj(resultPtr, (numAbbrev > 1) ? "ambiguous " : "bad ", msg, " \"", - key, "\": must be ", *tablePtr, (char *) NULL); - for (entryPtr = (char **) ((long) tablePtr + offset), count = 0; + key, "\": must be ", STRING_AT(tablePtr,offset,0), (char*)NULL); + for (entryPtr = NEXT_ENTRY(tablePtr, offset), count = 0; *entryPtr != NULL; - entryPtr = (char **) ((long) entryPtr + offset), count++) { - if ((*((char **) ((long) entryPtr + offset))) == NULL) { + entryPtr = NEXT_ENTRY(entryPtr, offset), count++) { + if (*NEXT_ENTRY(entryPtr, offset) == NULL) { Tcl_AppendStringsToObj(resultPtr, (count > 0) ? ", or " : " or ", *entryPtr, (char *) NULL); @@ -279,6 +325,94 @@ SetIndexFromAny(interp, objPtr) /* *---------------------------------------------------------------------- * + * UpdateStringOfIndex -- + * + * This procedure is called to convert a Tcl object from index + * internal form to its string form. No abbreviation is ever + * generated. + * + * Results: + * None. + * + * Side effects: + * The string representation of the object is updated. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateStringOfIndex(objPtr) + Tcl_Obj *objPtr; +{ + IndexRep *indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr; + register char *buf; + register unsigned len; + register CONST char *indexStr = EXPAND_OF(indexRep); + + len = strlen(indexStr); + buf = (char *) ckalloc(len + 1); + memcpy(buf, indexStr, len+1); + objPtr->bytes = buf; + objPtr->length = len; +} + +/* + *---------------------------------------------------------------------- + * + * DupIndex -- + * + * This procedure is called to copy the internal rep of an index + * Tcl object from to another object. + * + * Results: + * None. + * + * Side effects: + * The internal representation of the target object is updated + * and the type is set. + * + *---------------------------------------------------------------------- + */ + +static void +DupIndex(srcPtr, dupPtr) + Tcl_Obj *srcPtr, *dupPtr; +{ + IndexRep *srcIndexRep = (IndexRep *) srcPtr->internalRep.otherValuePtr; + IndexRep *dupIndexRep = (IndexRep *) ckalloc(sizeof(IndexRep)); + + memcpy(dupIndexRep, srcIndexRep, sizeof(IndexRep)); + dupPtr->internalRep.otherValuePtr = (VOID *) dupIndexRep; + dupPtr->typePtr = &tclIndexType; +} + +/* + *---------------------------------------------------------------------- + * + * FreeIndex -- + * + * This procedure is called to delete the internal rep of an index + * Tcl object. + * + * Results: + * None. + * + * Side effects: + * The internal representation of the target object is deleted. + * + *---------------------------------------------------------------------- + */ + +static void +FreeIndex(objPtr) + Tcl_Obj *objPtr; +{ + ckfree((char *) objPtr->internalRep.otherValuePtr); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_WrongNumArgs -- * * This procedure generates a "wrong # args" error message in an @@ -308,13 +442,13 @@ Tcl_WrongNumArgs(interp, objc, objv, message) Tcl_Obj *CONST objv[]; /* Initial argument objects, which * should be included in the error * message. */ - char *message; /* Error message to print after the + CONST char *message; /* Error message to print after the * leading objects in objv. The * message may be NULL. */ { Tcl_Obj *objPtr; - char **tablePtr; int i; + register IndexRep *indexRep; objPtr = Tcl_GetObjResult(interp); Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1); @@ -326,21 +460,24 @@ Tcl_WrongNumArgs(interp, objc, objv, message) */ if (objv[i]->typePtr == &tclIndexType) { - tablePtr = ((char **) objv[i]->internalRep.twoPtrValue.ptr1); - Tcl_AppendStringsToObj(objPtr, - tablePtr[(int) objv[i]->internalRep.twoPtrValue.ptr2], - (char *) NULL); + indexRep = (IndexRep *) objv[i]->internalRep.otherValuePtr; + Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), (char *) NULL); } else { Tcl_AppendStringsToObj(objPtr, Tcl_GetString(objv[i]), (char *) NULL); } - if (i < (objc - 1)) { + + /* + * Append a space character (" ") if there is more text to follow + * (either another element from objv, or the message string). + */ + if ((i < (objc - 1)) || message) { Tcl_AppendStringsToObj(objPtr, " ", (char *) NULL); } } + if (message) { - Tcl_AppendStringsToObj(objPtr, " ", message, (char *) NULL); + Tcl_AppendStringsToObj(objPtr, message, (char *) NULL); } Tcl_AppendStringsToObj(objPtr, "\"", (char *) NULL); } - diff --git a/tcl/generic/tclInitScript.h b/tcl/generic/tclInitScript.h index 749492361b9..dcb94c6e583 100644 --- a/tcl/generic/tclInitScript.h +++ b/tcl/generic/tclInitScript.h @@ -49,8 +49,10 @@ static char initScript[] = "if {[info proc tclInit]==\"\"} {\n\ if {[info exists env(TCL_LIBRARY)]} {\n\ lappend dirs $env(TCL_LIBRARY)\n\ }\n\ - lappend dirs $tclDefaultLibrary\n\ - unset tclDefaultLibrary\n\ + catch {\n\ + lappend dirs $tclDefaultLibrary\n\ + unset tclDefaultLibrary\n\ + }\n\ set dirs [concat $dirs $tcl_libPath]\n\ }\n\ foreach i $dirs {\n\ @@ -62,7 +64,6 @@ static char initScript[] = "if {[info proc tclInit]==\"\"} {\n\ } else {\n\ append errors \"$tclfile: $msg\n$errorInfo\n\"\n\ }\n\ - set tcl_pkgPath [lreplace $tcl_pkgPath end end]\n\ }\n\ }\n\ set msg \"Can't find a usable init.tcl in the following directories: \n\"\n\ diff --git a/tcl/generic/tclInt.decls b/tcl/generic/tclInt.decls index 71903e72fe9..e5eb2074d76 100644 --- a/tcl/generic/tclInt.decls +++ b/tcl/generic/tclInt.decls @@ -7,6 +7,8 @@ # files # # Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. +# # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # @@ -23,9 +25,10 @@ interface tclInt # Use at your own risk. Note that the position of functions should not # be changed between versions to avoid gratuitous incompatibilities. -declare 0 generic { - int TclAccess(CONST char *path, int mode) -} +# Replaced by Tcl_FSAccess in 8.4: +#declare 0 generic { +# int TclAccess(CONST char *path, int mode) +#} declare 1 generic { int TclAccessDeleteProc(TclAccessProc_ *proc) } @@ -40,7 +43,7 @@ declare 3 generic { # int TclChdir(Tcl_Interp *interp, char *dirName) # } declare 5 {unix win} { - int TclCleanupChildren(Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, \ + int TclCleanupChildren(Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan) } declare 6 generic { @@ -50,19 +53,20 @@ declare 7 generic { int TclCopyAndCollapse(int count, CONST char *src, char *dst) } declare 8 generic { - int TclCopyChannel(Tcl_Interp *interp, Tcl_Channel inChan, \ + int TclCopyChannel(Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr) } # TclCreatePipeline unofficially exported for use by BLT. declare 9 {unix win} { - int TclCreatePipeline(Tcl_Interp *interp, int argc, char **argv, \ - Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, \ + int TclCreatePipeline(Tcl_Interp *interp, int argc, CONST char **argv, + Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, TclFile *errFilePtr) } declare 10 generic { - int TclCreateProc(Tcl_Interp *interp, Namespace *nsPtr, char *procName, \ + int TclCreateProc(Tcl_Interp *interp, Namespace *nsPtr, + CONST char *procName, Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, Proc **procPtrPtr) } declare 11 generic { @@ -72,8 +76,8 @@ declare 12 generic { void TclDeleteVars(Interp *iPtr, Tcl_HashTable *tablePtr) } declare 13 generic { - int TclDoGlob(Tcl_Interp *interp, char *separators, \ - Tcl_DString *headPtr, char *tail, GlobTypeData *types) + int TclDoGlob(Tcl_Interp *interp, char *separators, + Tcl_DString *headPtr, char *tail, Tcl_GlobTypeData *types) } declare 14 generic { void TclDumpMemoryInfo(FILE *outFile) @@ -85,28 +89,29 @@ declare 14 generic { declare 16 generic { void TclExprFloatError(Tcl_Interp *interp, double value) } -declare 17 generic { - int TclFileAttrsCmd(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) -} -declare 18 generic { - int TclFileCopyCmd(Tcl_Interp *interp, int argc, char **argv) -} -declare 19 generic { - int TclFileDeleteCmd(Tcl_Interp *interp, int argc, char **argv) -} -declare 20 generic { - int TclFileMakeDirsCmd(Tcl_Interp *interp, int argc, char **argv) -} -declare 21 generic { - int TclFileRenameCmd(Tcl_Interp *interp, int argc, char **argv) -} +# Removed in 8.4 +#declare 17 generic { +# int TclFileAttrsCmd(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) +#} +#declare 18 generic { +# int TclFileCopyCmd(Tcl_Interp *interp, int argc, char **argv) +#} +#declare 19 generic { +# int TclFileDeleteCmd(Tcl_Interp *interp, int argc, char **argv) +#} +#declare 20 generic { +# int TclFileMakeDirsCmd(Tcl_Interp *interp, int argc, char **argv) +#} +#declare 21 generic { +# int TclFileRenameCmd(Tcl_Interp *interp, int argc, char **argv) +#} declare 22 generic { - int TclFindElement(Tcl_Interp *interp, CONST char *listStr, \ - int listLength, CONST char **elementPtr, CONST char **nextPtr, \ + int TclFindElement(Tcl_Interp *interp, CONST char *listStr, + int listLength, CONST char **elementPtr, CONST char **nextPtr, int *sizePtr, int *bracePtr) } declare 23 generic { - Proc * TclFindProc(Interp *iPtr, char *procName) + Proc * TclFindProc(Interp *iPtr, CONST char *procName) } declare 24 generic { int TclFormatInt(char *buffer, long n) @@ -119,16 +124,17 @@ declare 25 generic { # char * TclGetCwd(Tcl_Interp *interp) # } declare 27 generic { - int TclGetDate(char *p, unsigned long now, long zone, \ + int TclGetDate(char *p, unsigned long now, long zone, unsigned long *timePtr) } declare 28 generic { Tcl_Channel TclpGetDefaultStdChannel(int type) } -declare 29 generic { - Tcl_Obj * TclGetElementOfIndexedArray(Tcl_Interp *interp, \ - int localIndex, Tcl_Obj *elemPtr, int leaveErrorMsg) -} +# Removed in 8.4b2: +#declare 29 generic { +# Tcl_Obj * TclGetElementOfIndexedArray(Tcl_Interp *interp, +# int localIndex, Tcl_Obj *elemPtr, int flags) +#} # Replaced by char * TclGetEnv(CONST char *name, Tcl_DString *valuePtr) in 8.1: # declare 30 generic { # char * TclGetEnv(CONST char *name) @@ -137,36 +143,38 @@ declare 31 generic { char * TclGetExtension(char *name) } declare 32 generic { - int TclGetFrame(Tcl_Interp *interp, char *str, CallFrame **framePtrPtr) + int TclGetFrame(Tcl_Interp *interp, CONST char *str, + CallFrame **framePtrPtr) } declare 33 generic { TclCmdProcType TclGetInterpProc(void) } declare 34 generic { - int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, \ + int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, int endValue, int *indexPtr) } -declare 35 generic { - Tcl_Obj * TclGetIndexedScalar(Tcl_Interp *interp, int localIndex, \ - int leaveErrorMsg) -} +# Removed in 8.4b2: +#declare 35 generic { +# Tcl_Obj * TclGetIndexedScalar(Tcl_Interp *interp, int localIndex, +# int flags) +#} declare 36 generic { - int TclGetLong(Tcl_Interp *interp, char *str, long *longPtr) + int TclGetLong(Tcl_Interp *interp, CONST char *str, long *longPtr) } declare 37 generic { int TclGetLoadedPackages(Tcl_Interp *interp, char *targetName) } declare 38 generic { - int TclGetNamespaceForQualName(Tcl_Interp *interp, char *qualName, \ - Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr, \ - Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr, \ - char **simpleNamePtr) + int TclGetNamespaceForQualName(Tcl_Interp *interp, CONST char *qualName, + Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr, + Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr, + CONST char **simpleNamePtr) } declare 39 generic { TclObjCmdProcType TclGetObjInterpProc(void) } declare 40 generic { - int TclGetOpenMode(Tcl_Interp *interp, char *str, int *seekFlagPtr) + int TclGetOpenMode(Tcl_Interp *interp, CONST char *str, int *seekFlagPtr) } declare 41 generic { Tcl_Command TclGetOriginalCommand(Tcl_Command command) @@ -175,10 +183,10 @@ declare 42 generic { char * TclpGetUserHome(CONST char *name, Tcl_DString *bufferPtr) } declare 43 generic { - int TclGlobalInvoke(Tcl_Interp *interp, int argc, char **argv, int flags) + int TclGlobalInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv, int flags) } declare 44 generic { - int TclGuessPackageName(char *fileName, Tcl_DString *bufPtr) + int TclGuessPackageName(CONST char *fileName, Tcl_DString *bufPtr) } declare 45 generic { int TclHideUnsafeCommands(Tcl_Interp *interp) @@ -186,34 +194,36 @@ declare 45 generic { declare 46 generic { int TclInExit(void) } -declare 47 generic { - Tcl_Obj * TclIncrElementOfIndexedArray(Tcl_Interp *interp, \ - int localIndex, Tcl_Obj *elemPtr, long incrAmount) -} -declare 48 generic { - Tcl_Obj * TclIncrIndexedScalar(Tcl_Interp *interp, int localIndex, \ - long incrAmount) -} +# Removed in 8.4b2: +#declare 47 generic { +# Tcl_Obj * TclIncrElementOfIndexedArray(Tcl_Interp *interp, +# int localIndex, Tcl_Obj *elemPtr, long incrAmount) +#} +# Removed in 8.4b2: +#declare 48 generic { +# Tcl_Obj * TclIncrIndexedScalar(Tcl_Interp *interp, int localIndex, +# long incrAmount) +#} declare 49 generic { - Tcl_Obj * TclIncrVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, \ + Tcl_Obj * TclIncrVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, long incrAmount, int part1NotParsed) } declare 50 generic { - void TclInitCompiledLocals(Tcl_Interp *interp, CallFrame *framePtr, \ + void TclInitCompiledLocals(Tcl_Interp *interp, CallFrame *framePtr, Namespace *nsPtr) } declare 51 generic { int TclInterpInit(Tcl_Interp *interp) } declare 52 generic { - int TclInvoke(Tcl_Interp *interp, int argc, char **argv, int flags) + int TclInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv, int flags) } declare 53 generic { - int TclInvokeObjectCommand(ClientData clientData, Tcl_Interp *interp, \ - int argc, char **argv) + int TclInvokeObjectCommand(ClientData clientData, Tcl_Interp *interp, + int argc, CONST84 char **argv) } declare 54 generic { - int TclInvokeStringCommand(ClientData clientData, Tcl_Interp *interp, \ + int TclInvokeStringCommand(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) } declare 55 generic { @@ -221,8 +231,8 @@ declare 55 generic { } # Replaced with TclpLoadFile in 8.1: # declare 56 generic { -# int TclLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, \ -# char *sym2, Tcl_PackageInitProc **proc1Ptr, \ +# 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: @@ -230,16 +240,17 @@ declare 55 generic { # int TclLooksLikeInt(char *p) # } declare 58 generic { - Var * TclLookupVar(Tcl_Interp *interp, char *part1, char *part2, \ - int flags, char *msg, int createPart1, int createPart2, \ + Var * TclLookupVar(Tcl_Interp *interp, CONST char *part1, CONST char *part2, + int flags, CONST char *msg, int createPart1, int createPart2, Var **arrayPtrPtr) } -declare 59 generic { - int TclpMatchFiles(Tcl_Interp *interp, char *separators, \ - Tcl_DString *dirPtr, char *pattern, char *tail) -} +# Replaced by Tcl_FSMatchInDirectory in 8.4 +#declare 59 generic { +# int TclpMatchFiles(Tcl_Interp *interp, char *separators, +# Tcl_DString *dirPtr, char *pattern, char *tail) +#} declare 60 generic { - int TclNeedSpace(char *start, char *end) + int TclNeedSpace(CONST char *start, CONST char *end) } declare 61 generic { Tcl_Obj * TclNewProcBodyObj(Proc *procPtr) @@ -248,15 +259,15 @@ declare 62 generic { int TclObjCommandComplete(Tcl_Obj *cmdPtr) } declare 63 generic { - int TclObjInterpProc(ClientData clientData, Tcl_Interp *interp, \ + int TclObjInterpProc(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) } declare 64 generic { - int TclObjInvoke(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], \ + int TclObjInvoke(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], int flags) } declare 65 generic { - int TclObjInvokeGlobal(Tcl_Interp *interp, int objc, \ + int TclObjInvokeGlobal(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], int flags) } declare 66 generic { @@ -265,25 +276,26 @@ declare 66 generic { declare 67 generic { int TclOpenFileChannelInsertProc(TclOpenFileChannelProc_ *proc) } -declare 68 generic { - int TclpAccess(CONST char *path, int mode) -} +# Replaced by Tcl_FSAccess in 8.4: +#declare 68 generic { +# int TclpAccess(CONST char *path, int mode) +#} declare 69 generic { char * TclpAlloc(unsigned int size) } -declare 70 generic { - int TclpCopyFile(CONST char *source, CONST char *dest) -} -declare 71 generic { - int TclpCopyDirectory(CONST char *source, CONST char *dest, \ - Tcl_DString *errorPtr) -} -declare 72 generic { - int TclpCreateDirectory(CONST char *path) -} -declare 73 generic { - int TclpDeleteFile(CONST char *path) -} +#declare 70 generic { +# int TclpCopyFile(CONST char *source, CONST char *dest) +#} +#declare 71 generic { +# int TclpCopyDirectory(CONST char *source, CONST char *dest, +# Tcl_DString *errorPtr) +#} +#declare 72 generic { +# int TclpCreateDirectory(CONST char *path) +#} +#declare 73 generic { +# int TclpDeleteFile(CONST char *path) +#} declare 74 generic { void TclpFree(char *ptr) } @@ -293,51 +305,56 @@ declare 75 generic { declare 76 generic { unsigned long TclpGetSeconds(void) } + +# deprecated declare 77 generic { void TclpGetTime(Tcl_Time *time) } + declare 78 generic { int TclpGetTimeZone(unsigned long time) } -declare 79 generic { - int TclpListVolumes(Tcl_Interp *interp) -} -declare 80 generic { - Tcl_Channel TclpOpenFileChannel(Tcl_Interp *interp, char *fileName, \ - char *modeString, int permissions) -} +# Replaced by Tcl_FSListVolumes in 8.4: +#declare 79 generic { +# int TclpListVolumes(Tcl_Interp *interp) +#} +# Replaced by Tcl_FSOpenFileChannel in 8.4: +#declare 80 generic { +# Tcl_Channel TclpOpenFileChannel(Tcl_Interp *interp, char *fileName, +# char *modeString, int permissions) +#} declare 81 generic { char * TclpRealloc(char *ptr, unsigned int size) } -declare 82 generic { - int TclpRemoveDirectory(CONST char *path, int recursive, \ - Tcl_DString *errorPtr) -} -declare 83 generic { - int TclpRenameFile(CONST char *source, CONST char *dest) -} +#declare 82 generic { +# int TclpRemoveDirectory(CONST char *path, int recursive, +# Tcl_DString *errorPtr) +#} +#declare 83 generic { +# int TclpRenameFile(CONST char *source, CONST char *dest) +#} # Removed in 8.1: # declare 84 generic { -# int TclParseBraces(Tcl_Interp *interp, char *str, char **termPtr, \ +# int TclParseBraces(Tcl_Interp *interp, char *str, char **termPtr, # ParseValue *pvPtr) # } # declare 85 generic { -# int TclParseNestedCmd(Tcl_Interp *interp, char *str, int flags, \ +# int TclParseNestedCmd(Tcl_Interp *interp, char *str, int flags, # char **termPtr, ParseValue *pvPtr) # } # declare 86 generic { -# int TclParseQuotes(Tcl_Interp *interp, char *str, int termChar, \ +# int TclParseQuotes(Tcl_Interp *interp, char *str, int termChar, # int flags, char **termPtr, ParseValue *pvPtr) # } # declare 87 generic { # void TclPlatformInit(Tcl_Interp *interp) # } declare 88 generic { - char * TclPrecTraceProc(ClientData clientData, Tcl_Interp *interp, \ - char *name1, char *name2, int flags) + char * TclPrecTraceProc(ClientData clientData, Tcl_Interp *interp, + CONST char *name1, CONST char *name2, int flags) } declare 89 generic { - int TclPreventAliasLoop(Tcl_Interp *interp, Tcl_Interp *cmdInterp, \ + int TclPreventAliasLoop(Tcl_Interp *interp, Tcl_Interp *cmdInterp, Tcl_Command cmd) } # Removed in 8.1 (only available if compiled with TCL_COMPILE_DEBUG): @@ -348,20 +365,21 @@ declare 91 generic { void TclProcCleanupProc(Proc *procPtr) } declare 92 generic { - int TclProcCompileProc(Tcl_Interp *interp, Proc *procPtr, \ - Tcl_Obj *bodyPtr, Namespace *nsPtr, CONST char *description, \ + int TclProcCompileProc(Tcl_Interp *interp, Proc *procPtr, + Tcl_Obj *bodyPtr, Namespace *nsPtr, CONST char *description, CONST char *procName) } declare 93 generic { void TclProcDeleteProc(ClientData clientData) } declare 94 generic { - int TclProcInterpProc(ClientData clientData, Tcl_Interp *interp, \ - int argc, char **argv) -} -declare 95 generic { - int TclpStat(CONST char *path, struct stat *buf) + int TclProcInterpProc(ClientData clientData, Tcl_Interp *interp, + int argc, CONST84 char **argv) } +# Replaced by Tcl_FSStat in 8.4: +#declare 95 generic { +# int TclpStat(CONST char *path, Tcl_StatBuf *buf) +#} declare 96 generic { int TclRenameCommand(Tcl_Interp *interp, char *oldName, char *newName) } @@ -371,14 +389,16 @@ declare 97 generic { declare 98 generic { int TclServiceIdle(void) } -declare 99 generic { - Tcl_Obj * TclSetElementOfIndexedArray(Tcl_Interp *interp, \ - int localIndex, Tcl_Obj *elemPtr, Tcl_Obj *objPtr, int leaveErrorMsg) -} -declare 100 generic { - Tcl_Obj * TclSetIndexedScalar(Tcl_Interp *interp, int localIndex, \ - Tcl_Obj *objPtr, int leaveErrorMsg) -} +# Removed in 8.4b2: +#declare 99 generic { +# Tcl_Obj * TclSetElementOfIndexedArray(Tcl_Interp *interp, int localIndex, +# Tcl_Obj *elemPtr, Tcl_Obj *objPtr, int flags) +#} +# Removed in 8.4b2: +#declare 100 generic { +# Tcl_Obj * TclSetIndexedScalar(Tcl_Interp *interp, int localIndex, +# Tcl_Obj *objPtr, int flags) +#} declare 101 {unix win} { char * TclSetPreInitScript(char *string) } @@ -386,15 +406,16 @@ declare 102 generic { void TclSetupEnv(Tcl_Interp *interp) } declare 103 generic { - int TclSockGetPort(Tcl_Interp *interp, char *str, char *proto, \ + int TclSockGetPort(Tcl_Interp *interp, char *str, char *proto, int *portPtr) } declare 104 {unix win} { int TclSockMinimumBuffers(int sock, int size) } -declare 105 generic { - int TclStat(CONST char *path, struct stat *buf) -} +# Replaced by Tcl_FSStat in 8.4: +#declare 105 generic { +# int TclStat(CONST char *path, Tcl_StatBuf *buf) +#} declare 106 generic { int TclStatDeleteProc(TclStatProc_ *proc) } @@ -416,54 +437,54 @@ declare 109 generic { # defined here instead of in tcl.decls since they are not stable yet. declare 111 generic { - void Tcl_AddInterpResolvers(Tcl_Interp *interp, char *name, \ - Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, \ + void Tcl_AddInterpResolvers(Tcl_Interp *interp, CONST char *name, + Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc) } declare 112 generic { - int Tcl_AppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, \ + int Tcl_AppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr) } declare 113 generic { - Tcl_Namespace * Tcl_CreateNamespace(Tcl_Interp *interp, char *name, \ + Tcl_Namespace * Tcl_CreateNamespace(Tcl_Interp *interp, CONST char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc) } declare 114 generic { void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr) } declare 115 generic { - int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr, char *pattern, \ - int resetListFirst) + int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + CONST char *pattern, int resetListFirst) } declare 116 generic { - Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, char *name, \ + Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, CONST char *name, Tcl_Namespace *contextNsPtr, int flags) } declare 117 generic { - Tcl_Namespace * Tcl_FindNamespace(Tcl_Interp *interp, char *name, \ + Tcl_Namespace * Tcl_FindNamespace(Tcl_Interp *interp, CONST char *name, Tcl_Namespace *contextNsPtr, int flags) } declare 118 generic { - int Tcl_GetInterpResolvers(Tcl_Interp *interp, char *name, \ + int Tcl_GetInterpResolvers(Tcl_Interp *interp, CONST char *name, Tcl_ResolverInfo *resInfo) } declare 119 generic { - int Tcl_GetNamespaceResolvers(Tcl_Namespace *namespacePtr, \ + int Tcl_GetNamespaceResolvers(Tcl_Namespace *namespacePtr, Tcl_ResolverInfo *resInfo) } declare 120 generic { - Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, char *name, \ + Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, CONST char *name, Tcl_Namespace *contextNsPtr, int flags) } declare 121 generic { - int Tcl_ForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, \ - char *pattern) + int Tcl_ForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + CONST char *pattern) } declare 122 generic { Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr) } declare 123 generic { - void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command, \ + void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr) } declare 124 generic { @@ -473,26 +494,26 @@ declare 125 generic { Tcl_Namespace * Tcl_GetGlobalNamespace(Tcl_Interp *interp) } declare 126 generic { - void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable, \ + void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr) } declare 127 generic { - int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr, \ - char *pattern, int allowOverwrite) + int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + CONST char *pattern, int allowOverwrite) } declare 128 generic { void Tcl_PopCallFrame(Tcl_Interp* interp) } declare 129 generic { - int Tcl_PushCallFrame(Tcl_Interp* interp, Tcl_CallFrame *framePtr, \ + int Tcl_PushCallFrame(Tcl_Interp* interp, Tcl_CallFrame *framePtr, Tcl_Namespace *nsPtr, int isProcCallFrame) } declare 130 generic { - int Tcl_RemoveInterpResolvers(Tcl_Interp *interp, char *name) + int Tcl_RemoveInterpResolvers(Tcl_Interp *interp, CONST char *name) } declare 131 generic { - void Tcl_SetNamespaceResolvers(Tcl_Namespace *namespacePtr, \ - Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, \ + void Tcl_SetNamespaceResolvers(Tcl_Namespace *namespacePtr, + Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc) } declare 132 generic { @@ -502,8 +523,8 @@ declare 133 generic { struct tm * TclpGetDate(TclpTime_t time, int useGMT) } declare 134 generic { - size_t TclpStrftime(char *s, size_t maxsize, CONST char *format, \ - CONST struct tm *t) + size_t TclpStrftime(char *s, size_t maxsize, CONST char *format, + CONST struct tm *t, int useGMT) } declare 135 generic { int TclpCheckStackSpace(void) @@ -511,33 +532,34 @@ declare 135 generic { # Added in 8.1: -declare 137 generic { - int TclpChdir(CONST char *dirName) -} +#declare 137 generic { +# int TclpChdir(CONST char *dirName) +#} declare 138 generic { - char * TclGetEnv(CONST char *name, Tcl_DString *valuePtr) -} -declare 139 generic { - int TclpLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, \ - char *sym2, Tcl_PackageInitProc **proc1Ptr, \ - Tcl_PackageInitProc **proc2Ptr, ClientData *clientDataPtr) + CONST84_RETURN char * TclGetEnv(CONST char *name, Tcl_DString *valuePtr) } +#declare 139 generic { +# int TclpLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, +# char *sym2, Tcl_PackageInitProc **proc1Ptr, +# Tcl_PackageInitProc **proc2Ptr, ClientData *clientDataPtr) +#} declare 140 generic { - int TclLooksLikeInt(char *bytes, int length) + int TclLooksLikeInt(CONST char *bytes, int length) } +# This is used by TclX, but should otherwise be considered private declare 141 generic { - char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr) + CONST84_RETURN char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr) } declare 142 generic { - int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr, \ + int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, ClientData clientData) } declare 143 generic { - int TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr, \ + int TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr) } declare 144 generic { - void TclHideLiteral(Tcl_Interp *interp, struct CompileEnv *envPtr, \ + void TclHideLiteral(Tcl_Interp *interp, struct CompileEnv *envPtr, int index) } declare 145 generic { @@ -566,7 +588,7 @@ declare 150 generic { int TclRegAbout(Tcl_Interp *interp, Tcl_RegExp re) } declare 151 generic { - void TclRegExpRangeUniChar(Tcl_RegExp re, int index, int *startPtr, \ + void TclRegExpRangeUniChar(Tcl_RegExp re, int index, int *startPtr, int *endPtr) } @@ -577,43 +599,93 @@ declare 153 generic { Tcl_Obj *TclGetLibraryPath(void) } -# moved to tclTest.c in 8.3.2/8.4a2 +# moved to tclTest.c (static) in 8.3.2/8.4a2 #declare 154 generic { # int TclTestChannelCmd(ClientData clientData, # Tcl_Interp *interp, int argc, char **argv) #} #declare 155 generic { -# int TclTestChannelEventCmd(ClientData clientData, \ +# int TclTestChannelEventCmd(ClientData clientData, # Tcl_Interp *interp, int argc, char **argv) #} declare 156 generic { - void TclRegError (Tcl_Interp *interp, char *msg, \ + void TclRegError (Tcl_Interp *interp, CONST char *msg, int status) } declare 157 generic { - Var * TclVarTraceExists (Tcl_Interp *interp, char *varName) + Var * TclVarTraceExists (Tcl_Interp *interp, CONST char *varName) } declare 158 generic { - void TclSetStartupScriptFileName(char *filename) + void TclSetStartupScriptFileName(CONST char *filename) } declare 159 generic { - char *TclGetStartupScriptFileName(void) -} -declare 160 generic { - int TclpMatchFilesTypes(Tcl_Interp *interp, char *separators, \ - Tcl_DString *dirPtr, char *pattern, char *tail, GlobTypeData *types) + CONST84_RETURN char *TclGetStartupScriptFileName(void) } +#declare 160 generic { +# int TclpMatchFilesTypes(Tcl_Interp *interp, char *separators, +# Tcl_DString *dirPtr, char *pattern, char *tail, GlobTypeData *types) +#} # new in 8.3.2/8.4a2 declare 161 generic { - int TclChannelTransform(Tcl_Interp *interp, Tcl_Channel chan, \ + int TclChannelTransform(Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr) } declare 162 generic { void TclChannelEventScriptInvoker(ClientData clientData, int flags) } +# ALERT: The result of 'TclGetInstructionTable' is actually an +# "InstructionDesc*" but we do not want to describe this structure in +# "tclInt.h". It is described in "tclCompile.h". Use a cast to the +# correct type when calling this procedure. + +declare 163 generic { + void * TclGetInstructionTable (void) +} + +# ALERT: The argument of 'TclExpandCodeArray' is actually a +# "CompileEnv*" but we do not want to describe this structure in +# "tclInt.h". It is described in "tclCompile.h". + +declare 164 generic { + void TclExpandCodeArray (void *envPtr) +} + +# These functions are vfs aware, but are generally only useful internally. +declare 165 generic { + void TclpSetInitialEncodings(void) +} + +# New function due to TIP #33 +declare 166 generic { + int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr, + int index, Tcl_Obj *valuePtr) +} + +# VFS-aware versions of Tcl*StartupScriptFileName (158 and 159 above) +declare 167 generic { + void TclSetStartupScriptPath(Tcl_Obj *pathPtr) +} +declare 168 generic { + Tcl_Obj *TclGetStartupScriptPath(void) +} +# variant of Tcl_UtfNCmp that takes n as bytes, not chars +declare 169 generic { + int TclpUtfNcmp2(CONST char *s1, CONST char *s2, unsigned long n) +} +declare 170 generic { + int TclCheckInterpTraces (Tcl_Interp *interp, CONST char *command, int numChars, \ + Command *cmdPtr, int result, int traceFlags, int objc, \ + Tcl_Obj *CONST objv[]) +} +declare 171 generic { + int TclCheckExecutionTraces (Tcl_Interp *interp, CONST char *command, int numChars, \ + Command *cmdPtr, int result, int traceFlags, int objc, \ + Tcl_Obj *CONST objv[]) +} + ############################################################################## # Define the platform specific internal Tcl interface. These functions are @@ -646,11 +718,11 @@ declare 5 mac { int FSpSetDefaultDir(FSSpecPtr theSpec) } declare 6 mac { - OSErr FSpFindFolder(short vRefNum, OSType folderType, \ + OSErr FSpFindFolder(short vRefNum, OSType folderType, Boolean createFolder, FSSpec *spec) } declare 7 mac { - void GetGlobalMouse(Point *mouse) + void GetGlobalMouseTcl(Point *mouse) } # The following routines are utility functions in Tcl. They are exported @@ -658,15 +730,15 @@ declare 7 mac { # however. The first set are from the MoreFiles package. declare 8 mac { - pascal OSErr FSpGetDirectoryID(CONST FSSpec *spec, long *theDirID, \ + pascal OSErr FSpGetDirectoryIDTcl(CONST FSSpec *spec, long *theDirID, Boolean *isDirectory) } declare 9 mac { - pascal short FSpOpenResFileCompat(CONST FSSpec *spec, \ + pascal short FSpOpenResFileCompatTcl(CONST FSSpec *spec, SignedByte permission) } declare 10 mac { - pascal void FSpCreateResFileCompat(CONST FSSpec *spec, OSType creator, \ + pascal void FSpCreateResFileCompatTcl(CONST FSSpec *spec, OSType creator, OSType fileType, ScriptCode scriptTag) } @@ -677,7 +749,7 @@ declare 11 mac { int FSpLocationFromPath(int length, CONST char *path, FSSpecPtr theSpec) } declare 12 mac { - OSErr FSpPathFromLocation(FSSpecPtr theSpec, int *length, \ + OSErr FSpPathFromLocation(FSSpecPtr theSpec, int *length, Handle *fullPath) } @@ -705,7 +777,7 @@ declare 19 mac { int TclMacTimerExpired(void *timerToken) } declare 20 mac { - int TclMacRegisterResourceFork(short fileRef, Tcl_Obj *tokenPtr, \ + int TclMacRegisterResourceFork(short fileRef, Tcl_Obj *tokenPtr, int insert) } declare 21 mac { @@ -721,8 +793,15 @@ declare 23 mac { # declare 24 mac { # int TclMacReadlink(char *path, char *buf, int size) # } +declare 24 mac { + char * TclpGetTZName(int isdst) +} declare 25 mac { - int TclMacChmod(char *path, int mode) + int TclMacChmod(CONST char *path, int mode) +} +# version of FSpLocationFromPath that doesn't resolve the last path component +declare 26 mac { + int FSpLLocationFromPath(int length, CONST char *path, FSSpecPtr theSpec) } ############################ @@ -735,11 +814,11 @@ declare 1 win { void TclWinConvertWSAError(DWORD errCode) } declare 2 win { - struct servent * TclWinGetServByName(CONST char *nm, \ + struct servent * TclWinGetServByName(CONST char *nm, CONST char *proto) } declare 3 win { - int TclWinGetSockOpt(SOCKET s, int level, int optname, \ + int TclWinGetSockOpt(SOCKET s, int level, int optname, char FAR * optval, int FAR *optlen) } declare 4 win { @@ -753,7 +832,7 @@ declare 6 win { u_short TclWinNToHS(u_short ns) } declare 7 win { - int TclWinSetSockOpt(SOCKET s, int level, int optname, \ + int TclWinSetSockOpt(SOCKET s, int level, int optname, CONST char FAR * optval, int optlen) } declare 8 win { @@ -776,15 +855,15 @@ declare 12 win { int TclpCloseFile(TclFile file) } declare 13 win { - Tcl_Channel TclpCreateCommandChannel(TclFile readFile, \ + Tcl_Channel TclpCreateCommandChannel(TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr) } declare 14 win { int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe) } declare 15 win { - int TclpCreateProcess(Tcl_Interp *interp, int argc, char **argv, \ - TclFile inputFile, TclFile outputFile, TclFile errorFile, \ + int TclpCreateProcess(Tcl_Interp *interp, int argc, CONST char **argv, + TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr) } # Signature changed in 8.1: @@ -803,9 +882,11 @@ declare 19 win { declare 20 win { void TclWinAddProcess(HANDLE hProcess, DWORD id) } -declare 21 win { - void TclpAsyncMark(Tcl_AsyncHandler async) -} + +# removed permanently for 8.4 +#declare 21 win { +# void TclpAsyncMark(Tcl_AsyncHandler async) +#} # Added in 8.1: declare 22 win { @@ -824,6 +905,12 @@ declare 26 win { void TclWinSetInterfaces(int wide) } +# Added in Tcl 8.3.3 / 8.4 + +declare 27 win { + void TclWinFlushDirtyChannels (void) +} + ######################### # Unix specific internals @@ -836,21 +923,20 @@ declare 1 unix { int TclpCloseFile(TclFile file) } declare 2 unix { - Tcl_Channel TclpCreateCommandChannel(TclFile readFile, \ + Tcl_Channel TclpCreateCommandChannel(TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr) } declare 3 unix { int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe) } declare 4 unix { - int TclpCreateProcess(Tcl_Interp *interp, int argc, char **argv, \ - TclFile inputFile, TclFile outputFile, TclFile errorFile, \ + int TclpCreateProcess(Tcl_Interp *interp, int argc, CONST char **argv, + TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr) } # Signature changed in 8.1: # declare 5 unix { -# TclFile TclpCreateTempFile(char *contents, -# Tcl_DString *namePtr) +# TclFile TclpCreateTempFile(char *contents, Tcl_DString *namePtr) # } declare 6 unix { TclFile TclpMakeFile(Tcl_Channel channel, int direction) @@ -868,3 +954,21 @@ declare 9 unix { TclFile TclpCreateTempFile(CONST char *contents) } +# Added in 8.4: + +declare 10 unix { + Tcl_DirEntry * TclpReaddir(DIR * dir) +} + +declare 11 unix { + struct tm * TclpLocaltime(time_t * clock) +} + +declare 12 unix { + struct tm * TclpGmtime(time_t * clock) +} + +declare 13 unix { + char * TclpInetNtoa(struct in_addr addr) +} + diff --git a/tcl/generic/tclInt.h b/tcl/generic/tclInt.h index 641e9d665a9..7de19273884 100644 --- a/tcl/generic/tclInt.h +++ b/tcl/generic/tclInt.h @@ -7,6 +7,7 @@ * Copyright (c) 1993-1997 Lucent Technologies. * Copyright (c) 1994-1998 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. + * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -27,12 +28,12 @@ * needed by stdlib.h in some configurations. */ -#include <stdio.h> - #ifndef _TCL #include "tcl.h" #endif +#include <stdio.h> + #include <ctype.h> #ifdef NO_LIMITS_H # include "../compat/limits.h" @@ -90,15 +91,15 @@ typedef struct Tcl_ResolvedVarInfo { typedef int (Tcl_ResolveCompiledVarProc) _ANSI_ARGS_(( - Tcl_Interp* interp, char* name, int length, + Tcl_Interp* interp, CONST84 char* name, int length, Tcl_Namespace *context, Tcl_ResolvedVarInfo **rPtr)); typedef int (Tcl_ResolveVarProc) _ANSI_ARGS_(( - Tcl_Interp* interp, char* name, Tcl_Namespace *context, + Tcl_Interp* interp, CONST84 char* name, Tcl_Namespace *context, int flags, Tcl_Var *rPtr)); typedef int (Tcl_ResolveCmdProc) _ANSI_ARGS_((Tcl_Interp* interp, - char* name, Tcl_Namespace *context, int flags, + CONST84 char* name, Tcl_Namespace *context, int flags, Tcl_Command *rPtr)); typedef struct Tcl_ResolverInfo { @@ -184,11 +185,13 @@ typedef struct Namespace { * namespace has already cached a Command * * pointer; this causes all its cached * Command* pointers to be invalidated. */ - int resolverEpoch; /* Incremented whenever the name resolution - * rules change for this namespace; this - * invalidates all byte codes compiled in - * the namespace, causing the code to be - * recompiled under the new rules. */ + int 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 invalidates all byte codes compiled + * in the namespace, causing the code to be + * recompiled under the new rules.*/ Tcl_ResolveCmdProc *cmdResProc; /* If non-null, this procedure overrides * the usual command resolution mechanism @@ -270,6 +273,43 @@ typedef struct VarTrace { } VarTrace; /* + * The following structure defines a command trace, which is used to + * invoke a specific C procedure whenever certain operations are performed + * on a command. + */ + +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. */ + 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. */ +} CommandTrace; + +/* + * When a command trace is active (i.e. its associated procedure is + * executing), one of the following structures is linked into a list + * associated with the command's interpreter. The information in + * the structure is needed in order for Tcl to behave reasonably + * if traces are deleted while traces are active. + */ + +typedef struct ActiveCommandTrace { + struct Command *cmdPtr; /* Command that's being traced. */ + struct ActiveCommandTrace *nextPtr; + /* Next in list of all active command + * traces for the interpreter, or NULL + * if no more. */ + CommandTrace *nextTracePtr; /* Next trace to check after current + * trace procedure returns; if this + * trace gets deleted, must update pointer + * to avoid using free'd memory. */ +} ActiveCommandTrace; + +/* * When a variable trace is active (i.e. its associated procedure is * executing), one of the following structures is linked into a list * associated with the variable's interpreter. The information in @@ -614,12 +654,35 @@ typedef struct Proc { typedef struct Trace { int level; /* Only trace commands at nesting level * less than or equal to this. */ - Tcl_CmdTraceProc *proc; /* Procedure to call to trace command. */ + Tcl_CmdObjTraceProc *proc; /* Procedure to call to trace command. */ ClientData 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 */ + Tcl_CmdObjTraceDeleteProc* delProc; + /* Procedure to call when trace is deleted */ } Trace; /* + * When an interpreter trace is active (i.e. its associated procedure + * is executing), one of the following structures is linked into a list + * associated with the interpreter. The information in the structure + * is needed in order for Tcl to behave reasonably if traces are + * deleted while traces are active. + */ + +typedef struct ActiveInterpTrace { + struct ActiveInterpTrace *nextPtr; + /* Next in list of all active command + * traces for the interpreter, or NULL + * if no more. */ + Trace *nextTracePtr; /* Next trace to check after current + * trace procedure returns; if this + * trace gets deleted, must update pointer + * to avoid using free'd memory. */ +} ActiveInterpTrace; + +/* * The structure below defines an entry in the assocData hash table which * is associated with an interpreter. The entry contains a pointer to a * function to call when the interpreter is deleted, and a pointer to @@ -701,11 +764,6 @@ typedef struct CallFrame { typedef VOID **TclHandle; -EXTERN TclHandle TclHandleCreate _ANSI_ARGS_((VOID *ptr)); -EXTERN void TclHandleFree _ANSI_ARGS_((TclHandle handle)); -EXTERN TclHandle TclHandlePreserve _ANSI_ARGS_((TclHandle handle)); -EXTERN void TclHandleRelease _ANSI_ARGS_((TclHandle handle)); - /* *---------------------------------------------------------------- * Data structures related to history. These are used primarily @@ -852,6 +910,8 @@ typedef struct ExecEnv { int stackTop; /* Index of current top of stack; -1 when * the stack is empty. */ int stackEnd; /* Index of last usable item in stack. */ + Tcl_Obj *errorInfo; + Tcl_Obj *errorCode; } ExecEnv; /* @@ -1020,10 +1080,8 @@ typedef struct Command { /* Procedure invoked when deleting command * to, e.g., free all client data. */ ClientData deleteData; /* Arbitrary value passed to deleteProc. */ - int deleted; /* Means that the command is in the process - * of being deleted (its deleteProc is - * currently executing). Other attempts to - * delete the command should be ignored. */ + int flags; /* Miscellaneous bits of information about + * command. See below for definitions. */ ImportRef *importRefPtr; /* List of each imported Command created in * another namespace when this command is * imported. These imported commands @@ -1031,9 +1089,35 @@ typedef struct Command { * command. The list is used to remove all * those imported commands when deleting * this "real" command. */ + CommandTrace *tracePtr; /* First in list of all traces set for this + * command. */ } Command; /* + * Flag bits for commands. + * + * CMD_IS_DELETED - Means that 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 + * 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 execution trace (as opposed to simple + * delete/rename traces) in its tracePtr list. + * TCL_TRACE_RENAME - A rename trace is in progress. Further + * recursive renames will not be traced. + * TCL_TRACE_DELETE - A delete trace is in progress. Further + * recursive deletes will not be traced. + * (these last two flags are defined in tcl.h) + */ +#define CMD_IS_DELETED 0x1 +#define CMD_TRACE_ACTIVE 0x2 +#define CMD_HAS_EXEC_TRACES 0x4 + +/* *---------------------------------------------------------------- * Data structures related to name resolution procedures. *---------------------------------------------------------------- @@ -1134,7 +1218,7 @@ typedef struct Interp { /* * Information related to procedures and variables. See tclProc.c - * and tclvar.c for usage. + * and tclVar.c for usage. */ int numLevels; /* Keeps track of how many nested calls to @@ -1153,7 +1237,7 @@ typedef struct Interp { * unless an "uplevel" command is * executing). NULL means no procedure is * active or "uplevel 0" is executing. */ - ActiveVarTrace *activeTracePtr; + ActiveVarTrace *activeVarTracePtr; /* First in list of active traces for * interp, or NULL if no active traces. */ int returnCode; /* Completion code to return if current @@ -1223,11 +1307,9 @@ typedef struct Interp { * are added/removed by calling * Tcl_AddInterpResolvers and * Tcl_RemoveInterpResolver. */ - char *scriptFile; /* NULL means there is no nested source + Tcl_Obj *scriptFile; /* NULL means there is no nested source * command active; otherwise this points to - * the name of the file being sourced (it's - * not malloc-ed: it points to an argument - * to Tcl_EvalFile. */ + * pathPtr of the file being sourced. */ int flags; /* Various flag bits. See below. */ long randSeed; /* Seed used for rand() function. */ Trace *tracePtr; /* List of traces for this interpreter. */ @@ -1248,6 +1330,16 @@ typedef struct Interp { * accessed directly; see comment above. */ Tcl_ThreadId threadId; /* ID of thread that owns the interpreter */ + ActiveCommandTrace *activeCmdTracePtr; + /* First in list of active command traces for + * interp, or NULL if no active traces. */ + ActiveInterpTrace *activeInterpTracePtr; + /* First in list of active traces for + * interp, or NULL if no active traces. */ + + int tracesForbiddingInline; /* Count of traces (in the list headed by + * tracePtr) that forbid inline bytecode + * compilation */ /* * Statistical information about the bytecode compiler and interpreter's * operation. @@ -1306,6 +1398,9 @@ typedef struct Interp { * interpreter; instead, have Tcl_EvalObj call * Tcl_EvalEx. Used primarily for testing the * new parser. + * INTERP_TRACE_IN_PROGRESS: Non-zero means that an interp trace is currently + * active; so no further trace callbacks should be + * invoked. */ #define DELETED 1 @@ -1317,6 +1412,7 @@ typedef struct Interp { #define RAND_SEED_INITIALIZED 0x40 #define SAFE_INTERP 0x80 #define USE_EVAL_DIRECT 0x100 +#define INTERP_TRACE_IN_PROGRESS 0x200 /* *---------------------------------------------------------------- @@ -1379,7 +1475,7 @@ typedef struct ParseValue { #define TCL_ALIGN(x) (((int)(x) + 7) & ~7) /* - * The following macros are used to specify the runtime platform + * The following enum values are used to specify the runtime platform * setting of the tclPlatform variable. */ @@ -1390,6 +1486,19 @@ typedef enum { } TclPlatformType; /* + * The following enum values are used to indicate the translation + * of a Tcl channel. Declared here so that each platform can define + * TCL_PLATFORM_TRANSLATION to the native translation on that platform + */ + +typedef enum TclEolTranslation { + TCL_TRANSLATE_AUTO, /* Eol == \r, \n and \r\n. */ + TCL_TRANSLATE_CR, /* Eol == \r. */ + TCL_TRANSLATE_LF, /* Eol == \n. */ + TCL_TRANSLATE_CRLF /* Eol == \r\n. */ +} TclEolTranslation; + +/* * Flags for TclInvoke: * * TCL_INVOKE_HIDDEN Invoke a hidden command; if not set, @@ -1434,9 +1543,9 @@ typedef struct List { */ typedef int (TclGetFileAttrProc) _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, CONST char *fileName, Tcl_Obj **attrObjPtrPtr)); + int objIndex, Tcl_Obj *fileName, Tcl_Obj **attrObjPtrPtr)); typedef int (TclSetFileAttrProc) _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, CONST char *fileName, Tcl_Obj *attrObjPtr)); + int objIndex, Tcl_Obj *fileName, Tcl_Obj *attrObjPtr)); typedef struct TclFileAttrProcs { TclGetFileAttrProc *getProc; /* The procedure for getting attrs. */ @@ -1451,63 +1560,42 @@ typedef struct TclFileAttrProcs { typedef struct TclFile_ *TclFile; /* + * Opaque names for platform specific types. + */ + +typedef struct TclpTime_t_ *TclpTime_t; + +/* + * The "globParameters" argument of the function TclGlob is an + * or'ed 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 + +/* *---------------------------------------------------------------- - * Data structures related to hooking 'TclStat(...)' and - * 'TclAccess(...)'. + * Data structures related to obsolete filesystem hooks *---------------------------------------------------------------- */ typedef int (TclStatProc_) _ANSI_ARGS_((CONST char *path, struct stat *buf)); typedef int (TclAccessProc_) _ANSI_ARGS_((CONST char *path, int mode)); typedef Tcl_Channel (TclOpenFileChannelProc_) _ANSI_ARGS_((Tcl_Interp *interp, - char *fileName, char *modeString, + CONST char *fileName, CONST char *modeString, int permissions)); -typedef int (*TclCmdProcType) _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char *argv[])); -typedef int (*TclObjCmdProcType) _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST objv[])); /* - * Opaque names for platform specific types. - */ - -typedef struct TclpTime_t_ *TclpTime_t; - -/* - * The following structure is used to pass glob type data amongst - * the various glob routines and TclpMatchFilesTypes. Currently - * most of the fields are ignored. However they will be used in - * a future release to implement glob's ability to find files - * of particular types/permissions/etc only. - */ -typedef struct GlobTypeData { - /* Corresponds to bcdpfls as in 'find -t' */ - int type; - /* Corresponds to file permissions */ - int perm; - /* Acceptable mac type */ - Tcl_Obj* macType; - /* Acceptable mac creator */ - Tcl_Obj* macCreator; -} GlobTypeData; - -/* - * type and permission definitions for glob command + *---------------------------------------------------------------- + * Data structures related to procedures + *---------------------------------------------------------------- */ -#define TCL_GLOB_TYPE_BLOCK (1<<0) -#define TCL_GLOB_TYPE_CHAR (1<<1) -#define TCL_GLOB_TYPE_DIR (1<<2) -#define TCL_GLOB_TYPE_PIPE (1<<3) -#define TCL_GLOB_TYPE_FILE (1<<4) -#define TCL_GLOB_TYPE_LINK (1<<5) -#define TCL_GLOB_TYPE_SOCK (1<<6) -#define TCL_GLOB_PERM_RONLY (1<<0) -#define TCL_GLOB_PERM_HIDDEN (1<<1) -#define TCL_GLOB_PERM_R (1<<2) -#define TCL_GLOB_PERM_W (1<<3) -#define TCL_GLOB_PERM_X (1<<4) +typedef Tcl_CmdProc *TclCmdProcType; +typedef Tcl_ObjCmdProc *TclObjCmdProcType; /* *---------------------------------------------------------------- @@ -1523,8 +1611,6 @@ extern char * tclDefaultEncodingDir; extern Tcl_ChannelType tclFileChannelType; extern char * tclMemDumpFileName; extern TclPlatformType tclPlatform; -extern char * tclpFileAttrStrings[]; -extern CONST TclFileAttrProcs tclpFileAttrProcs[]; /* * Variables denoting the Tcl object types defined in the core. @@ -1534,10 +1620,26 @@ extern Tcl_ObjType tclBooleanType; extern Tcl_ObjType tclByteArrayType; extern Tcl_ObjType tclByteCodeType; extern Tcl_ObjType tclDoubleType; +extern Tcl_ObjType tclEndOffsetType; extern Tcl_ObjType tclIntType; extern Tcl_ObjType tclListType; extern Tcl_ObjType tclProcBodyType; extern Tcl_ObjType tclStringType; +extern Tcl_ObjType tclArraySearchType; +extern Tcl_ObjType tclIndexType; +extern Tcl_ObjType tclNsNameType; +#ifndef TCL_WIDE_INT_IS_LONG +extern Tcl_ObjType tclWideIntType; +#endif + +/* + * Variables denoting the hash key types defined in the core. + */ + +extern Tcl_HashKeyType tclArrayHashKeyType; +extern Tcl_HashKeyType tclOneWordHashKeyType; +extern Tcl_HashKeyType tclStringHashKeyType; +extern Tcl_HashKeyType tclObjHashKeyType; /* * The head of the list of free Tcl objects, and the total number of Tcl @@ -1549,6 +1651,8 @@ extern Tcl_Obj * tclFreeObjList; #ifdef TCL_COMPILE_STATS extern long tclObjsAlloced; extern long tclObjsFreed; +#define TCL_MAX_SHARED_OBJ_STATS 5 +extern long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS]; #endif /* TCL_COMPILE_STATS */ /* @@ -1558,6 +1662,7 @@ extern long tclObjsFreed; */ extern char * tclEmptyStringRep; +extern char tclEmptyString; /* *---------------------------------------------------------------- @@ -1566,55 +1671,22 @@ extern char * tclEmptyStringRep; *---------------------------------------------------------------- */ -EXTERN int TclAccess _ANSI_ARGS_((CONST char *path, - int mode)); -EXTERN int TclAccessDeleteProc _ANSI_ARGS_((TclAccessProc_ *proc)); -EXTERN int TclAccessInsertProc _ANSI_ARGS_((TclAccessProc_ *proc)); -EXTERN void TclAllocateFreeObjects _ANSI_ARGS_((void)); EXTERN int TclArraySet _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj)); EXTERN int TclCheckBadOctal _ANSI_ARGS_((Tcl_Interp *interp, - char *value)); -EXTERN int TclCleanupChildren _ANSI_ARGS_((Tcl_Interp *interp, - int numPids, Tcl_Pid *pidPtr, - Tcl_Channel errorChan)); -EXTERN void TclCleanupCommand _ANSI_ARGS_((Command *cmdPtr)); -EXTERN int TclCopyChannel _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Channel inChan, Tcl_Channel outChan, - int toRead, Tcl_Obj *cmdPtr)); -/* - * TclCreatePipeline unofficially exported for use by BLT. - */ -EXTERN int TclCreatePipeline _ANSI_ARGS_((Tcl_Interp *interp, - int argc, char **argv, Tcl_Pid **pidArrayPtr, - TclFile *inPipePtr, TclFile *outPipePtr, - TclFile *errFilePtr)); -EXTERN int TclCreateProc _ANSI_ARGS_((Tcl_Interp *interp, - Namespace *nsPtr, char *procName, - Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, - Proc **procPtrPtr)); -EXTERN void TclDeleteCompiledLocalVars _ANSI_ARGS_(( - Interp *iPtr, CallFrame *framePtr)); -EXTERN void TclDeleteVars _ANSI_ARGS_((Interp *iPtr, - Tcl_HashTable *tablePtr)); -EXTERN int TclDoGlob _ANSI_ARGS_((Tcl_Interp *interp, - char *separators, Tcl_DString *headPtr, - char *tail, GlobTypeData *types)); -EXTERN void TclDumpMemoryInfo _ANSI_ARGS_((FILE *outFile)); + CONST char *value)); EXTERN void TclExpandTokenArray _ANSI_ARGS_(( Tcl_Parse *parsePtr)); -EXTERN void TclExprFloatError _ANSI_ARGS_((Tcl_Interp *interp, - double value)); EXTERN int TclFileAttrsCmd _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int TclFileCopyCmd _ANSI_ARGS_((Tcl_Interp *interp, - int argc, char **argv)) ; + int objc, Tcl_Obj *CONST objv[])) ; EXTERN int TclFileDeleteCmd _ANSI_ARGS_((Tcl_Interp *interp, - int argc, char **argv)); + int objc, Tcl_Obj *CONST objv[])); EXTERN int TclFileMakeDirsCmd _ANSI_ARGS_((Tcl_Interp *interp, - int argc, char **argv)) ; + int objc, Tcl_Obj *CONST objv[])) ; EXTERN int TclFileRenameCmd _ANSI_ARGS_((Tcl_Interp *interp, - int argc, char **argv)) ; + int objc, Tcl_Obj *CONST objv[])) ; EXTERN void TclFinalizeAllocSubsystem _ANSI_ARGS_((void)); EXTERN void TclFinalizeCompExecEnv _ANSI_ARGS_((void)); EXTERN void TclFinalizeCompilation _ANSI_ARGS_((void)); @@ -1622,68 +1694,18 @@ EXTERN void TclFinalizeEncodingSubsystem _ANSI_ARGS_((void)); EXTERN void TclFinalizeEnvironment _ANSI_ARGS_((void)); EXTERN void TclFinalizeExecution _ANSI_ARGS_((void)); EXTERN void TclFinalizeIOSubsystem _ANSI_ARGS_((void)); +EXTERN void TclFinalizeFilesystem _ANSI_ARGS_((void)); EXTERN void TclFinalizeLoad _ANSI_ARGS_((void)); EXTERN void TclFinalizeMemorySubsystem _ANSI_ARGS_((void)); EXTERN void TclFinalizeNotifier _ANSI_ARGS_((void)); +EXTERN void TclFinalizeAsync _ANSI_ARGS_((void)); EXTERN void TclFinalizeSynchronization _ANSI_ARGS_((void)); EXTERN void TclFinalizeThreadData _ANSI_ARGS_((void)); EXTERN void TclFindEncodings _ANSI_ARGS_((CONST char *argv0)); -EXTERN Proc * TclFindProc _ANSI_ARGS_((Interp *iPtr, - char *procName)); -EXTERN int TclFormatInt _ANSI_ARGS_((char *buffer, long n)); -EXTERN void TclFreePackageInfo _ANSI_ARGS_((Interp *iPtr)); -EXTERN int TclGetDate _ANSI_ARGS_((char *p, - unsigned long now, long zone, - unsigned long *timePtr)); -EXTERN Tcl_Obj * TclGetElementOfIndexedArray _ANSI_ARGS_(( - Tcl_Interp *interp, int localIndex, - Tcl_Obj *elemPtr, int leaveErrorMsg)); -EXTERN char * TclGetExtension _ANSI_ARGS_((char *name)); -EXTERN int TclGetFrame _ANSI_ARGS_((Tcl_Interp *interp, - char *string, CallFrame **framePtrPtr)); -EXTERN TclCmdProcType TclGetInterpProc _ANSI_ARGS_((void)); -EXTERN int TclGetIntForIndex _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr, int endValue, int *indexPtr)); -EXTERN Tcl_Obj * TclGetIndexedScalar _ANSI_ARGS_((Tcl_Interp *interp, - int localIndex, int leaveErrorMsg)); -EXTERN int TclGetLong _ANSI_ARGS_((Tcl_Interp *interp, - char *string, long *longPtr)); -EXTERN int TclGetLoadedPackages _ANSI_ARGS_(( - Tcl_Interp *interp, char *targetName)); -EXTERN int TclGetNamespaceForQualName _ANSI_ARGS_(( - Tcl_Interp *interp, char *qualName, - Namespace *cxtNsPtr, int flags, - Namespace **nsPtrPtr, Namespace **altNsPtrPtr, - Namespace **actualCxtPtrPtr, - char **simpleNamePtr)); -EXTERN TclObjCmdProcType TclGetObjInterpProc _ANSI_ARGS_((void)); -EXTERN int TclGetOpenMode _ANSI_ARGS_((Tcl_Interp *interp, - char *string, int *seekFlagPtr)); -EXTERN Tcl_Command TclGetOriginalCommand _ANSI_ARGS_(( - Tcl_Command command)); EXTERN int TclGlob _ANSI_ARGS_((Tcl_Interp *interp, - char *pattern, char *unquotedPrefix, - int globFlags, GlobTypeData* types)); -EXTERN int TclGlobalInvoke _ANSI_ARGS_((Tcl_Interp *interp, - int argc, char **argv, int flags)); -EXTERN int TclGuessPackageName _ANSI_ARGS_((char *fileName, - Tcl_DString *bufPtr)); -EXTERN int TclHideUnsafeCommands _ANSI_ARGS_(( - Tcl_Interp *interp)); -EXTERN int TclInExit _ANSI_ARGS_((void)); -EXTERN Tcl_Obj * TclIncrElementOfIndexedArray _ANSI_ARGS_(( - Tcl_Interp *interp, int localIndex, - Tcl_Obj *elemPtr, long incrAmount)); -EXTERN Tcl_Obj * TclIncrIndexedScalar _ANSI_ARGS_(( - Tcl_Interp *interp, int localIndex, - long incrAmount)); -EXTERN Tcl_Obj * TclIncrVar2 _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, - long incrAmount, int flags)); + char *pattern, Tcl_Obj *unquotedPrefix, + int globFlags, Tcl_GlobTypeData* types)); EXTERN void TclInitAlloc _ANSI_ARGS_((void)); -EXTERN void TclInitCompiledLocals _ANSI_ARGS_(( - Tcl_Interp *interp, CallFrame *framePtr, - Namespace *nsPtr)); EXTERN void TclInitDbCkalloc _ANSI_ARGS_((void)); EXTERN void TclInitEncodingSubsystem _ANSI_ARGS_((void)); EXTERN void TclInitIOSubsystem _ANSI_ARGS_((void)); @@ -1691,47 +1713,43 @@ EXTERN void TclInitNamespaceSubsystem _ANSI_ARGS_((void)); EXTERN void TclInitNotifier _ANSI_ARGS_((void)); EXTERN void TclInitObjSubsystem _ANSI_ARGS_((void)); EXTERN void TclInitSubsystems _ANSI_ARGS_((CONST char *argv0)); -EXTERN int TclInvoke _ANSI_ARGS_((Tcl_Interp *interp, - int argc, char **argv, int flags)); -EXTERN int TclInvokeObjectCommand _ANSI_ARGS_(( - ClientData clientData, Tcl_Interp *interp, - int argc, char **argv)); -EXTERN int TclInvokeStringCommand _ANSI_ARGS_(( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); EXTERN int TclIsLocalScalar _ANSI_ARGS_((CONST char *src, int len)); -EXTERN Proc * TclIsProc _ANSI_ARGS_((Command *cmdPtr)); -EXTERN Var * TclLookupVar _ANSI_ARGS_((Tcl_Interp *interp, - char *part1, char *part2, int flags, char *msg, - int createPart1, int createPart2, - Var **arrayPtrPtr)); -EXTERN int TclMathInProgress _ANSI_ARGS_((void)); -EXTERN int TclNeedSpace _ANSI_ARGS_((char *start, char *end)); -EXTERN Tcl_Obj * TclNewProcBodyObj _ANSI_ARGS_((Proc *procPtr)); -EXTERN int TclObjCommandComplete _ANSI_ARGS_((Tcl_Obj *cmdPtr)); -EXTERN int TclObjInterpProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -EXTERN int TclObjInvoke _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[], int flags)); -EXTERN int TclObjInvokeGlobal _ANSI_ARGS_((Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[], int flags)); -EXTERN int TclOpenFileChannelDeleteProc _ANSI_ARGS_(( - TclOpenFileChannelProc_ *proc)); -EXTERN int TclOpenFileChannelInsertProc _ANSI_ARGS_(( - TclOpenFileChannelProc_ *proc)); -EXTERN int TclpAccess _ANSI_ARGS_((CONST char *filename, +EXTERN int TclJoinThread _ANSI_ARGS_((Tcl_ThreadId id, + int* result)); +EXTERN Tcl_Obj * TclLindexList _ANSI_ARGS_((Tcl_Interp* interp, + Tcl_Obj* listPtr, + Tcl_Obj* argPtr )); +EXTERN Tcl_Obj * TclLindexFlat _ANSI_ARGS_((Tcl_Interp* interp, + Tcl_Obj* listPtr, + int indexCount, + Tcl_Obj *CONST indexArray[] + )); +EXTERN Tcl_Obj * TclLsetList _ANSI_ARGS_((Tcl_Interp* interp, + Tcl_Obj* listPtr, + Tcl_Obj* indexPtr, + Tcl_Obj* valuePtr + )); +EXTERN Tcl_Obj * TclLsetFlat _ANSI_ARGS_((Tcl_Interp* interp, + Tcl_Obj* listPtr, + int indexCount, + Tcl_Obj *CONST indexArray[], + Tcl_Obj* valuePtr + )); +EXTERN int TclParseBackslash _ANSI_ARGS_((CONST char *src, + int numBytes, int *readPtr, char *dst)); +EXTERN int TclParseHex _ANSI_ARGS_((CONST char *src, int numBytes, + Tcl_UniChar *resultPtr)); +EXTERN int TclParseInteger _ANSI_ARGS_((CONST char *string, + int numBytes)); +EXTERN int TclParseWhiteSpace _ANSI_ARGS_((CONST char *src, + int numBytes, Tcl_Parse *parsePtr, char *typePtr)); +EXTERN int TclpObjAccess _ANSI_ARGS_((Tcl_Obj *filename, int mode)); -EXTERN char * TclpAlloc _ANSI_ARGS_((unsigned int size)); +EXTERN int TclpObjLstat _ANSI_ARGS_((Tcl_Obj *pathPtr, + Tcl_StatBuf *buf)); EXTERN int TclpCheckStackSpace _ANSI_ARGS_((void)); -EXTERN int TclpCopyFile _ANSI_ARGS_((CONST char *source, - CONST char *dest)); -EXTERN int TclpCopyDirectory _ANSI_ARGS_((CONST char *source, - CONST char *dest, Tcl_DString *errorPtr)); -EXTERN int TclpCreateDirectory _ANSI_ARGS_((CONST char *path)); -EXTERN int TclpDeleteFile _ANSI_ARGS_((CONST char *path)); -EXTERN void TclpExit _ANSI_ARGS_((int status)); +EXTERN Tcl_Obj* TclpTempFileName _ANSI_ARGS_((void)); EXTERN void TclpFinalizeCondition _ANSI_ARGS_(( Tcl_Condition *condPtr)); EXTERN void TclpFinalizeMutex _ANSI_ARGS_((Tcl_Mutex *mutexPtr)); @@ -1743,56 +1761,63 @@ EXTERN char * TclpFindExecutable _ANSI_ARGS_(( CONST char *argv0)); EXTERN int TclpFindVariable _ANSI_ARGS_((CONST char *name, int *lengthPtr)); -EXTERN void TclpFree _ANSI_ARGS_((char *ptr)); -EXTERN unsigned long TclpGetClicks _ANSI_ARGS_((void)); -EXTERN Tcl_Channel TclpGetDefaultStdChannel _ANSI_ARGS_((int type)); -EXTERN unsigned long TclpGetSeconds _ANSI_ARGS_((void)); -EXTERN void TclpGetTime _ANSI_ARGS_((Tcl_Time *time)); -EXTERN int TclpGetTimeZone _ANSI_ARGS_((unsigned long time)); -EXTERN char * TclpGetUserHome _ANSI_ARGS_((CONST char *name, - Tcl_DString *bufferPtr)); -EXTERN int TclpHasSockets _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN void TclpInitLibraryPath _ANSI_ARGS_((CONST char *argv0)); EXTERN void TclpInitLock _ANSI_ARGS_((void)); EXTERN void TclpInitPlatform _ANSI_ARGS_((void)); EXTERN void TclpInitUnlock _ANSI_ARGS_((void)); -EXTERN int TclpListVolumes _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int TclpLoadFile _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *pathPtr, + CONST char *sym1, CONST char *sym2, + Tcl_PackageInitProc **proc1Ptr, + Tcl_PackageInitProc **proc2Ptr, + ClientData *clientDataPtr, + Tcl_FSUnloadFileProc **unloadProcPtr)); +EXTERN Tcl_Obj* TclpObjListVolumes _ANSI_ARGS_((void)); EXTERN void TclpMasterLock _ANSI_ARGS_((void)); EXTERN void TclpMasterUnlock _ANSI_ARGS_((void)); EXTERN int TclpMatchFiles _ANSI_ARGS_((Tcl_Interp *interp, char *separators, Tcl_DString *dirPtr, char *pattern, char *tail)); +EXTERN int TclpObjNormalizePath _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *pathPtr, int nextCheckpoint)); +EXTERN int TclpObjCreateDirectory _ANSI_ARGS_((Tcl_Obj *pathPtr)); +EXTERN void TclpNativeJoinPath _ANSI_ARGS_((Tcl_Obj *prefix, + char *joining)); +EXTERN Tcl_Obj* TclpNativeSplitPath _ANSI_ARGS_((Tcl_Obj *pathPtr, + int *lenPtr)); +EXTERN Tcl_PathType TclpGetNativePathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr, + int *driveNameLengthPtr, Tcl_Obj **driveNameRef)); +EXTERN int TclCrossFilesystemCopy _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *source, Tcl_Obj *target)); +EXTERN int TclpObjDeleteFile _ANSI_ARGS_((Tcl_Obj *pathPtr)); +EXTERN int TclpObjCopyDirectory _ANSI_ARGS_((Tcl_Obj *srcPathPtr, + Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr)); +EXTERN int TclpObjCopyFile _ANSI_ARGS_((Tcl_Obj *srcPathPtr, + Tcl_Obj *destPathPtr)); +EXTERN int TclpObjRemoveDirectory _ANSI_ARGS_((Tcl_Obj *pathPtr, + int recursive, Tcl_Obj **errorPtr)); +EXTERN int TclpObjRenameFile _ANSI_ARGS_((Tcl_Obj *srcPathPtr, + Tcl_Obj *destPathPtr)); +EXTERN int TclpMatchInDirectory _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *resultPtr, Tcl_Obj *pathPtr, + CONST char *pattern, Tcl_GlobTypeData *types)); +EXTERN Tcl_Obj* TclpObjGetCwd _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN Tcl_Obj* TclpObjLink _ANSI_ARGS_((Tcl_Obj *pathPtr, + Tcl_Obj *toPtr, int linkType)); +EXTERN int TclpObjChdir _ANSI_ARGS_((Tcl_Obj *pathPtr)); +EXTERN Tcl_Obj* TclFileDirname _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj*pathPtr)); +EXTERN int TclpObjStat _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_StatBuf *buf)); EXTERN Tcl_Channel TclpOpenFileChannel _ANSI_ARGS_((Tcl_Interp *interp, - char *fileName, char *modeString, + Tcl_Obj *pathPtr, int mode, int permissions)); +EXTERN void TclpPanic _ANSI_ARGS_(TCL_VARARGS(CONST char *, + format)); EXTERN char * TclpReadlink _ANSI_ARGS_((CONST char *fileName, Tcl_DString *linkPtr)); -EXTERN char * TclpRealloc _ANSI_ARGS_((char *ptr, - unsigned int size)); EXTERN void TclpReleaseFile _ANSI_ARGS_((TclFile file)); -EXTERN int TclpRemoveDirectory _ANSI_ARGS_((CONST char *path, - int recursive, Tcl_DString *errorPtr)); -EXTERN int TclpRenameFile _ANSI_ARGS_((CONST char *source, - CONST char *dest)); -EXTERN void TclpSetInitialEncodings _ANSI_ARGS_((void)); EXTERN void TclpSetVariables _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN VOID * TclpSysAlloc _ANSI_ARGS_((long size, int isBin)); -EXTERN void TclpSysFree _ANSI_ARGS_((VOID *ptr)); -EXTERN VOID * TclpSysRealloc _ANSI_ARGS_((VOID *cp, - unsigned int size)); -EXTERN void TclpUnloadFile _ANSI_ARGS_((ClientData clientData)); -EXTERN char * TclPrecTraceProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, char *name1, char *name2, - int flags)); -EXTERN int TclPreventAliasLoop _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Interp *cmdInterp, Tcl_Command cmd)); -EXTERN void TclProcCleanupProc _ANSI_ARGS_((Proc *procPtr)); -EXTERN int TclProcCompileProc _ANSI_ARGS_((Tcl_Interp *interp, - Proc *procPtr, Tcl_Obj *bodyPtr, Namespace *nsPtr, - CONST char *description, CONST char *procName)); -EXTERN void TclProcDeleteProc _ANSI_ARGS_((ClientData clientData)); -EXTERN int TclProcInterpProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN void TclpUnloadFile _ANSI_ARGS_((Tcl_LoadHandle loadHandle)); EXTERN VOID * TclpThreadDataKeyGet _ANSI_ARGS_(( Tcl_ThreadDataKey *keyPtr)); EXTERN void TclpThreadDataKeyInit _ANSI_ARGS_(( @@ -1802,33 +1827,22 @@ EXTERN void TclpThreadDataKeySet _ANSI_ARGS_(( EXTERN void TclpThreadExit _ANSI_ARGS_((int status)); EXTERN void TclRememberCondition _ANSI_ARGS_((Tcl_Condition *mutex)); EXTERN void TclRememberDataKey _ANSI_ARGS_((Tcl_ThreadDataKey *mutex)); +EXTERN VOID TclRememberJoinableThread _ANSI_ARGS_((Tcl_ThreadId id)); EXTERN void TclRememberMutex _ANSI_ARGS_((Tcl_Mutex *mutex)); -EXTERN int TclRenameCommand _ANSI_ARGS_((Tcl_Interp *interp, - char *oldName, char *newName)) ; -EXTERN void TclResetShadowedCmdRefs _ANSI_ARGS_(( - Tcl_Interp *interp, Command *newCmdPtr)); -EXTERN int TclServiceIdle _ANSI_ARGS_((void)); -EXTERN Tcl_Obj * TclSetElementOfIndexedArray _ANSI_ARGS_(( - Tcl_Interp *interp, int localIndex, - Tcl_Obj *elemPtr, Tcl_Obj *objPtr, - int leaveErrorMsg)); -EXTERN Tcl_Obj * TclSetIndexedScalar _ANSI_ARGS_((Tcl_Interp *interp, - int localIndex, Tcl_Obj *objPtr, - int leaveErrorMsg)); -EXTERN char * TclSetPreInitScript _ANSI_ARGS_((char *string)); -EXTERN void TclSetupEnv _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN int TclSockGetPort _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *proto, int *portPtr)); -EXTERN int TclSockMinimumBuffers _ANSI_ARGS_((int sock, - int size)); -EXTERN int TclStat _ANSI_ARGS_((CONST char *path, - struct stat *buf)); -EXTERN int TclStatDeleteProc _ANSI_ARGS_((TclStatProc_ *proc)); -EXTERN int TclStatInsertProc _ANSI_ARGS_((TclStatProc_ *proc)); -EXTERN void TclTeardownNamespace _ANSI_ARGS_((Namespace *nsPtr)); +EXTERN VOID TclSignalExitThread _ANSI_ARGS_((Tcl_ThreadId id, + int result)); EXTERN void TclTransferResult _ANSI_ARGS_((Tcl_Interp *sourceInterp, int result, Tcl_Interp *targetInterp)); -EXTERN int TclUpdateReturnInfo _ANSI_ARGS_((Interp *iPtr)); +EXTERN Tcl_Obj* TclpNativeToNormalized + _ANSI_ARGS_((ClientData clientData)); +EXTERN Tcl_Obj* TclpFilesystemPathType + _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); +EXTERN Tcl_PackageInitProc* TclpFindSymbol _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_LoadHandle loadHandle, CONST char *symbol)); +EXTERN int TclpDlopen _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *pathPtr, + Tcl_LoadHandle *loadHandle, + Tcl_FSUnloadFileProc **unloadProcPtr)); /* *---------------------------------------------------------------- @@ -1926,6 +1940,8 @@ EXTERN int Tcl_LreplaceObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_LsearchObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_LsetObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp* interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_LsortObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_NamespaceObjCmd _ANSI_ARGS_((ClientData clientData, @@ -1997,7 +2013,7 @@ EXTERN int Tcl_WhileObjCmd _ANSI_ARGS_((ClientData clientData, #ifdef MAC_TCL EXTERN int Tcl_EchoCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); + Tcl_Interp *interp, int argc, CONST84 char **argv)); EXTERN int Tcl_LsObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_BeepObjCmd _ANSI_ARGS_((ClientData clientData, @@ -2014,6 +2030,8 @@ EXTERN int Tcl_ResourceObjCmd _ANSI_ARGS_((ClientData clientData, *---------------------------------------------------------------- */ +EXTERN int TclCompileAppendCmd _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); EXTERN int TclCompileBreakCmd _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); EXTERN int TclCompileCatchCmd _ANSI_ARGS_((Tcl_Interp *interp, @@ -2030,12 +2048,52 @@ EXTERN int TclCompileIfCmd _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); EXTERN int TclCompileIncrCmd _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); +EXTERN int TclCompileLappendCmd _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); +EXTERN int TclCompileLindexCmd _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); +EXTERN int TclCompileListCmd _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); +EXTERN int TclCompileLlengthCmd _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); +EXTERN int TclCompileLsetCmd _ANSI_ARGS_((Tcl_Interp* interp, + Tcl_Parse* parsePtr, struct CompileEnv* envPtr)); +EXTERN int TclCompileRegexpCmd _ANSI_ARGS_((Tcl_Interp* interp, + Tcl_Parse* parsePtr, struct CompileEnv* envPtr)); +EXTERN int TclCompileReturnCmd _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); EXTERN int TclCompileSetCmd _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); +EXTERN int TclCompileStringCmd _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); EXTERN int TclCompileWhileCmd _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); /* + * Functions defined in generic/tclVar.c and currenttly exported only + * for use by the bytecode compiler and engine. Some of these could later + * be placed in the public interface. + */ + +EXTERN Var * TclLookupArrayElement _ANSI_ARGS_((Tcl_Interp *interp, + CONST char *arrayName, CONST char *elName, CONST int flags, + CONST char *msg, CONST int createPart1, + CONST int createPart2, Var *arrayPtr)); +EXTERN Var * TclObjLookupVar _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *part1Ptr, CONST char *part2, int flags, + CONST char *msg, CONST int createPart1, + CONST int createPart2, Var **arrayPtrPtr)); +EXTERN Tcl_Obj *TclPtrGetVar _ANSI_ARGS_((Tcl_Interp *interp, Var *varPtr, + Var *arrayPtr, CONST char *part1, CONST char *part2, + CONST int flags)); +EXTERN Tcl_Obj *TclPtrSetVar _ANSI_ARGS_((Tcl_Interp *interp, Var *varPtr, + Var *arrayPtr, CONST char *part1, CONST char *part2, + Tcl_Obj *newValuePtr, CONST int flags)); +EXTERN Tcl_Obj *TclPtrIncrVar _ANSI_ARGS_((Tcl_Interp *interp, Var *varPtr, + Var *arrayPtr, CONST char *part1, CONST char *part2, + CONST long i, CONST int flags)); + +/* *---------------------------------------------------------------- * Macros used by the Tcl core to create and release Tcl objects. * TclNewObj(objPtr) creates a new object denoting an empty string. @@ -2050,6 +2108,10 @@ EXTERN int TclCompileWhileCmd _ANSI_ARGS_((Tcl_Interp *interp, * * EXTERN void TclNewObj _ANSI_ARGS_((Tcl_Obj *objPtr)); * EXTERN void TclDecrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr)); + * + * These macros are defined in terms of two macros that depend on + * memory allocator in use: TclAllocObjStorage, TclFreeObjStorage. + * They are defined below. *---------------------------------------------------------------- */ @@ -2063,78 +2125,102 @@ EXTERN int TclCompileWhileCmd _ANSI_ARGS_((Tcl_Interp *interp, # define TclIncrObjsFreed() #endif /* TCL_COMPILE_STATS */ -#ifdef TCL_MEM_DEBUG -# define TclNewObj(objPtr) \ - (objPtr) = (Tcl_Obj *) \ - Tcl_DbCkalloc(sizeof(Tcl_Obj), __FILE__, __LINE__); \ - (objPtr)->refCount = 0; \ - (objPtr)->bytes = tclEmptyStringRep; \ - (objPtr)->length = 0; \ - (objPtr)->typePtr = NULL; \ - TclIncrObjsAllocated() - -# define TclDbNewObj(objPtr, file, line) \ - (objPtr) = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), (file), (line)); \ +#define TclNewObj(objPtr) \ + TclAllocObjStorage(objPtr); \ + TclIncrObjsAllocated(); \ (objPtr)->refCount = 0; \ (objPtr)->bytes = tclEmptyStringRep; \ (objPtr)->length = 0; \ - (objPtr)->typePtr = NULL; \ - TclIncrObjsAllocated() - -# define TclDecrRefCount(objPtr) \ + (objPtr)->typePtr = NULL + +#define TclDecrRefCount(objPtr) \ if (--(objPtr)->refCount <= 0) { \ - if ((objPtr)->refCount < -1) \ - panic("Reference count for %lx was negative: %s line %d", \ - (objPtr), __FILE__, __LINE__); \ - if (((objPtr)->bytes != NULL) \ - && ((objPtr)->bytes != tclEmptyStringRep)) { \ - ckfree((char *) (objPtr)->bytes); \ - } \ if (((objPtr)->typePtr != NULL) \ && ((objPtr)->typePtr->freeIntRepProc != NULL)) { \ (objPtr)->typePtr->freeIntRepProc(objPtr); \ } \ - ckfree((char *) (objPtr)); \ + if (((objPtr)->bytes != NULL) \ + && ((objPtr)->bytes != tclEmptyStringRep)) { \ + ckfree((char *) (objPtr)->bytes); \ + } \ + TclFreeObjStorage(objPtr); \ TclIncrObjsFreed(); \ } +#ifdef TCL_MEM_DEBUG +# define TclAllocObjStorage(objPtr) \ + (objPtr) = (Tcl_Obj *) \ + Tcl_DbCkalloc(sizeof(Tcl_Obj), __FILE__, __LINE__) + +# define TclFreeObjStorage(objPtr) \ + if ((objPtr)->refCount < -1) { \ + panic("Reference count for %lx was negative: %s line %d", \ + (objPtr), __FILE__, __LINE__); \ + } \ + ckfree((char *) (objPtr)) + +# define TclDbNewObj(objPtr, file, line) \ + (objPtr) = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), (file), (line)); \ + (objPtr)->refCount = 0; \ + (objPtr)->bytes = tclEmptyStringRep; \ + (objPtr)->length = 0; \ + (objPtr)->typePtr = NULL; \ + TclIncrObjsAllocated() + +#elif defined(PURIFY) + +/* + * The PURIFY mode is like the regular mode, but instead of doing block + * Tcl_Obj allocation and keeping a freed list for efficiency, it always + * allocates and frees a single Tcl_Obj so that tools like Purify can + * better track memory leaks + */ + +# define TclAllocObjStorage(objPtr) \ + (objPtr) = (Tcl_Obj *) Tcl_Ckalloc(sizeof(Tcl_Obj)) + +# define TclFreeObjStorage(objPtr) \ + ckfree((char *) (objPtr)) + +#elif defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) + +/* + * The TCL_THREADS mode is like the regular mode but allocates Tcl_Obj's + * from per-thread caches. + */ + +EXTERN Tcl_Obj *TclThreadAllocObj _ANSI_ARGS_((void)); +EXTERN void TclThreadFreeObj _ANSI_ARGS_((Tcl_Obj *)); + +# define TclAllocObjStorage(objPtr) \ + (objPtr) = TclThreadAllocObj() + +# define TclFreeObjStorage(objPtr) \ + TclThreadFreeObj((objPtr)) + #else /* not TCL_MEM_DEBUG */ #ifdef TCL_THREADS +/* declared in tclObj.c */ extern Tcl_Mutex tclObjMutex; #endif -# define TclNewObj(objPtr) \ - Tcl_MutexLock(&tclObjMutex); \ - if (tclFreeObjList == NULL) { \ - TclAllocateFreeObjects(); \ - } \ - (objPtr) = tclFreeObjList; \ - tclFreeObjList = (Tcl_Obj *) \ - tclFreeObjList->internalRep.otherValuePtr; \ - (objPtr)->refCount = 0; \ - (objPtr)->bytes = tclEmptyStringRep; \ - (objPtr)->length = 0; \ - (objPtr)->typePtr = NULL; \ - TclIncrObjsAllocated(); \ - Tcl_MutexUnlock(&tclObjMutex) +# define TclAllocObjStorage(objPtr) \ + Tcl_MutexLock(&tclObjMutex); \ + if (tclFreeObjList == NULL) { \ + TclAllocateFreeObjects(); \ + } \ + (objPtr) = tclFreeObjList; \ + tclFreeObjList = (Tcl_Obj *) \ + tclFreeObjList->internalRep.otherValuePtr; \ + Tcl_MutexUnlock(&tclObjMutex) + +# define TclFreeObjStorage(objPtr) \ + Tcl_MutexLock(&tclObjMutex); \ + (objPtr)->internalRep.otherValuePtr = (VOID *) tclFreeObjList; \ + tclFreeObjList = (objPtr); \ + Tcl_MutexUnlock(&tclObjMutex) -# define TclDecrRefCount(objPtr) \ - if (--(objPtr)->refCount <= 0) { \ - if (((objPtr)->bytes != NULL) \ - && ((objPtr)->bytes != tclEmptyStringRep)) { \ - ckfree((char *) (objPtr)->bytes); \ - } \ - if (((objPtr)->typePtr != NULL) \ - && ((objPtr)->typePtr->freeIntRepProc != NULL)) { \ - (objPtr)->typePtr->freeIntRepProc(objPtr); \ - } \ - Tcl_MutexLock(&tclObjMutex); \ - (objPtr)->internalRep.otherValuePtr = (VOID *) tclFreeObjList; \ - tclFreeObjList = (objPtr); \ - TclIncrObjsFreed(); \ - Tcl_MutexUnlock(&tclObjMutex); \ - } #endif /* TCL_MEM_DEBUG */ /* @@ -2179,6 +2265,23 @@ extern Tcl_Mutex tclObjMutex; #define TclGetString(objPtr) \ ((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString((objPtr))) +/* + *---------------------------------------------------------------- + * 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: + * + * EXTERN int TclUniCharNcmp _ANSI_ARGS_((CONST Tcl_UniChar *cs, + * CONST Tcl_UniChar *ct, unsigned long n)); + *---------------------------------------------------------------- + */ +#ifdef WORDS_BIGENDIAN +# define TclUniCharNcmp(cs,ct,n) memcmp((cs),(ct),(n)*sizeof(Tcl_UniChar)) +#else /* !WORDS_BIGENDIAN */ +# define TclUniCharNcmp Tcl_UniCharNcmp +#endif /* WORDS_BIGENDIAN */ + #include "tclIntDecls.h" # undef TCL_STORAGE_CLASS @@ -2186,4 +2289,3 @@ extern Tcl_Mutex tclObjMutex; #endif /* _TCLINT */ - diff --git a/tcl/generic/tclIntDecls.h b/tcl/generic/tclIntDecls.h index 900fc2e9f00..adea7f58f25 100644 --- a/tcl/generic/tclIntDecls.h +++ b/tcl/generic/tclIntDecls.h @@ -29,8 +29,7 @@ * Exported function declarations: */ -/* 0 */ -EXTERN int TclAccess _ANSI_ARGS_((CONST char * path, int mode)); +/* Slot 0 is reserved */ /* 1 */ EXTERN int TclAccessDeleteProc _ANSI_ARGS_(( TclAccessProc_ * proc)); @@ -64,20 +63,20 @@ EXTERN int TclCopyChannel _ANSI_ARGS_((Tcl_Interp * interp, #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ /* 9 */ EXTERN int TclCreatePipeline _ANSI_ARGS_((Tcl_Interp * interp, - int argc, char ** argv, + int argc, CONST char ** argv, Tcl_Pid ** pidArrayPtr, TclFile * inPipePtr, TclFile * outPipePtr, TclFile * errFilePtr)); #endif /* UNIX */ #ifdef __WIN32__ /* 9 */ EXTERN int TclCreatePipeline _ANSI_ARGS_((Tcl_Interp * interp, - int argc, char ** argv, + int argc, CONST char ** argv, Tcl_Pid ** pidArrayPtr, TclFile * inPipePtr, TclFile * outPipePtr, TclFile * errFilePtr)); #endif /* __WIN32__ */ /* 10 */ EXTERN int TclCreateProc _ANSI_ARGS_((Tcl_Interp * interp, - Namespace * nsPtr, char * procName, + Namespace * nsPtr, CONST char * procName, Tcl_Obj * argsPtr, Tcl_Obj * bodyPtr, Proc ** procPtrPtr)); /* 11 */ @@ -89,28 +88,18 @@ EXTERN void TclDeleteVars _ANSI_ARGS_((Interp * iPtr, /* 13 */ EXTERN int TclDoGlob _ANSI_ARGS_((Tcl_Interp * interp, char * separators, Tcl_DString * headPtr, - char * tail, GlobTypeData * types)); + char * tail, Tcl_GlobTypeData * types)); /* 14 */ EXTERN void TclDumpMemoryInfo _ANSI_ARGS_((FILE * outFile)); /* Slot 15 is reserved */ /* 16 */ EXTERN void TclExprFloatError _ANSI_ARGS_((Tcl_Interp * interp, double value)); -/* 17 */ -EXTERN int TclFileAttrsCmd _ANSI_ARGS_((Tcl_Interp * interp, - int objc, Tcl_Obj *CONST objv[])); -/* 18 */ -EXTERN int TclFileCopyCmd _ANSI_ARGS_((Tcl_Interp * interp, - int argc, char ** argv)); -/* 19 */ -EXTERN int TclFileDeleteCmd _ANSI_ARGS_((Tcl_Interp * interp, - int argc, char ** argv)); -/* 20 */ -EXTERN int TclFileMakeDirsCmd _ANSI_ARGS_((Tcl_Interp * interp, - int argc, char ** argv)); -/* 21 */ -EXTERN int TclFileRenameCmd _ANSI_ARGS_((Tcl_Interp * interp, - int argc, char ** argv)); +/* Slot 17 is reserved */ +/* Slot 18 is reserved */ +/* Slot 19 is reserved */ +/* Slot 20 is reserved */ +/* Slot 21 is reserved */ /* 22 */ EXTERN int TclFindElement _ANSI_ARGS_((Tcl_Interp * interp, CONST char * listStr, int listLength, @@ -119,7 +108,7 @@ EXTERN int TclFindElement _ANSI_ARGS_((Tcl_Interp * interp, int * bracePtr)); /* 23 */ EXTERN Proc * TclFindProc _ANSI_ARGS_((Interp * iPtr, - char * procName)); + CONST char * procName)); /* 24 */ EXTERN int TclFormatInt _ANSI_ARGS_((char * buffer, long n)); /* 25 */ @@ -130,44 +119,39 @@ EXTERN int TclGetDate _ANSI_ARGS_((char * p, unsigned long now, long zone, unsigned long * timePtr)); /* 28 */ EXTERN Tcl_Channel TclpGetDefaultStdChannel _ANSI_ARGS_((int type)); -/* 29 */ -EXTERN Tcl_Obj * TclGetElementOfIndexedArray _ANSI_ARGS_(( - Tcl_Interp * interp, int localIndex, - Tcl_Obj * elemPtr, int leaveErrorMsg)); +/* Slot 29 is reserved */ /* Slot 30 is reserved */ /* 31 */ EXTERN char * TclGetExtension _ANSI_ARGS_((char * name)); /* 32 */ EXTERN int TclGetFrame _ANSI_ARGS_((Tcl_Interp * interp, - char * str, CallFrame ** framePtrPtr)); + CONST char * str, CallFrame ** framePtrPtr)); /* 33 */ EXTERN TclCmdProcType TclGetInterpProc _ANSI_ARGS_((void)); /* 34 */ EXTERN int TclGetIntForIndex _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int endValue, int * indexPtr)); -/* 35 */ -EXTERN Tcl_Obj * TclGetIndexedScalar _ANSI_ARGS_((Tcl_Interp * interp, - int localIndex, int leaveErrorMsg)); +/* Slot 35 is reserved */ /* 36 */ EXTERN int TclGetLong _ANSI_ARGS_((Tcl_Interp * interp, - char * str, long * longPtr)); + CONST char * str, long * longPtr)); /* 37 */ EXTERN int TclGetLoadedPackages _ANSI_ARGS_(( Tcl_Interp * interp, char * targetName)); /* 38 */ EXTERN int TclGetNamespaceForQualName _ANSI_ARGS_(( - Tcl_Interp * interp, char * qualName, + Tcl_Interp * interp, CONST char * qualName, Namespace * cxtNsPtr, int flags, Namespace ** nsPtrPtr, Namespace ** altNsPtrPtr, Namespace ** actualCxtPtrPtr, - char ** simpleNamePtr)); + CONST char ** simpleNamePtr)); /* 39 */ EXTERN TclObjCmdProcType TclGetObjInterpProc _ANSI_ARGS_((void)); /* 40 */ EXTERN int TclGetOpenMode _ANSI_ARGS_((Tcl_Interp * interp, - char * str, int * seekFlagPtr)); + CONST char * str, int * seekFlagPtr)); /* 41 */ EXTERN Tcl_Command TclGetOriginalCommand _ANSI_ARGS_(( Tcl_Command command)); @@ -176,23 +160,17 @@ EXTERN char * TclpGetUserHome _ANSI_ARGS_((CONST char * name, Tcl_DString * bufferPtr)); /* 43 */ EXTERN int TclGlobalInvoke _ANSI_ARGS_((Tcl_Interp * interp, - int argc, char ** argv, int flags)); + int argc, CONST84 char ** argv, int flags)); /* 44 */ -EXTERN int TclGuessPackageName _ANSI_ARGS_((char * fileName, - Tcl_DString * bufPtr)); +EXTERN int TclGuessPackageName _ANSI_ARGS_(( + CONST char * fileName, Tcl_DString * bufPtr)); /* 45 */ EXTERN int TclHideUnsafeCommands _ANSI_ARGS_(( Tcl_Interp * interp)); /* 46 */ EXTERN int TclInExit _ANSI_ARGS_((void)); -/* 47 */ -EXTERN Tcl_Obj * TclIncrElementOfIndexedArray _ANSI_ARGS_(( - Tcl_Interp * interp, int localIndex, - Tcl_Obj * elemPtr, long incrAmount)); -/* 48 */ -EXTERN Tcl_Obj * TclIncrIndexedScalar _ANSI_ARGS_(( - Tcl_Interp * interp, int localIndex, - long incrAmount)); +/* Slot 47 is reserved */ +/* Slot 48 is reserved */ /* 49 */ EXTERN Tcl_Obj * TclIncrVar2 _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, @@ -205,11 +183,11 @@ EXTERN void TclInitCompiledLocals _ANSI_ARGS_(( EXTERN int TclInterpInit _ANSI_ARGS_((Tcl_Interp * interp)); /* 52 */ EXTERN int TclInvoke _ANSI_ARGS_((Tcl_Interp * interp, int argc, - char ** argv, int flags)); + CONST84 char ** argv, int flags)); /* 53 */ EXTERN int TclInvokeObjectCommand _ANSI_ARGS_(( ClientData clientData, Tcl_Interp * interp, - int argc, char ** argv)); + int argc, CONST84 char ** argv)); /* 54 */ EXTERN int TclInvokeStringCommand _ANSI_ARGS_(( ClientData clientData, Tcl_Interp * interp, @@ -220,15 +198,13 @@ EXTERN Proc * TclIsProc _ANSI_ARGS_((Command * cmdPtr)); /* Slot 57 is reserved */ /* 58 */ EXTERN Var * TclLookupVar _ANSI_ARGS_((Tcl_Interp * interp, - char * part1, char * part2, int flags, - char * msg, int createPart1, int createPart2, - Var ** arrayPtrPtr)); -/* 59 */ -EXTERN int TclpMatchFiles _ANSI_ARGS_((Tcl_Interp * interp, - char * separators, Tcl_DString * dirPtr, - char * pattern, char * tail)); + CONST char * part1, CONST char * part2, + int flags, CONST char * msg, int createPart1, + int createPart2, Var ** arrayPtrPtr)); +/* Slot 59 is reserved */ /* 60 */ -EXTERN int TclNeedSpace _ANSI_ARGS_((char * start, char * end)); +EXTERN int TclNeedSpace _ANSI_ARGS_((CONST char * start, + CONST char * end)); /* 61 */ EXTERN Tcl_Obj * TclNewProcBodyObj _ANSI_ARGS_((Proc * procPtr)); /* 62 */ @@ -249,20 +225,13 @@ EXTERN int TclOpenFileChannelDeleteProc _ANSI_ARGS_(( /* 67 */ EXTERN int TclOpenFileChannelInsertProc _ANSI_ARGS_(( TclOpenFileChannelProc_ * proc)); -/* 68 */ -EXTERN int TclpAccess _ANSI_ARGS_((CONST char * path, int mode)); +/* Slot 68 is reserved */ /* 69 */ EXTERN char * TclpAlloc _ANSI_ARGS_((unsigned int size)); -/* 70 */ -EXTERN int TclpCopyFile _ANSI_ARGS_((CONST char * source, - CONST char * dest)); -/* 71 */ -EXTERN int TclpCopyDirectory _ANSI_ARGS_((CONST char * source, - CONST char * dest, Tcl_DString * errorPtr)); -/* 72 */ -EXTERN int TclpCreateDirectory _ANSI_ARGS_((CONST char * path)); -/* 73 */ -EXTERN int TclpDeleteFile _ANSI_ARGS_((CONST char * path)); +/* Slot 70 is reserved */ +/* Slot 71 is reserved */ +/* Slot 72 is reserved */ +/* Slot 73 is reserved */ /* 74 */ EXTERN void TclpFree _ANSI_ARGS_((char * ptr)); /* 75 */ @@ -273,29 +242,21 @@ EXTERN unsigned long TclpGetSeconds _ANSI_ARGS_((void)); EXTERN void TclpGetTime _ANSI_ARGS_((Tcl_Time * time)); /* 78 */ EXTERN int TclpGetTimeZone _ANSI_ARGS_((unsigned long time)); -/* 79 */ -EXTERN int TclpListVolumes _ANSI_ARGS_((Tcl_Interp * interp)); -/* 80 */ -EXTERN Tcl_Channel TclpOpenFileChannel _ANSI_ARGS_((Tcl_Interp * interp, - char * fileName, char * modeString, - int permissions)); +/* Slot 79 is reserved */ +/* Slot 80 is reserved */ /* 81 */ EXTERN char * TclpRealloc _ANSI_ARGS_((char * ptr, unsigned int size)); -/* 82 */ -EXTERN int TclpRemoveDirectory _ANSI_ARGS_((CONST char * path, - int recursive, Tcl_DString * errorPtr)); -/* 83 */ -EXTERN int TclpRenameFile _ANSI_ARGS_((CONST char * source, - CONST char * dest)); +/* Slot 82 is reserved */ +/* Slot 83 is reserved */ /* Slot 84 is reserved */ /* Slot 85 is reserved */ /* Slot 86 is reserved */ /* Slot 87 is reserved */ /* 88 */ EXTERN char * TclPrecTraceProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp * interp, char * name1, - char * name2, int flags)); + Tcl_Interp * interp, CONST char * name1, + CONST char * name2, int flags)); /* 89 */ EXTERN int TclPreventAliasLoop _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Interp * cmdInterp, Tcl_Command cmd)); @@ -311,10 +272,9 @@ EXTERN int TclProcCompileProc _ANSI_ARGS_((Tcl_Interp * interp, EXTERN void TclProcDeleteProc _ANSI_ARGS_((ClientData clientData)); /* 94 */ EXTERN int TclProcInterpProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp * interp, int argc, char ** argv)); -/* 95 */ -EXTERN int TclpStat _ANSI_ARGS_((CONST char * path, - struct stat * buf)); + Tcl_Interp * interp, int argc, + CONST84 char ** argv)); +/* Slot 95 is reserved */ /* 96 */ EXTERN int TclRenameCommand _ANSI_ARGS_((Tcl_Interp * interp, char * oldName, char * newName)); @@ -323,15 +283,8 @@ EXTERN void TclResetShadowedCmdRefs _ANSI_ARGS_(( Tcl_Interp * interp, Command * newCmdPtr)); /* 98 */ EXTERN int TclServiceIdle _ANSI_ARGS_((void)); -/* 99 */ -EXTERN Tcl_Obj * TclSetElementOfIndexedArray _ANSI_ARGS_(( - Tcl_Interp * interp, int localIndex, - Tcl_Obj * elemPtr, Tcl_Obj * objPtr, - int leaveErrorMsg)); -/* 100 */ -EXTERN Tcl_Obj * TclSetIndexedScalar _ANSI_ARGS_((Tcl_Interp * interp, - int localIndex, Tcl_Obj * objPtr, - int leaveErrorMsg)); +/* Slot 99 is reserved */ +/* Slot 100 is reserved */ #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ /* 101 */ EXTERN char * TclSetPreInitScript _ANSI_ARGS_((char * string)); @@ -355,9 +308,7 @@ EXTERN int TclSockMinimumBuffers _ANSI_ARGS_((int sock, EXTERN int TclSockMinimumBuffers _ANSI_ARGS_((int sock, int size)); #endif /* __WIN32__ */ -/* 105 */ -EXTERN int TclStat _ANSI_ARGS_((CONST char * path, - struct stat * buf)); +/* Slot 105 is reserved */ /* 106 */ EXTERN int TclStatDeleteProc _ANSI_ARGS_((TclStatProc_ * proc)); /* 107 */ @@ -369,7 +320,7 @@ EXTERN int TclUpdateReturnInfo _ANSI_ARGS_((Interp * iPtr)); /* Slot 110 is reserved */ /* 111 */ EXTERN void Tcl_AddInterpResolvers _ANSI_ARGS_(( - Tcl_Interp * interp, char * name, + Tcl_Interp * interp, CONST char * name, Tcl_ResolveCmdProc * cmdProc, Tcl_ResolveVarProc * varProc, Tcl_ResolveCompiledVarProc * compiledVarProc)); @@ -379,26 +330,26 @@ EXTERN int Tcl_AppendExportList _ANSI_ARGS_(( Tcl_Obj * objPtr)); /* 113 */ EXTERN Tcl_Namespace * Tcl_CreateNamespace _ANSI_ARGS_((Tcl_Interp * interp, - char * name, ClientData clientData, + CONST char * name, ClientData clientData, Tcl_NamespaceDeleteProc * deleteProc)); /* 114 */ EXTERN void Tcl_DeleteNamespace _ANSI_ARGS_(( Tcl_Namespace * nsPtr)); /* 115 */ EXTERN int Tcl_Export _ANSI_ARGS_((Tcl_Interp * interp, - Tcl_Namespace * nsPtr, char * pattern, + Tcl_Namespace * nsPtr, CONST char * pattern, int resetListFirst)); /* 116 */ EXTERN Tcl_Command Tcl_FindCommand _ANSI_ARGS_((Tcl_Interp * interp, - char * name, Tcl_Namespace * contextNsPtr, - int flags)); + CONST char * name, + Tcl_Namespace * contextNsPtr, int flags)); /* 117 */ EXTERN Tcl_Namespace * Tcl_FindNamespace _ANSI_ARGS_((Tcl_Interp * interp, - char * name, Tcl_Namespace * contextNsPtr, - int flags)); + CONST char * name, + Tcl_Namespace * contextNsPtr, int flags)); /* 118 */ EXTERN int Tcl_GetInterpResolvers _ANSI_ARGS_(( - Tcl_Interp * interp, char * name, + Tcl_Interp * interp, CONST char * name, Tcl_ResolverInfo * resInfo)); /* 119 */ EXTERN int Tcl_GetNamespaceResolvers _ANSI_ARGS_(( @@ -406,11 +357,11 @@ EXTERN int Tcl_GetNamespaceResolvers _ANSI_ARGS_(( Tcl_ResolverInfo * resInfo)); /* 120 */ EXTERN Tcl_Var Tcl_FindNamespaceVar _ANSI_ARGS_(( - Tcl_Interp * interp, char * name, + Tcl_Interp * interp, CONST char * name, Tcl_Namespace * contextNsPtr, int flags)); /* 121 */ EXTERN int Tcl_ForgetImport _ANSI_ARGS_((Tcl_Interp * interp, - Tcl_Namespace * nsPtr, char * pattern)); + Tcl_Namespace * nsPtr, CONST char * pattern)); /* 122 */ EXTERN Tcl_Command Tcl_GetCommandFromObj _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Obj * objPtr)); @@ -430,7 +381,7 @@ EXTERN void Tcl_GetVariableFullName _ANSI_ARGS_(( Tcl_Obj * objPtr)); /* 127 */ EXTERN int Tcl_Import _ANSI_ARGS_((Tcl_Interp * interp, - Tcl_Namespace * nsPtr, char * pattern, + Tcl_Namespace * nsPtr, CONST char * pattern, int allowOverwrite)); /* 128 */ EXTERN void Tcl_PopCallFrame _ANSI_ARGS_((Tcl_Interp* interp)); @@ -440,7 +391,7 @@ EXTERN int Tcl_PushCallFrame _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Namespace * nsPtr, int isProcCallFrame)); /* 130 */ EXTERN int Tcl_RemoveInterpResolvers _ANSI_ARGS_(( - Tcl_Interp * interp, char * name)); + Tcl_Interp * interp, CONST char * name)); /* 131 */ EXTERN void Tcl_SetNamespaceResolvers _ANSI_ARGS_(( Tcl_Namespace * namespacePtr, @@ -453,26 +404,21 @@ EXTERN int TclpHasSockets _ANSI_ARGS_((Tcl_Interp * interp)); EXTERN struct tm * TclpGetDate _ANSI_ARGS_((TclpTime_t time, int useGMT)); /* 134 */ EXTERN size_t TclpStrftime _ANSI_ARGS_((char * s, size_t maxsize, - CONST char * format, CONST struct tm * t)); + CONST char * format, CONST struct tm * t, + int useGMT)); /* 135 */ EXTERN int TclpCheckStackSpace _ANSI_ARGS_((void)); /* Slot 136 is reserved */ -/* 137 */ -EXTERN int TclpChdir _ANSI_ARGS_((CONST char * dirName)); +/* Slot 137 is reserved */ /* 138 */ -EXTERN char * TclGetEnv _ANSI_ARGS_((CONST char * name, +EXTERN CONST84_RETURN char * TclGetEnv _ANSI_ARGS_((CONST char * name, Tcl_DString * valuePtr)); -/* 139 */ -EXTERN int TclpLoadFile _ANSI_ARGS_((Tcl_Interp * interp, - char * fileName, char * sym1, char * sym2, - Tcl_PackageInitProc ** proc1Ptr, - Tcl_PackageInitProc ** proc2Ptr, - ClientData * clientDataPtr)); +/* Slot 139 is reserved */ /* 140 */ -EXTERN int TclLooksLikeInt _ANSI_ARGS_((char * bytes, +EXTERN int TclLooksLikeInt _ANSI_ARGS_((CONST char * bytes, int length)); /* 141 */ -EXTERN char * TclpGetCwd _ANSI_ARGS_((Tcl_Interp * interp, +EXTERN CONST84_RETURN char * TclpGetCwd _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * cwdPtr)); /* 142 */ EXTERN int TclSetByteCodeFromAny _ANSI_ARGS_(( @@ -510,32 +456,58 @@ EXTERN Tcl_Obj * TclGetLibraryPath _ANSI_ARGS_((void)); /* Slot 155 is reserved */ /* 156 */ EXTERN void TclRegError _ANSI_ARGS_((Tcl_Interp * interp, - char * msg, int status)); + CONST char * msg, int status)); /* 157 */ EXTERN Var * TclVarTraceExists _ANSI_ARGS_((Tcl_Interp * interp, - char * varName)); + CONST char * varName)); /* 158 */ EXTERN void TclSetStartupScriptFileName _ANSI_ARGS_(( - char * filename)); + CONST char * filename)); /* 159 */ -EXTERN char * TclGetStartupScriptFileName _ANSI_ARGS_((void)); -/* 160 */ -EXTERN int TclpMatchFilesTypes _ANSI_ARGS_((Tcl_Interp * interp, - char * separators, Tcl_DString * dirPtr, - char * pattern, char * tail, - GlobTypeData * types)); +EXTERN CONST84_RETURN char * TclGetStartupScriptFileName _ANSI_ARGS_((void)); +/* Slot 160 is reserved */ /* 161 */ EXTERN int TclChannelTransform _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, Tcl_Obj * cmdObjPtr)); /* 162 */ EXTERN void TclChannelEventScriptInvoker _ANSI_ARGS_(( ClientData clientData, int flags)); +/* 163 */ +EXTERN void * TclGetInstructionTable _ANSI_ARGS_((void)); +/* 164 */ +EXTERN void TclExpandCodeArray _ANSI_ARGS_((void * envPtr)); +/* 165 */ +EXTERN void TclpSetInitialEncodings _ANSI_ARGS_((void)); +/* 166 */ +EXTERN int TclListObjSetElement _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Obj * listPtr, + int index, Tcl_Obj * valuePtr)); +/* 167 */ +EXTERN void TclSetStartupScriptPath _ANSI_ARGS_(( + Tcl_Obj * pathPtr)); +/* 168 */ +EXTERN Tcl_Obj * TclGetStartupScriptPath _ANSI_ARGS_((void)); +/* 169 */ +EXTERN int TclpUtfNcmp2 _ANSI_ARGS_((CONST char * s1, + CONST char * s2, unsigned long n)); +/* 170 */ +EXTERN int TclCheckInterpTraces _ANSI_ARGS_(( + Tcl_Interp * interp, CONST char * command, + int numChars, Command * cmdPtr, int result, + int traceFlags, int objc, + Tcl_Obj *CONST objv[])); +/* 171 */ +EXTERN int TclCheckExecutionTraces _ANSI_ARGS_(( + Tcl_Interp * interp, CONST char * command, + int numChars, Command * cmdPtr, int result, + int traceFlags, int objc, + Tcl_Obj *CONST objv[])); typedef struct TclIntStubs { int magic; struct TclIntStubHooks *hooks; - int (*tclAccess) _ANSI_ARGS_((CONST char * path, int mode)); /* 0 */ + void *reserved0; int (*tclAccessDeleteProc) _ANSI_ARGS_((TclAccessProc_ * proc)); /* 1 */ int (*tclAccessInsertProc) _ANSI_ARGS_((TclAccessProc_ * proc)); /* 2 */ void (*tclAllocateFreeObjects) _ANSI_ARGS_((void)); /* 3 */ @@ -553,65 +525,65 @@ typedef struct TclIntStubs { int (*tclCopyAndCollapse) _ANSI_ARGS_((int count, CONST char * src, char * dst)); /* 7 */ int (*tclCopyChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj * cmdPtr)); /* 8 */ #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ - int (*tclCreatePipeline) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv, Tcl_Pid ** pidArrayPtr, TclFile * inPipePtr, TclFile * outPipePtr, TclFile * errFilePtr)); /* 9 */ + int (*tclCreatePipeline) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST char ** argv, Tcl_Pid ** pidArrayPtr, TclFile * inPipePtr, TclFile * outPipePtr, TclFile * errFilePtr)); /* 9 */ #endif /* UNIX */ #ifdef __WIN32__ - int (*tclCreatePipeline) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv, Tcl_Pid ** pidArrayPtr, TclFile * inPipePtr, TclFile * outPipePtr, TclFile * errFilePtr)); /* 9 */ + int (*tclCreatePipeline) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST char ** argv, Tcl_Pid ** pidArrayPtr, TclFile * inPipePtr, TclFile * outPipePtr, TclFile * errFilePtr)); /* 9 */ #endif /* __WIN32__ */ #ifdef MAC_TCL void *reserved9; #endif /* MAC_TCL */ - int (*tclCreateProc) _ANSI_ARGS_((Tcl_Interp * interp, Namespace * nsPtr, char * procName, Tcl_Obj * argsPtr, Tcl_Obj * bodyPtr, Proc ** procPtrPtr)); /* 10 */ + int (*tclCreateProc) _ANSI_ARGS_((Tcl_Interp * interp, Namespace * nsPtr, CONST char * procName, Tcl_Obj * argsPtr, Tcl_Obj * bodyPtr, Proc ** procPtrPtr)); /* 10 */ void (*tclDeleteCompiledLocalVars) _ANSI_ARGS_((Interp * iPtr, CallFrame * framePtr)); /* 11 */ void (*tclDeleteVars) _ANSI_ARGS_((Interp * iPtr, Tcl_HashTable * tablePtr)); /* 12 */ - int (*tclDoGlob) _ANSI_ARGS_((Tcl_Interp * interp, char * separators, Tcl_DString * headPtr, char * tail, GlobTypeData * types)); /* 13 */ + int (*tclDoGlob) _ANSI_ARGS_((Tcl_Interp * interp, char * separators, Tcl_DString * headPtr, char * tail, Tcl_GlobTypeData * types)); /* 13 */ void (*tclDumpMemoryInfo) _ANSI_ARGS_((FILE * outFile)); /* 14 */ void *reserved15; void (*tclExprFloatError) _ANSI_ARGS_((Tcl_Interp * interp, double value)); /* 16 */ - int (*tclFileAttrsCmd) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 17 */ - int (*tclFileCopyCmd) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv)); /* 18 */ - int (*tclFileDeleteCmd) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv)); /* 19 */ - int (*tclFileMakeDirsCmd) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv)); /* 20 */ - int (*tclFileRenameCmd) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv)); /* 21 */ + void *reserved17; + void *reserved18; + void *reserved19; + void *reserved20; + void *reserved21; int (*tclFindElement) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * listStr, int listLength, CONST char ** elementPtr, CONST char ** nextPtr, int * sizePtr, int * bracePtr)); /* 22 */ - Proc * (*tclFindProc) _ANSI_ARGS_((Interp * iPtr, char * procName)); /* 23 */ + Proc * (*tclFindProc) _ANSI_ARGS_((Interp * iPtr, CONST char * procName)); /* 23 */ int (*tclFormatInt) _ANSI_ARGS_((char * buffer, long n)); /* 24 */ void (*tclFreePackageInfo) _ANSI_ARGS_((Interp * iPtr)); /* 25 */ void *reserved26; int (*tclGetDate) _ANSI_ARGS_((char * p, unsigned long now, long zone, unsigned long * timePtr)); /* 27 */ Tcl_Channel (*tclpGetDefaultStdChannel) _ANSI_ARGS_((int type)); /* 28 */ - Tcl_Obj * (*tclGetElementOfIndexedArray) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * elemPtr, int leaveErrorMsg)); /* 29 */ + void *reserved29; void *reserved30; char * (*tclGetExtension) _ANSI_ARGS_((char * name)); /* 31 */ - int (*tclGetFrame) _ANSI_ARGS_((Tcl_Interp * interp, char * str, CallFrame ** framePtrPtr)); /* 32 */ + int (*tclGetFrame) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, CallFrame ** framePtrPtr)); /* 32 */ TclCmdProcType (*tclGetInterpProc) _ANSI_ARGS_((void)); /* 33 */ int (*tclGetIntForIndex) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int endValue, int * indexPtr)); /* 34 */ - Tcl_Obj * (*tclGetIndexedScalar) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, int leaveErrorMsg)); /* 35 */ - int (*tclGetLong) _ANSI_ARGS_((Tcl_Interp * interp, char * str, long * longPtr)); /* 36 */ + void *reserved35; + int (*tclGetLong) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, long * longPtr)); /* 36 */ int (*tclGetLoadedPackages) _ANSI_ARGS_((Tcl_Interp * interp, char * targetName)); /* 37 */ - int (*tclGetNamespaceForQualName) _ANSI_ARGS_((Tcl_Interp * interp, char * qualName, Namespace * cxtNsPtr, int flags, Namespace ** nsPtrPtr, Namespace ** altNsPtrPtr, Namespace ** actualCxtPtrPtr, char ** simpleNamePtr)); /* 38 */ + int (*tclGetNamespaceForQualName) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * qualName, Namespace * cxtNsPtr, int flags, Namespace ** nsPtrPtr, Namespace ** altNsPtrPtr, Namespace ** actualCxtPtrPtr, CONST char ** simpleNamePtr)); /* 38 */ TclObjCmdProcType (*tclGetObjInterpProc) _ANSI_ARGS_((void)); /* 39 */ - int (*tclGetOpenMode) _ANSI_ARGS_((Tcl_Interp * interp, char * str, int * seekFlagPtr)); /* 40 */ + int (*tclGetOpenMode) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, int * seekFlagPtr)); /* 40 */ Tcl_Command (*tclGetOriginalCommand) _ANSI_ARGS_((Tcl_Command command)); /* 41 */ char * (*tclpGetUserHome) _ANSI_ARGS_((CONST char * name, Tcl_DString * bufferPtr)); /* 42 */ - int (*tclGlobalInvoke) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv, int flags)); /* 43 */ - int (*tclGuessPackageName) _ANSI_ARGS_((char * fileName, Tcl_DString * bufPtr)); /* 44 */ + int (*tclGlobalInvoke) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST84 char ** argv, int flags)); /* 43 */ + int (*tclGuessPackageName) _ANSI_ARGS_((CONST char * fileName, Tcl_DString * bufPtr)); /* 44 */ int (*tclHideUnsafeCommands) _ANSI_ARGS_((Tcl_Interp * interp)); /* 45 */ int (*tclInExit) _ANSI_ARGS_((void)); /* 46 */ - Tcl_Obj * (*tclIncrElementOfIndexedArray) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * elemPtr, long incrAmount)); /* 47 */ - Tcl_Obj * (*tclIncrIndexedScalar) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, long incrAmount)); /* 48 */ + void *reserved47; + void *reserved48; Tcl_Obj * (*tclIncrVar2) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, long incrAmount, int part1NotParsed)); /* 49 */ void (*tclInitCompiledLocals) _ANSI_ARGS_((Tcl_Interp * interp, CallFrame * framePtr, Namespace * nsPtr)); /* 50 */ int (*tclInterpInit) _ANSI_ARGS_((Tcl_Interp * interp)); /* 51 */ - int (*tclInvoke) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv, int flags)); /* 52 */ - int (*tclInvokeObjectCommand) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int argc, char ** argv)); /* 53 */ + int (*tclInvoke) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST84 char ** argv, int flags)); /* 52 */ + int (*tclInvokeObjectCommand) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int argc, CONST84 char ** argv)); /* 53 */ int (*tclInvokeStringCommand) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 54 */ Proc * (*tclIsProc) _ANSI_ARGS_((Command * cmdPtr)); /* 55 */ void *reserved56; void *reserved57; - Var * (*tclLookupVar) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, char * part2, int flags, char * msg, int createPart1, int createPart2, Var ** arrayPtrPtr)); /* 58 */ - int (*tclpMatchFiles) _ANSI_ARGS_((Tcl_Interp * interp, char * separators, Tcl_DString * dirPtr, char * pattern, char * tail)); /* 59 */ - int (*tclNeedSpace) _ANSI_ARGS_((char * start, char * end)); /* 60 */ + Var * (*tclLookupVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, CONST char * msg, int createPart1, int createPart2, Var ** arrayPtrPtr)); /* 58 */ + void *reserved59; + int (*tclNeedSpace) _ANSI_ARGS_((CONST char * start, CONST char * end)); /* 60 */ Tcl_Obj * (*tclNewProcBodyObj) _ANSI_ARGS_((Proc * procPtr)); /* 61 */ int (*tclObjCommandComplete) _ANSI_ARGS_((Tcl_Obj * cmdPtr)); /* 62 */ int (*tclObjInterpProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 63 */ @@ -619,39 +591,39 @@ typedef struct TclIntStubs { int (*tclObjInvokeGlobal) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], int flags)); /* 65 */ int (*tclOpenFileChannelDeleteProc) _ANSI_ARGS_((TclOpenFileChannelProc_ * proc)); /* 66 */ int (*tclOpenFileChannelInsertProc) _ANSI_ARGS_((TclOpenFileChannelProc_ * proc)); /* 67 */ - int (*tclpAccess) _ANSI_ARGS_((CONST char * path, int mode)); /* 68 */ + void *reserved68; char * (*tclpAlloc) _ANSI_ARGS_((unsigned int size)); /* 69 */ - int (*tclpCopyFile) _ANSI_ARGS_((CONST char * source, CONST char * dest)); /* 70 */ - int (*tclpCopyDirectory) _ANSI_ARGS_((CONST char * source, CONST char * dest, Tcl_DString * errorPtr)); /* 71 */ - int (*tclpCreateDirectory) _ANSI_ARGS_((CONST char * path)); /* 72 */ - int (*tclpDeleteFile) _ANSI_ARGS_((CONST char * path)); /* 73 */ + void *reserved70; + void *reserved71; + void *reserved72; + void *reserved73; void (*tclpFree) _ANSI_ARGS_((char * ptr)); /* 74 */ unsigned long (*tclpGetClicks) _ANSI_ARGS_((void)); /* 75 */ unsigned long (*tclpGetSeconds) _ANSI_ARGS_((void)); /* 76 */ void (*tclpGetTime) _ANSI_ARGS_((Tcl_Time * time)); /* 77 */ int (*tclpGetTimeZone) _ANSI_ARGS_((unsigned long time)); /* 78 */ - int (*tclpListVolumes) _ANSI_ARGS_((Tcl_Interp * interp)); /* 79 */ - Tcl_Channel (*tclpOpenFileChannel) _ANSI_ARGS_((Tcl_Interp * interp, char * fileName, char * modeString, int permissions)); /* 80 */ + void *reserved79; + void *reserved80; char * (*tclpRealloc) _ANSI_ARGS_((char * ptr, unsigned int size)); /* 81 */ - int (*tclpRemoveDirectory) _ANSI_ARGS_((CONST char * path, int recursive, Tcl_DString * errorPtr)); /* 82 */ - int (*tclpRenameFile) _ANSI_ARGS_((CONST char * source, CONST char * dest)); /* 83 */ + void *reserved82; + void *reserved83; void *reserved84; void *reserved85; void *reserved86; void *reserved87; - char * (*tclPrecTraceProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, char * name1, char * name2, int flags)); /* 88 */ + char * (*tclPrecTraceProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, CONST char * name1, CONST char * name2, int flags)); /* 88 */ int (*tclPreventAliasLoop) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Interp * cmdInterp, Tcl_Command cmd)); /* 89 */ void *reserved90; void (*tclProcCleanupProc) _ANSI_ARGS_((Proc * procPtr)); /* 91 */ int (*tclProcCompileProc) _ANSI_ARGS_((Tcl_Interp * interp, Proc * procPtr, Tcl_Obj * bodyPtr, Namespace * nsPtr, CONST char * description, CONST char * procName)); /* 92 */ void (*tclProcDeleteProc) _ANSI_ARGS_((ClientData clientData)); /* 93 */ - int (*tclProcInterpProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int argc, char ** argv)); /* 94 */ - int (*tclpStat) _ANSI_ARGS_((CONST char * path, struct stat * buf)); /* 95 */ + int (*tclProcInterpProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int argc, CONST84 char ** argv)); /* 94 */ + void *reserved95; int (*tclRenameCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * oldName, char * newName)); /* 96 */ void (*tclResetShadowedCmdRefs) _ANSI_ARGS_((Tcl_Interp * interp, Command * newCmdPtr)); /* 97 */ int (*tclServiceIdle) _ANSI_ARGS_((void)); /* 98 */ - Tcl_Obj * (*tclSetElementOfIndexedArray) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * elemPtr, Tcl_Obj * objPtr, int leaveErrorMsg)); /* 99 */ - Tcl_Obj * (*tclSetIndexedScalar) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * objPtr, int leaveErrorMsg)); /* 100 */ + void *reserved99; + void *reserved100; #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ char * (*tclSetPreInitScript) _ANSI_ARGS_((char * string)); /* 101 */ #endif /* UNIX */ @@ -672,43 +644,43 @@ typedef struct TclIntStubs { #ifdef MAC_TCL void *reserved104; #endif /* MAC_TCL */ - int (*tclStat) _ANSI_ARGS_((CONST char * path, struct stat * buf)); /* 105 */ + void *reserved105; int (*tclStatDeleteProc) _ANSI_ARGS_((TclStatProc_ * proc)); /* 106 */ int (*tclStatInsertProc) _ANSI_ARGS_((TclStatProc_ * proc)); /* 107 */ void (*tclTeardownNamespace) _ANSI_ARGS_((Namespace * nsPtr)); /* 108 */ int (*tclUpdateReturnInfo) _ANSI_ARGS_((Interp * iPtr)); /* 109 */ void *reserved110; - void (*tcl_AddInterpResolvers) _ANSI_ARGS_((Tcl_Interp * interp, char * name, Tcl_ResolveCmdProc * cmdProc, Tcl_ResolveVarProc * varProc, Tcl_ResolveCompiledVarProc * compiledVarProc)); /* 111 */ + void (*tcl_AddInterpResolvers) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_ResolveCmdProc * cmdProc, Tcl_ResolveVarProc * varProc, Tcl_ResolveCompiledVarProc * compiledVarProc)); /* 111 */ int (*tcl_AppendExportList) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Namespace * nsPtr, Tcl_Obj * objPtr)); /* 112 */ - Tcl_Namespace * (*tcl_CreateNamespace) _ANSI_ARGS_((Tcl_Interp * interp, char * name, ClientData clientData, Tcl_NamespaceDeleteProc * deleteProc)); /* 113 */ + Tcl_Namespace * (*tcl_CreateNamespace) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, ClientData clientData, Tcl_NamespaceDeleteProc * deleteProc)); /* 113 */ void (*tcl_DeleteNamespace) _ANSI_ARGS_((Tcl_Namespace * nsPtr)); /* 114 */ - int (*tcl_Export) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Namespace * nsPtr, char * pattern, int resetListFirst)); /* 115 */ - Tcl_Command (*tcl_FindCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * name, Tcl_Namespace * contextNsPtr, int flags)); /* 116 */ - Tcl_Namespace * (*tcl_FindNamespace) _ANSI_ARGS_((Tcl_Interp * interp, char * name, Tcl_Namespace * contextNsPtr, int flags)); /* 117 */ - int (*tcl_GetInterpResolvers) _ANSI_ARGS_((Tcl_Interp * interp, char * name, Tcl_ResolverInfo * resInfo)); /* 118 */ + int (*tcl_Export) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Namespace * nsPtr, CONST char * pattern, int resetListFirst)); /* 115 */ + Tcl_Command (*tcl_FindCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_Namespace * contextNsPtr, int flags)); /* 116 */ + Tcl_Namespace * (*tcl_FindNamespace) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_Namespace * contextNsPtr, int flags)); /* 117 */ + int (*tcl_GetInterpResolvers) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_ResolverInfo * resInfo)); /* 118 */ int (*tcl_GetNamespaceResolvers) _ANSI_ARGS_((Tcl_Namespace * namespacePtr, Tcl_ResolverInfo * resInfo)); /* 119 */ - Tcl_Var (*tcl_FindNamespaceVar) _ANSI_ARGS_((Tcl_Interp * interp, char * name, Tcl_Namespace * contextNsPtr, int flags)); /* 120 */ - int (*tcl_ForgetImport) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Namespace * nsPtr, char * pattern)); /* 121 */ + Tcl_Var (*tcl_FindNamespaceVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_Namespace * contextNsPtr, int flags)); /* 120 */ + int (*tcl_ForgetImport) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Namespace * nsPtr, CONST char * pattern)); /* 121 */ Tcl_Command (*tcl_GetCommandFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 122 */ void (*tcl_GetCommandFullName) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command command, Tcl_Obj * objPtr)); /* 123 */ Tcl_Namespace * (*tcl_GetCurrentNamespace) _ANSI_ARGS_((Tcl_Interp * interp)); /* 124 */ Tcl_Namespace * (*tcl_GetGlobalNamespace) _ANSI_ARGS_((Tcl_Interp * interp)); /* 125 */ void (*tcl_GetVariableFullName) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Var variable, Tcl_Obj * objPtr)); /* 126 */ - int (*tcl_Import) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Namespace * nsPtr, char * pattern, int allowOverwrite)); /* 127 */ + int (*tcl_Import) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Namespace * nsPtr, CONST char * pattern, int allowOverwrite)); /* 127 */ void (*tcl_PopCallFrame) _ANSI_ARGS_((Tcl_Interp* interp)); /* 128 */ int (*tcl_PushCallFrame) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_CallFrame * framePtr, Tcl_Namespace * nsPtr, int isProcCallFrame)); /* 129 */ - int (*tcl_RemoveInterpResolvers) _ANSI_ARGS_((Tcl_Interp * interp, char * name)); /* 130 */ + int (*tcl_RemoveInterpResolvers) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name)); /* 130 */ void (*tcl_SetNamespaceResolvers) _ANSI_ARGS_((Tcl_Namespace * namespacePtr, Tcl_ResolveCmdProc * cmdProc, Tcl_ResolveVarProc * varProc, Tcl_ResolveCompiledVarProc * compiledVarProc)); /* 131 */ int (*tclpHasSockets) _ANSI_ARGS_((Tcl_Interp * interp)); /* 132 */ struct tm * (*tclpGetDate) _ANSI_ARGS_((TclpTime_t time, int useGMT)); /* 133 */ - size_t (*tclpStrftime) _ANSI_ARGS_((char * s, size_t maxsize, CONST char * format, CONST struct tm * t)); /* 134 */ + size_t (*tclpStrftime) _ANSI_ARGS_((char * s, size_t maxsize, CONST char * format, CONST struct tm * t, int useGMT)); /* 134 */ int (*tclpCheckStackSpace) _ANSI_ARGS_((void)); /* 135 */ void *reserved136; - int (*tclpChdir) _ANSI_ARGS_((CONST char * dirName)); /* 137 */ - char * (*tclGetEnv) _ANSI_ARGS_((CONST char * name, Tcl_DString * valuePtr)); /* 138 */ - int (*tclpLoadFile) _ANSI_ARGS_((Tcl_Interp * interp, char * fileName, char * sym1, char * sym2, Tcl_PackageInitProc ** proc1Ptr, Tcl_PackageInitProc ** proc2Ptr, ClientData * clientDataPtr)); /* 139 */ - int (*tclLooksLikeInt) _ANSI_ARGS_((char * bytes, int length)); /* 140 */ - char * (*tclpGetCwd) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * cwdPtr)); /* 141 */ + void *reserved137; + CONST84_RETURN char * (*tclGetEnv) _ANSI_ARGS_((CONST char * name, Tcl_DString * valuePtr)); /* 138 */ + void *reserved139; + int (*tclLooksLikeInt) _ANSI_ARGS_((CONST char * bytes, int length)); /* 140 */ + CONST84_RETURN char * (*tclpGetCwd) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * cwdPtr)); /* 141 */ int (*tclSetByteCodeFromAny) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, CompileHookProc * hookProc, ClientData clientData)); /* 142 */ int (*tclAddLiteralObj) _ANSI_ARGS_((struct CompileEnv * envPtr, Tcl_Obj * objPtr, LiteralEntry ** litPtrPtr)); /* 143 */ void (*tclHideLiteral) _ANSI_ARGS_((Tcl_Interp * interp, struct CompileEnv * envPtr, int index)); /* 144 */ @@ -723,13 +695,22 @@ typedef struct TclIntStubs { Tcl_Obj * (*tclGetLibraryPath) _ANSI_ARGS_((void)); /* 153 */ void *reserved154; void *reserved155; - void (*tclRegError) _ANSI_ARGS_((Tcl_Interp * interp, char * msg, int status)); /* 156 */ - Var * (*tclVarTraceExists) _ANSI_ARGS_((Tcl_Interp * interp, char * varName)); /* 157 */ - void (*tclSetStartupScriptFileName) _ANSI_ARGS_((char * filename)); /* 158 */ - char * (*tclGetStartupScriptFileName) _ANSI_ARGS_((void)); /* 159 */ - int (*tclpMatchFilesTypes) _ANSI_ARGS_((Tcl_Interp * interp, char * separators, Tcl_DString * dirPtr, char * pattern, char * tail, GlobTypeData * types)); /* 160 */ + void (*tclRegError) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * msg, int status)); /* 156 */ + Var * (*tclVarTraceExists) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName)); /* 157 */ + void (*tclSetStartupScriptFileName) _ANSI_ARGS_((CONST char * filename)); /* 158 */ + CONST84_RETURN char * (*tclGetStartupScriptFileName) _ANSI_ARGS_((void)); /* 159 */ + void *reserved160; int (*tclChannelTransform) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, Tcl_Obj * cmdObjPtr)); /* 161 */ void (*tclChannelEventScriptInvoker) _ANSI_ARGS_((ClientData clientData, int flags)); /* 162 */ + void * (*tclGetInstructionTable) _ANSI_ARGS_((void)); /* 163 */ + void (*tclExpandCodeArray) _ANSI_ARGS_((void * envPtr)); /* 164 */ + void (*tclpSetInitialEncodings) _ANSI_ARGS_((void)); /* 165 */ + int (*tclListObjSetElement) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, int index, Tcl_Obj * valuePtr)); /* 166 */ + void (*tclSetStartupScriptPath) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 167 */ + Tcl_Obj * (*tclGetStartupScriptPath) _ANSI_ARGS_((void)); /* 168 */ + int (*tclpUtfNcmp2) _ANSI_ARGS_((CONST char * s1, CONST char * s2, unsigned long n)); /* 169 */ + int (*tclCheckInterpTraces) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * command, int numChars, Command * cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *CONST objv[])); /* 170 */ + int (*tclCheckExecutionTraces) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * command, int numChars, Command * cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *CONST objv[])); /* 171 */ } TclIntStubs; #ifdef __cplusplus @@ -746,10 +727,7 @@ extern TclIntStubs *tclIntStubsPtr; * Inline function declarations: */ -#ifndef TclAccess -#define TclAccess \ - (tclIntStubsPtr->tclAccess) /* 0 */ -#endif +/* Slot 0 is reserved */ #ifndef TclAccessDeleteProc #define TclAccessDeleteProc \ (tclIntStubsPtr->tclAccessDeleteProc) /* 1 */ @@ -824,26 +802,11 @@ extern TclIntStubs *tclIntStubsPtr; #define TclExprFloatError \ (tclIntStubsPtr->tclExprFloatError) /* 16 */ #endif -#ifndef TclFileAttrsCmd -#define TclFileAttrsCmd \ - (tclIntStubsPtr->tclFileAttrsCmd) /* 17 */ -#endif -#ifndef TclFileCopyCmd -#define TclFileCopyCmd \ - (tclIntStubsPtr->tclFileCopyCmd) /* 18 */ -#endif -#ifndef TclFileDeleteCmd -#define TclFileDeleteCmd \ - (tclIntStubsPtr->tclFileDeleteCmd) /* 19 */ -#endif -#ifndef TclFileMakeDirsCmd -#define TclFileMakeDirsCmd \ - (tclIntStubsPtr->tclFileMakeDirsCmd) /* 20 */ -#endif -#ifndef TclFileRenameCmd -#define TclFileRenameCmd \ - (tclIntStubsPtr->tclFileRenameCmd) /* 21 */ -#endif +/* Slot 17 is reserved */ +/* Slot 18 is reserved */ +/* Slot 19 is reserved */ +/* Slot 20 is reserved */ +/* Slot 21 is reserved */ #ifndef TclFindElement #define TclFindElement \ (tclIntStubsPtr->tclFindElement) /* 22 */ @@ -869,10 +832,7 @@ extern TclIntStubs *tclIntStubsPtr; #define TclpGetDefaultStdChannel \ (tclIntStubsPtr->tclpGetDefaultStdChannel) /* 28 */ #endif -#ifndef TclGetElementOfIndexedArray -#define TclGetElementOfIndexedArray \ - (tclIntStubsPtr->tclGetElementOfIndexedArray) /* 29 */ -#endif +/* Slot 29 is reserved */ /* Slot 30 is reserved */ #ifndef TclGetExtension #define TclGetExtension \ @@ -890,10 +850,7 @@ extern TclIntStubs *tclIntStubsPtr; #define TclGetIntForIndex \ (tclIntStubsPtr->tclGetIntForIndex) /* 34 */ #endif -#ifndef TclGetIndexedScalar -#define TclGetIndexedScalar \ - (tclIntStubsPtr->tclGetIndexedScalar) /* 35 */ -#endif +/* Slot 35 is reserved */ #ifndef TclGetLong #define TclGetLong \ (tclIntStubsPtr->tclGetLong) /* 36 */ @@ -938,14 +895,8 @@ extern TclIntStubs *tclIntStubsPtr; #define TclInExit \ (tclIntStubsPtr->tclInExit) /* 46 */ #endif -#ifndef TclIncrElementOfIndexedArray -#define TclIncrElementOfIndexedArray \ - (tclIntStubsPtr->tclIncrElementOfIndexedArray) /* 47 */ -#endif -#ifndef TclIncrIndexedScalar -#define TclIncrIndexedScalar \ - (tclIntStubsPtr->tclIncrIndexedScalar) /* 48 */ -#endif +/* Slot 47 is reserved */ +/* Slot 48 is reserved */ #ifndef TclIncrVar2 #define TclIncrVar2 \ (tclIntStubsPtr->tclIncrVar2) /* 49 */ @@ -980,10 +931,7 @@ extern TclIntStubs *tclIntStubsPtr; #define TclLookupVar \ (tclIntStubsPtr->tclLookupVar) /* 58 */ #endif -#ifndef TclpMatchFiles -#define TclpMatchFiles \ - (tclIntStubsPtr->tclpMatchFiles) /* 59 */ -#endif +/* Slot 59 is reserved */ #ifndef TclNeedSpace #define TclNeedSpace \ (tclIntStubsPtr->tclNeedSpace) /* 60 */ @@ -1016,30 +964,15 @@ extern TclIntStubs *tclIntStubsPtr; #define TclOpenFileChannelInsertProc \ (tclIntStubsPtr->tclOpenFileChannelInsertProc) /* 67 */ #endif -#ifndef TclpAccess -#define TclpAccess \ - (tclIntStubsPtr->tclpAccess) /* 68 */ -#endif +/* Slot 68 is reserved */ #ifndef TclpAlloc #define TclpAlloc \ (tclIntStubsPtr->tclpAlloc) /* 69 */ #endif -#ifndef TclpCopyFile -#define TclpCopyFile \ - (tclIntStubsPtr->tclpCopyFile) /* 70 */ -#endif -#ifndef TclpCopyDirectory -#define TclpCopyDirectory \ - (tclIntStubsPtr->tclpCopyDirectory) /* 71 */ -#endif -#ifndef TclpCreateDirectory -#define TclpCreateDirectory \ - (tclIntStubsPtr->tclpCreateDirectory) /* 72 */ -#endif -#ifndef TclpDeleteFile -#define TclpDeleteFile \ - (tclIntStubsPtr->tclpDeleteFile) /* 73 */ -#endif +/* Slot 70 is reserved */ +/* Slot 71 is reserved */ +/* Slot 72 is reserved */ +/* Slot 73 is reserved */ #ifndef TclpFree #define TclpFree \ (tclIntStubsPtr->tclpFree) /* 74 */ @@ -1060,26 +993,14 @@ extern TclIntStubs *tclIntStubsPtr; #define TclpGetTimeZone \ (tclIntStubsPtr->tclpGetTimeZone) /* 78 */ #endif -#ifndef TclpListVolumes -#define TclpListVolumes \ - (tclIntStubsPtr->tclpListVolumes) /* 79 */ -#endif -#ifndef TclpOpenFileChannel -#define TclpOpenFileChannel \ - (tclIntStubsPtr->tclpOpenFileChannel) /* 80 */ -#endif +/* Slot 79 is reserved */ +/* Slot 80 is reserved */ #ifndef TclpRealloc #define TclpRealloc \ (tclIntStubsPtr->tclpRealloc) /* 81 */ #endif -#ifndef TclpRemoveDirectory -#define TclpRemoveDirectory \ - (tclIntStubsPtr->tclpRemoveDirectory) /* 82 */ -#endif -#ifndef TclpRenameFile -#define TclpRenameFile \ - (tclIntStubsPtr->tclpRenameFile) /* 83 */ -#endif +/* Slot 82 is reserved */ +/* Slot 83 is reserved */ /* Slot 84 is reserved */ /* Slot 85 is reserved */ /* Slot 86 is reserved */ @@ -1109,10 +1030,7 @@ extern TclIntStubs *tclIntStubsPtr; #define TclProcInterpProc \ (tclIntStubsPtr->tclProcInterpProc) /* 94 */ #endif -#ifndef TclpStat -#define TclpStat \ - (tclIntStubsPtr->tclpStat) /* 95 */ -#endif +/* Slot 95 is reserved */ #ifndef TclRenameCommand #define TclRenameCommand \ (tclIntStubsPtr->tclRenameCommand) /* 96 */ @@ -1125,14 +1043,8 @@ extern TclIntStubs *tclIntStubsPtr; #define TclServiceIdle \ (tclIntStubsPtr->tclServiceIdle) /* 98 */ #endif -#ifndef TclSetElementOfIndexedArray -#define TclSetElementOfIndexedArray \ - (tclIntStubsPtr->tclSetElementOfIndexedArray) /* 99 */ -#endif -#ifndef TclSetIndexedScalar -#define TclSetIndexedScalar \ - (tclIntStubsPtr->tclSetIndexedScalar) /* 100 */ -#endif +/* Slot 99 is reserved */ +/* Slot 100 is reserved */ #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ #ifndef TclSetPreInitScript #define TclSetPreInitScript \ @@ -1165,10 +1077,7 @@ extern TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclSockMinimumBuffers) /* 104 */ #endif #endif /* __WIN32__ */ -#ifndef TclStat -#define TclStat \ - (tclIntStubsPtr->tclStat) /* 105 */ -#endif +/* Slot 105 is reserved */ #ifndef TclStatDeleteProc #define TclStatDeleteProc \ (tclIntStubsPtr->tclStatDeleteProc) /* 106 */ @@ -1287,18 +1196,12 @@ extern TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclpCheckStackSpace) /* 135 */ #endif /* Slot 136 is reserved */ -#ifndef TclpChdir -#define TclpChdir \ - (tclIntStubsPtr->tclpChdir) /* 137 */ -#endif +/* Slot 137 is reserved */ #ifndef TclGetEnv #define TclGetEnv \ (tclIntStubsPtr->tclGetEnv) /* 138 */ #endif -#ifndef TclpLoadFile -#define TclpLoadFile \ - (tclIntStubsPtr->tclpLoadFile) /* 139 */ -#endif +/* Slot 139 is reserved */ #ifndef TclLooksLikeInt #define TclLooksLikeInt \ (tclIntStubsPtr->tclLooksLikeInt) /* 140 */ @@ -1373,10 +1276,7 @@ extern TclIntStubs *tclIntStubsPtr; #define TclGetStartupScriptFileName \ (tclIntStubsPtr->tclGetStartupScriptFileName) /* 159 */ #endif -#ifndef TclpMatchFilesTypes -#define TclpMatchFilesTypes \ - (tclIntStubsPtr->tclpMatchFilesTypes) /* 160 */ -#endif +/* Slot 160 is reserved */ #ifndef TclChannelTransform #define TclChannelTransform \ (tclIntStubsPtr->tclChannelTransform) /* 161 */ @@ -1385,10 +1285,45 @@ extern TclIntStubs *tclIntStubsPtr; #define TclChannelEventScriptInvoker \ (tclIntStubsPtr->tclChannelEventScriptInvoker) /* 162 */ #endif +#ifndef TclGetInstructionTable +#define TclGetInstructionTable \ + (tclIntStubsPtr->tclGetInstructionTable) /* 163 */ +#endif +#ifndef TclExpandCodeArray +#define TclExpandCodeArray \ + (tclIntStubsPtr->tclExpandCodeArray) /* 164 */ +#endif +#ifndef TclpSetInitialEncodings +#define TclpSetInitialEncodings \ + (tclIntStubsPtr->tclpSetInitialEncodings) /* 165 */ +#endif +#ifndef TclListObjSetElement +#define TclListObjSetElement \ + (tclIntStubsPtr->tclListObjSetElement) /* 166 */ +#endif +#ifndef TclSetStartupScriptPath +#define TclSetStartupScriptPath \ + (tclIntStubsPtr->tclSetStartupScriptPath) /* 167 */ +#endif +#ifndef TclGetStartupScriptPath +#define TclGetStartupScriptPath \ + (tclIntStubsPtr->tclGetStartupScriptPath) /* 168 */ +#endif +#ifndef TclpUtfNcmp2 +#define TclpUtfNcmp2 \ + (tclIntStubsPtr->tclpUtfNcmp2) /* 169 */ +#endif +#ifndef TclCheckInterpTraces +#define TclCheckInterpTraces \ + (tclIntStubsPtr->tclCheckInterpTraces) /* 170 */ +#endif +#ifndef TclCheckExecutionTraces +#define TclCheckExecutionTraces \ + (tclIntStubsPtr->tclCheckExecutionTraces) /* 171 */ +#endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ /* !END!: Do not edit above this line. */ #endif /* _TCLINTDECLS */ - diff --git a/tcl/generic/tclIntPlatDecls.h b/tcl/generic/tclIntPlatDecls.h index b985bb0987e..fb6f7d1c90c 100644 --- a/tcl/generic/tclIntPlatDecls.h +++ b/tcl/generic/tclIntPlatDecls.h @@ -43,9 +43,9 @@ EXTERN int TclpCreatePipe _ANSI_ARGS_((TclFile * readPipe, TclFile * writePipe)); /* 4 */ EXTERN int TclpCreateProcess _ANSI_ARGS_((Tcl_Interp * interp, - int argc, char ** argv, TclFile inputFile, - TclFile outputFile, TclFile errorFile, - Tcl_Pid * pidPtr)); + int argc, CONST char ** argv, + TclFile inputFile, TclFile outputFile, + TclFile errorFile, Tcl_Pid * pidPtr)); /* Slot 5 is reserved */ /* 6 */ EXTERN TclFile TclpMakeFile _ANSI_ARGS_((Tcl_Channel channel, @@ -59,6 +59,14 @@ EXTERN int TclUnixWaitForFile _ANSI_ARGS_((int fd, int mask, /* 9 */ EXTERN TclFile TclpCreateTempFile _ANSI_ARGS_(( CONST char * contents)); +/* 10 */ +EXTERN Tcl_DirEntry * TclpReaddir _ANSI_ARGS_((DIR * dir)); +/* 11 */ +EXTERN struct tm * TclpLocaltime _ANSI_ARGS_((time_t * clock)); +/* 12 */ +EXTERN struct tm * TclpGmtime _ANSI_ARGS_((time_t * clock)); +/* 13 */ +EXTERN char * TclpInetNtoa _ANSI_ARGS_((struct in_addr addr)); #endif /* UNIX */ #ifdef __WIN32__ /* 0 */ @@ -101,9 +109,9 @@ EXTERN int TclpCreatePipe _ANSI_ARGS_((TclFile * readPipe, TclFile * writePipe)); /* 15 */ EXTERN int TclpCreateProcess _ANSI_ARGS_((Tcl_Interp * interp, - int argc, char ** argv, TclFile inputFile, - TclFile outputFile, TclFile errorFile, - Tcl_Pid * pidPtr)); + int argc, CONST char ** argv, + TclFile inputFile, TclFile outputFile, + TclFile errorFile, Tcl_Pid * pidPtr)); /* Slot 16 is reserved */ /* Slot 17 is reserved */ /* 18 */ @@ -115,8 +123,7 @@ EXTERN TclFile TclpOpenFile _ANSI_ARGS_((CONST char * fname, /* 20 */ EXTERN void TclWinAddProcess _ANSI_ARGS_((HANDLE hProcess, DWORD id)); -/* 21 */ -EXTERN void TclpAsyncMark _ANSI_ARGS_((Tcl_AsyncHandler async)); +/* Slot 21 is reserved */ /* 22 */ EXTERN TclFile TclpCreateTempFile _ANSI_ARGS_(( CONST char * contents)); @@ -128,6 +135,8 @@ EXTERN char * TclWinNoBackslash _ANSI_ARGS_((char * path)); EXTERN TclPlatformType * TclWinGetPlatform _ANSI_ARGS_((void)); /* 26 */ EXTERN void TclWinSetInterfaces _ANSI_ARGS_((int wide)); +/* 27 */ +EXTERN void TclWinFlushDirtyChannels _ANSI_ARGS_((void)); #endif /* __WIN32__ */ #ifdef MAC_TCL /* 0 */ @@ -148,15 +157,16 @@ EXTERN OSErr FSpFindFolder _ANSI_ARGS_((short vRefNum, OSType folderType, Boolean createFolder, FSSpec * spec)); /* 7 */ -EXTERN void GetGlobalMouse _ANSI_ARGS_((Point * mouse)); +EXTERN void GetGlobalMouseTcl _ANSI_ARGS_((Point * mouse)); /* 8 */ -EXTERN pascal OSErr FSpGetDirectoryID _ANSI_ARGS_((CONST FSSpec * spec, - long * theDirID, Boolean * isDirectory)); +EXTERN pascal OSErr FSpGetDirectoryIDTcl _ANSI_ARGS_(( + CONST FSSpec * spec, long * theDirID, + Boolean * isDirectory)); /* 9 */ -EXTERN pascal short FSpOpenResFileCompat _ANSI_ARGS_(( +EXTERN pascal short FSpOpenResFileCompatTcl _ANSI_ARGS_(( CONST FSSpec * spec, SignedByte permission)); /* 10 */ -EXTERN pascal void FSpCreateResFileCompat _ANSI_ARGS_(( +EXTERN pascal void FSpCreateResFileCompatTcl _ANSI_ARGS_(( CONST FSSpec * spec, OSType creator, OSType fileType, ScriptCode scriptTag)); /* 11 */ @@ -192,9 +202,13 @@ EXTERN int TclMacCreateEnv _ANSI_ARGS_((void)); /* 23 */ EXTERN FILE * TclMacFOpenHack _ANSI_ARGS_((CONST char * path, CONST char * mode)); -/* Slot 24 is reserved */ +/* 24 */ +EXTERN char * TclpGetTZName _ANSI_ARGS_((int isdst)); /* 25 */ -EXTERN int TclMacChmod _ANSI_ARGS_((char * path, int mode)); +EXTERN int TclMacChmod _ANSI_ARGS_((CONST char * path, int mode)); +/* 26 */ +EXTERN int FSpLLocationFromPath _ANSI_ARGS_((int length, + CONST char * path, FSSpecPtr theSpec)); #endif /* MAC_TCL */ typedef struct TclIntPlatStubs { @@ -206,12 +220,16 @@ typedef struct TclIntPlatStubs { int (*tclpCloseFile) _ANSI_ARGS_((TclFile file)); /* 1 */ Tcl_Channel (*tclpCreateCommandChannel) _ANSI_ARGS_((TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid * pidPtr)); /* 2 */ int (*tclpCreatePipe) _ANSI_ARGS_((TclFile * readPipe, TclFile * writePipe)); /* 3 */ - int (*tclpCreateProcess) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid * pidPtr)); /* 4 */ + int (*tclpCreateProcess) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST char ** argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid * pidPtr)); /* 4 */ void *reserved5; TclFile (*tclpMakeFile) _ANSI_ARGS_((Tcl_Channel channel, int direction)); /* 6 */ TclFile (*tclpOpenFile) _ANSI_ARGS_((CONST char * fname, int mode)); /* 7 */ int (*tclUnixWaitForFile) _ANSI_ARGS_((int fd, int mask, int timeout)); /* 8 */ TclFile (*tclpCreateTempFile) _ANSI_ARGS_((CONST char * contents)); /* 9 */ + Tcl_DirEntry * (*tclpReaddir) _ANSI_ARGS_((DIR * dir)); /* 10 */ + struct tm * (*tclpLocaltime) _ANSI_ARGS_((time_t * clock)); /* 11 */ + struct tm * (*tclpGmtime) _ANSI_ARGS_((time_t * clock)); /* 12 */ + char * (*tclpInetNtoa) _ANSI_ARGS_((struct in_addr addr)); /* 13 */ #endif /* UNIX */ #ifdef __WIN32__ void (*tclWinConvertError) _ANSI_ARGS_((DWORD errCode)); /* 0 */ @@ -229,18 +247,19 @@ typedef struct TclIntPlatStubs { int (*tclpCloseFile) _ANSI_ARGS_((TclFile file)); /* 12 */ Tcl_Channel (*tclpCreateCommandChannel) _ANSI_ARGS_((TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid * pidPtr)); /* 13 */ int (*tclpCreatePipe) _ANSI_ARGS_((TclFile * readPipe, TclFile * writePipe)); /* 14 */ - int (*tclpCreateProcess) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid * pidPtr)); /* 15 */ + int (*tclpCreateProcess) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST char ** argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid * pidPtr)); /* 15 */ void *reserved16; void *reserved17; TclFile (*tclpMakeFile) _ANSI_ARGS_((Tcl_Channel channel, int direction)); /* 18 */ TclFile (*tclpOpenFile) _ANSI_ARGS_((CONST char * fname, int mode)); /* 19 */ void (*tclWinAddProcess) _ANSI_ARGS_((HANDLE hProcess, DWORD id)); /* 20 */ - void (*tclpAsyncMark) _ANSI_ARGS_((Tcl_AsyncHandler async)); /* 21 */ + void *reserved21; TclFile (*tclpCreateTempFile) _ANSI_ARGS_((CONST char * contents)); /* 22 */ char * (*tclpGetTZName) _ANSI_ARGS_((int isdst)); /* 23 */ char * (*tclWinNoBackslash) _ANSI_ARGS_((char * path)); /* 24 */ TclPlatformType * (*tclWinGetPlatform) _ANSI_ARGS_((void)); /* 25 */ void (*tclWinSetInterfaces) _ANSI_ARGS_((int wide)); /* 26 */ + void (*tclWinFlushDirtyChannels) _ANSI_ARGS_((void)); /* 27 */ #endif /* __WIN32__ */ #ifdef MAC_TCL VOID * (*tclpSysAlloc) _ANSI_ARGS_((long size, int isBin)); /* 0 */ @@ -250,10 +269,10 @@ typedef struct TclIntPlatStubs { int (*fSpGetDefaultDir) _ANSI_ARGS_((FSSpecPtr theSpec)); /* 4 */ int (*fSpSetDefaultDir) _ANSI_ARGS_((FSSpecPtr theSpec)); /* 5 */ OSErr (*fSpFindFolder) _ANSI_ARGS_((short vRefNum, OSType folderType, Boolean createFolder, FSSpec * spec)); /* 6 */ - void (*getGlobalMouse) _ANSI_ARGS_((Point * mouse)); /* 7 */ - pascal OSErr (*fSpGetDirectoryID) _ANSI_ARGS_((CONST FSSpec * spec, long * theDirID, Boolean * isDirectory)); /* 8 */ - pascal short (*fSpOpenResFileCompat) _ANSI_ARGS_((CONST FSSpec * spec, SignedByte permission)); /* 9 */ - pascal void (*fSpCreateResFileCompat) _ANSI_ARGS_((CONST FSSpec * spec, OSType creator, OSType fileType, ScriptCode scriptTag)); /* 10 */ + void (*getGlobalMouseTcl) _ANSI_ARGS_((Point * mouse)); /* 7 */ + pascal OSErr (*fSpGetDirectoryIDTcl) _ANSI_ARGS_((CONST FSSpec * spec, long * theDirID, Boolean * isDirectory)); /* 8 */ + pascal short (*fSpOpenResFileCompatTcl) _ANSI_ARGS_((CONST FSSpec * spec, SignedByte permission)); /* 9 */ + pascal void (*fSpCreateResFileCompatTcl) _ANSI_ARGS_((CONST FSSpec * spec, OSType creator, OSType fileType, ScriptCode scriptTag)); /* 10 */ int (*fSpLocationFromPath) _ANSI_ARGS_((int length, CONST char * path, FSSpecPtr theSpec)); /* 11 */ OSErr (*fSpPathFromLocation) _ANSI_ARGS_((FSSpecPtr theSpec, int * length, Handle * fullPath)); /* 12 */ void (*tclMacExitHandler) _ANSI_ARGS_((void)); /* 13 */ @@ -267,8 +286,9 @@ typedef struct TclIntPlatStubs { short (*tclMacUnRegisterResourceFork) _ANSI_ARGS_((char * tokenPtr, Tcl_Obj * resultPtr)); /* 21 */ int (*tclMacCreateEnv) _ANSI_ARGS_((void)); /* 22 */ FILE * (*tclMacFOpenHack) _ANSI_ARGS_((CONST char * path, CONST char * mode)); /* 23 */ - void *reserved24; - int (*tclMacChmod) _ANSI_ARGS_((char * path, int mode)); /* 25 */ + char * (*tclpGetTZName) _ANSI_ARGS_((int isdst)); /* 24 */ + int (*tclMacChmod) _ANSI_ARGS_((CONST char * path, int mode)); /* 25 */ + int (*fSpLLocationFromPath) _ANSI_ARGS_((int length, CONST char * path, FSSpecPtr theSpec)); /* 26 */ #endif /* MAC_TCL */ } TclIntPlatStubs; @@ -324,6 +344,22 @@ extern TclIntPlatStubs *tclIntPlatStubsPtr; #define TclpCreateTempFile \ (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ #endif +#ifndef TclpReaddir +#define TclpReaddir \ + (tclIntPlatStubsPtr->tclpReaddir) /* 10 */ +#endif +#ifndef TclpLocaltime +#define TclpLocaltime \ + (tclIntPlatStubsPtr->tclpLocaltime) /* 11 */ +#endif +#ifndef TclpGmtime +#define TclpGmtime \ + (tclIntPlatStubsPtr->tclpGmtime) /* 12 */ +#endif +#ifndef TclpInetNtoa +#define TclpInetNtoa \ + (tclIntPlatStubsPtr->tclpInetNtoa) /* 13 */ +#endif #endif /* UNIX */ #ifdef __WIN32__ #ifndef TclWinConvertError @@ -398,10 +434,7 @@ extern TclIntPlatStubs *tclIntPlatStubsPtr; #define TclWinAddProcess \ (tclIntPlatStubsPtr->tclWinAddProcess) /* 20 */ #endif -#ifndef TclpAsyncMark -#define TclpAsyncMark \ - (tclIntPlatStubsPtr->tclpAsyncMark) /* 21 */ -#endif +/* Slot 21 is reserved */ #ifndef TclpCreateTempFile #define TclpCreateTempFile \ (tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */ @@ -422,6 +455,10 @@ extern TclIntPlatStubs *tclIntPlatStubsPtr; #define TclWinSetInterfaces \ (tclIntPlatStubsPtr->tclWinSetInterfaces) /* 26 */ #endif +#ifndef TclWinFlushDirtyChannels +#define TclWinFlushDirtyChannels \ + (tclIntPlatStubsPtr->tclWinFlushDirtyChannels) /* 27 */ +#endif #endif /* __WIN32__ */ #ifdef MAC_TCL #ifndef TclpSysAlloc @@ -452,21 +489,21 @@ extern TclIntPlatStubs *tclIntPlatStubsPtr; #define FSpFindFolder \ (tclIntPlatStubsPtr->fSpFindFolder) /* 6 */ #endif -#ifndef GetGlobalMouse -#define GetGlobalMouse \ - (tclIntPlatStubsPtr->getGlobalMouse) /* 7 */ +#ifndef GetGlobalMouseTcl +#define GetGlobalMouseTcl \ + (tclIntPlatStubsPtr->getGlobalMouseTcl) /* 7 */ #endif -#ifndef FSpGetDirectoryID -#define FSpGetDirectoryID \ - (tclIntPlatStubsPtr->fSpGetDirectoryID) /* 8 */ +#ifndef FSpGetDirectoryIDTcl +#define FSpGetDirectoryIDTcl \ + (tclIntPlatStubsPtr->fSpGetDirectoryIDTcl) /* 8 */ #endif -#ifndef FSpOpenResFileCompat -#define FSpOpenResFileCompat \ - (tclIntPlatStubsPtr->fSpOpenResFileCompat) /* 9 */ +#ifndef FSpOpenResFileCompatTcl +#define FSpOpenResFileCompatTcl \ + (tclIntPlatStubsPtr->fSpOpenResFileCompatTcl) /* 9 */ #endif -#ifndef FSpCreateResFileCompat -#define FSpCreateResFileCompat \ - (tclIntPlatStubsPtr->fSpCreateResFileCompat) /* 10 */ +#ifndef FSpCreateResFileCompatTcl +#define FSpCreateResFileCompatTcl \ + (tclIntPlatStubsPtr->fSpCreateResFileCompatTcl) /* 10 */ #endif #ifndef FSpLocationFromPath #define FSpLocationFromPath \ @@ -520,11 +557,18 @@ extern TclIntPlatStubs *tclIntPlatStubsPtr; #define TclMacFOpenHack \ (tclIntPlatStubsPtr->tclMacFOpenHack) /* 23 */ #endif -/* Slot 24 is reserved */ +#ifndef TclpGetTZName +#define TclpGetTZName \ + (tclIntPlatStubsPtr->tclpGetTZName) /* 24 */ +#endif #ifndef TclMacChmod #define TclMacChmod \ (tclIntPlatStubsPtr->tclMacChmod) /* 25 */ #endif +#ifndef FSpLLocationFromPath +#define FSpLLocationFromPath \ + (tclIntPlatStubsPtr->fSpLLocationFromPath) /* 26 */ +#endif #endif /* MAC_TCL */ #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ @@ -532,4 +576,3 @@ extern TclIntPlatStubs *tclIntPlatStubsPtr; /* !END!: Do not edit above this line. */ #endif /* _TCLINTPLATDECLS */ - diff --git a/tcl/generic/tclInterp.c b/tcl/generic/tclInterp.c index 96d2e27d418..f8626b5773c 100644 --- a/tcl/generic/tclInterp.c +++ b/tcl/generic/tclInterp.c @@ -12,9 +12,9 @@ * RCS: @(#) $Id$ */ -#include <stdio.h> #include "tclInt.h" #include "tclPort.h" +#include <stdio.h> /* * Counter for how many aliases were created (global) @@ -35,12 +35,6 @@ typedef struct Alias { Tcl_Obj *namePtr; /* Name of alias command in slave interp. */ Tcl_Interp *targetInterp; /* Interp in which target command will be * invoked. */ - Tcl_Obj *prefixPtr; /* Tcl list making up the prefix of the - * target command to be invoked in the target - * interpreter. Additional arguments - * specified when calling the alias in the - * slave interp will be appended to the prefix - * before the command is invoked. */ Tcl_Command slaveCmd; /* Source command in slave interpreter, * bound to command that invokes the target * command in the target interpreter. */ @@ -56,6 +50,16 @@ typedef struct Alias { * redirecting to it. Random access to this * hash table is never required - we are using * a hash table only for convenience. */ + int objc; /* Count of Tcl_Obj in the prefix of the + * target command to be invoked in the + * target interpreter. Additional arguments + * specified when calling the alias in the + * slave interp will be appended to the prefix + * before the command is invoked. */ + Tcl_Obj *objPtr; /* The first actual prefix object - the target + * command name; this has to be at the end of the + * structure, which will be extended to accomodate + * the remaining objects in the prefix. */ } Alias; /* @@ -190,6 +194,10 @@ static int SlaveObjCmd _ANSI_ARGS_((ClientData dummy, Tcl_Obj *CONST objv[])); static void SlaveObjCmdDeleteProc _ANSI_ARGS_(( ClientData clientData)); +static int SlaveRecursionLimit _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Interp *slaveInterp, int objc, + Tcl_Obj *CONST objv[])); + /* *--------------------------------------------------------------------------- @@ -347,18 +355,20 @@ Tcl_InterpObjCmd(clientData, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { int index; - static char *options[] = { + static CONST char *options[] = { "alias", "aliases", "create", "delete", "eval", "exists", "expose", "hide", "hidden", "issafe", "invokehidden", "marktrusted", - "slaves", "share", "target", "transfer", + "recursionlimit", "slaves", "share", + "target", "transfer", NULL }; enum option { OPT_ALIAS, OPT_ALIASES, OPT_CREATE, OPT_DELETE, OPT_EVAL, OPT_EXISTS, OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHID, OPT_MARKTRUSTED, - OPT_SLAVES, OPT_SHARE, OPT_TARGET, OPT_TRANSFER + OPT_RECLIMIT, OPT_SLAVES, OPT_SHARE, + OPT_TARGET, OPT_TRANSFER }; @@ -419,7 +429,7 @@ Tcl_InterpObjCmd(clientData, interp, objc, objv) int i, last, safe; Tcl_Obj *slavePtr; char buf[16 + TCL_INTEGER_SPACE]; - static char *options[] = { + static CONST char *options[] = { "-safe", "--", NULL }; enum option { @@ -582,7 +592,7 @@ Tcl_InterpObjCmd(clientData, interp, objc, objv) case OPT_INVOKEHID: { int i, index, global; Tcl_Interp *slaveInterp; - static char *hiddenOptions[] = { + static CONST char *hiddenOptions[] = { "-global", "--", NULL }; enum hiddenOption { @@ -630,6 +640,19 @@ Tcl_InterpObjCmd(clientData, interp, objc, objv) } return SlaveMarkTrusted(interp, slaveInterp); } + case OPT_RECLIMIT: { + Tcl_Interp *slaveInterp; + + if (objc != 3 && objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "path ?newlimit?"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return SlaveRecursionLimit(interp, slaveInterp, objc - 3, objv + 3); + } case OPT_SLAVES: { Tcl_Interp *slaveInterp; InterpInfo *iiPtr; @@ -808,11 +831,11 @@ GetInterp2(interp, objc, objv) int Tcl_CreateAlias(slaveInterp, slaveCmd, targetInterp, targetCmd, argc, argv) Tcl_Interp *slaveInterp; /* Interpreter for source command. */ - char *slaveCmd; /* Command to install in slave. */ + CONST char *slaveCmd; /* Command to install in slave. */ Tcl_Interp *targetInterp; /* Interpreter for target command. */ - char *targetCmd; /* Name of target command. */ + CONST char *targetCmd; /* Name of target command. */ int argc; /* How many additional arguments? */ - char **argv; /* These are the additional args. */ + CONST char * CONST *argv; /* These are the additional args. */ { Tcl_Obj *slaveObjPtr, *targetObjPtr; Tcl_Obj **objv; @@ -863,9 +886,9 @@ Tcl_CreateAlias(slaveInterp, slaveCmd, targetInterp, targetCmd, argc, argv) int Tcl_CreateAliasObj(slaveInterp, slaveCmd, targetInterp, targetCmd, objc, objv) Tcl_Interp *slaveInterp; /* Interpreter for source command. */ - char *slaveCmd; /* Command to install in slave. */ + CONST char *slaveCmd; /* Command to install in slave. */ Tcl_Interp *targetInterp; /* Interpreter for target command. */ - char *targetCmd; /* Name of target command. */ + CONST char *targetCmd; /* Name of target command. */ int objc; /* How many additional arguments? */ Tcl_Obj *CONST objv[]; /* Argument vector. */ { @@ -906,11 +929,11 @@ int Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr, argvPtr) Tcl_Interp *interp; /* Interp to start search from. */ - char *aliasName; /* Name of alias to find. */ + CONST char *aliasName; /* Name of alias to find. */ Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */ - char **targetNamePtr; /* (Return) name of target command. */ + CONST char **targetNamePtr; /* (Return) name of target command. */ int *argcPtr; /* (Return) count of addnl args. */ - char ***argvPtr; /* (Return) additional arguments. */ + CONST char ***argvPtr; /* (Return) additional arguments. */ { InterpInfo *iiPtr; Tcl_HashEntry *hPtr; @@ -926,7 +949,8 @@ Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr, return TCL_ERROR; } aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); - Tcl_ListObjGetElements(NULL, aliasPtr->prefixPtr, &objc, &objv); + objc = aliasPtr->objc; + objv = &aliasPtr->objPtr; if (targetInterpPtr != NULL) { *targetInterpPtr = aliasPtr->targetInterp; @@ -938,7 +962,8 @@ Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr, *argcPtr = objc - 1; } if (argvPtr != NULL) { - *argvPtr = (char **) ckalloc((unsigned) sizeof(char *) * (objc - 1)); + *argvPtr = (CONST char **) + ckalloc((unsigned) sizeof(CONST char *) * (objc - 1)); for (i = 1; i < objc; i++) { *argvPtr[i - 1] = Tcl_GetString(objv[i]); } @@ -949,7 +974,7 @@ Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr, /* *---------------------------------------------------------------------- * - * Tcl_ObjGetAlias -- + * Tcl_GetAliasObj -- * * Object version: Gets information about an alias. * @@ -966,9 +991,9 @@ int Tcl_GetAliasObj(interp, aliasName, targetInterpPtr, targetNamePtr, objcPtr, objvPtr) Tcl_Interp *interp; /* Interp to start search from. */ - char *aliasName; /* Name of alias to find. */ + CONST char *aliasName; /* Name of alias to find. */ Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */ - char **targetNamePtr; /* (Return) name of target command. */ + CONST char **targetNamePtr; /* (Return) name of target command. */ int *objcPtr; /* (Return) count of addnl args. */ Tcl_Obj ***objvPtr; /* (Return) additional args. */ { @@ -986,12 +1011,13 @@ Tcl_GetAliasObj(interp, aliasName, targetInterpPtr, targetNamePtr, objcPtr, return TCL_ERROR; } aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); - Tcl_ListObjGetElements(NULL, aliasPtr->prefixPtr, &objc, &objv); + objc = aliasPtr->objc; + objv = &aliasPtr->objPtr; if (targetInterpPtr != (Tcl_Interp **) NULL) { *targetInterpPtr = aliasPtr->targetInterp; } - if (targetNamePtr != (char **) NULL) { + if (targetNamePtr != (CONST char **) NULL) { *targetNamePtr = Tcl_GetString(objv[0]); } if (objcPtr != (int *) NULL) { @@ -1056,17 +1082,16 @@ TclPreventAliasLoop(interp, cmdInterp, cmd) aliasPtr = (Alias *) cmdPtr->objClientData; nextAliasPtr = aliasPtr; while (1) { - int objc; - Tcl_Obj **objv; + Tcl_Obj *cmdNamePtr; /* * If the target of the next alias in the chain is the same as * the source alias, we have a loop. */ - Tcl_ListObjGetElements(NULL, nextAliasPtr->prefixPtr, &objc, &objv); + cmdNamePtr = nextAliasPtr->objPtr; aliasCmd = Tcl_FindCommand(nextAliasPtr->targetInterp, - Tcl_GetString(objv[0]), + Tcl_GetString(cmdNamePtr), Tcl_GetGlobalNamespace(nextAliasPtr->targetInterp), /*flags*/ 0); if (aliasCmd == (Tcl_Command) NULL) { @@ -1132,14 +1157,24 @@ AliasCreate(interp, slaveInterp, masterInterp, namePtr, targetNamePtr, Target *targetPtr; Slave *slavePtr; Master *masterPtr; + int i; + Tcl_Obj **prefv; - aliasPtr = (Alias *) ckalloc((unsigned) sizeof(Alias)); + aliasPtr = (Alias *) ckalloc((unsigned) (sizeof(Alias) + + objc * sizeof(Tcl_Obj *))); aliasPtr->namePtr = namePtr; Tcl_IncrRefCount(aliasPtr->namePtr); aliasPtr->targetInterp = masterInterp; - aliasPtr->prefixPtr = Tcl_NewListObj(1, &targetNamePtr); - Tcl_ListObjReplace(NULL, aliasPtr->prefixPtr, 1, 0, objc, objv); - Tcl_IncrRefCount(aliasPtr->prefixPtr); + + aliasPtr->objc = objc + 1; + prefv = &aliasPtr->objPtr; + + *prefv = targetNamePtr; + Tcl_IncrRefCount(targetNamePtr); + for (i = 0; i < objc; i++) { + *(++prefv) = objv[i]; + Tcl_IncrRefCount(objv[i]); + } aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp, Tcl_GetString(namePtr), AliasObjCmd, (ClientData) aliasPtr, @@ -1156,7 +1191,10 @@ AliasCreate(interp, slaveInterp, masterInterp, namePtr, targetNamePtr, Command *cmdPtr; Tcl_DecrRefCount(aliasPtr->namePtr); - Tcl_DecrRefCount(aliasPtr->prefixPtr); + Tcl_DecrRefCount(targetNamePtr); + for (i = 0; i < objc; i++) { + Tcl_DecrRefCount(objv[i]); + } cmdPtr = (Command *) aliasPtr->slaveCmd; cmdPtr->clientData = NULL; @@ -1245,7 +1283,7 @@ static int AliasDelete(interp, slaveInterp, namePtr) Tcl_Interp *interp; /* Interpreter for result & errors. */ Tcl_Interp *slaveInterp; /* Interpreter containing alias. */ - Tcl_Obj *namePtr; /* Name of alias to describe. */ + Tcl_Obj *namePtr; /* Name of alias to delete. */ { Slave *slavePtr; Alias *aliasPtr; @@ -1297,6 +1335,7 @@ AliasDescribe(interp, slaveInterp, namePtr) Slave *slavePtr; Tcl_HashEntry *hPtr; Alias *aliasPtr; + Tcl_Obj *prefixPtr; /* * If the alias has been renamed in the slave, the master can still use @@ -1310,7 +1349,8 @@ AliasDescribe(interp, slaveInterp, namePtr) return TCL_OK; } aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); - Tcl_SetObjResult(interp, aliasPtr->prefixPtr); + prefixPtr = Tcl_NewListObj(aliasPtr->objc, &aliasPtr->objPtr); + Tcl_SetObjResult(interp, prefixPtr); return TCL_OK; } @@ -1381,71 +1421,51 @@ AliasObjCmd(clientData, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument vector. */ { +#define ALIAS_CMDV_PREALLOC 10 Tcl_Interp *targetInterp; Alias *aliasPtr; int result, prefc, cmdc; - Tcl_Obj *cmdPtr; Tcl_Obj **prefv, **cmdv; - + Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC]; aliasPtr = (Alias *) clientData; targetInterp = aliasPtr->targetInterp; - Tcl_Preserve((ClientData) targetInterp); - - ((Interp *) targetInterp)->numLevels++; - - Tcl_ResetResult(targetInterp); - Tcl_AllowExceptions(targetInterp); - /* * Append the arguments to the command prefix and invoke the command * in the target interp's global namespace. */ - Tcl_ListObjGetElements(NULL, aliasPtr->prefixPtr, &prefc, &prefv); - cmdPtr = Tcl_NewListObj(prefc, prefv); - Tcl_ListObjReplace(NULL, cmdPtr, prefc, 0, objc - 1, objv + 1); - Tcl_ListObjGetElements(NULL, cmdPtr, &cmdc, &cmdv); - result = TclObjInvoke(targetInterp, cmdc, cmdv, - TCL_INVOKE_NO_TRACEBACK); - Tcl_DecrRefCount(cmdPtr); - - ((Interp *) targetInterp)->numLevels--; - - /* - * Check if we are at the bottom of the stack for the target interpreter. - * If so, check for special return codes. - */ - - if (((Interp *) targetInterp)->numLevels == 0) { - if (result == TCL_RETURN) { - result = TclUpdateReturnInfo((Interp *) targetInterp); - } - if ((result != TCL_OK) && (result != TCL_ERROR)) { - Tcl_ResetResult(targetInterp); - if (result == TCL_BREAK) { - Tcl_SetObjResult(targetInterp, - Tcl_NewStringObj("invoked \"break\" outside of a loop", - -1)); - } else if (result == TCL_CONTINUE) { - Tcl_SetObjResult(targetInterp, - Tcl_NewStringObj( - "invoked \"continue\" outside of a loop", - -1)); - } else { - char buf[32 + TCL_INTEGER_SPACE]; - - sprintf(buf, "command returned bad code: %d", result); - Tcl_SetObjResult(targetInterp, Tcl_NewStringObj(buf, -1)); - } - result = TCL_ERROR; - } + prefc = aliasPtr->objc; + prefv = &aliasPtr->objPtr; + cmdc = prefc + objc - 1; + if (cmdc <= ALIAS_CMDV_PREALLOC) { + cmdv = cmdArr; + } else { + cmdv = (Tcl_Obj **) ckalloc((unsigned) (cmdc * sizeof(Tcl_Obj *))); } - TclTransferResult(targetInterp, result, interp); + prefv = &aliasPtr->objPtr; + memcpy((VOID *) cmdv, (VOID *) prefv, + (size_t) (prefc * sizeof(Tcl_Obj *))); + memcpy((VOID *) (cmdv+prefc), (VOID *) (objv+1), + (size_t) ((objc-1) * sizeof(Tcl_Obj *))); + + Tcl_ResetResult(targetInterp); - Tcl_Release((ClientData) targetInterp); + if (targetInterp != interp) { + Tcl_Preserve((ClientData) targetInterp); + result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_INVOKE); + TclTransferResult(targetInterp, result, interp); + Tcl_Release((ClientData) targetInterp); + } else { + result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_INVOKE); + } + + if (cmdv != cmdArr) { + ckfree((char *) cmdv); + } return result; +#undef ALIAS_CMDV_PREALLOC } /* @@ -1472,11 +1492,16 @@ AliasObjCmdDeleteProc(clientData) { Alias *aliasPtr; Target *targetPtr; + int i; + Tcl_Obj **objv; aliasPtr = (Alias *) clientData; Tcl_DecrRefCount(aliasPtr->namePtr); - Tcl_DecrRefCount(aliasPtr->prefixPtr); + objv = &aliasPtr->objPtr; + for (i = 0; i < aliasPtr->objc; i++) { + Tcl_DecrRefCount(objv[i]); + } Tcl_DeleteHashEntry(aliasPtr->aliasEntryPtr); targetPtr = (Target *) Tcl_GetHashValue(aliasPtr->targetEntryPtr); @@ -1512,7 +1537,7 @@ AliasObjCmdDeleteProc(clientData) Tcl_Interp * Tcl_CreateSlave(interp, slavePath, isSafe) Tcl_Interp *interp; /* Interpreter to start search at. */ - char *slavePath; /* Name of slave to create. */ + CONST char *slavePath; /* Name of slave to create. */ int isSafe; /* Should new slave be "safe" ? */ { Tcl_Obj *pathPtr; @@ -1545,7 +1570,7 @@ Tcl_CreateSlave(interp, slavePath, isSafe) Tcl_Interp * Tcl_GetSlave(interp, slavePath) Tcl_Interp *interp; /* Interpreter to start search from. */ - char *slavePath; /* Path of slave to find. */ + CONST char *slavePath; /* Path of slave to find. */ { Tcl_Obj *pathPtr; Tcl_Interp *slaveInterp; @@ -1780,6 +1805,11 @@ SlaveCreate(interp, pathPtr, safe) if (Tcl_Init(slaveInterp) == TCL_ERROR) { goto error; } + /* + * This will create the "memory" command in slave interpreters + * if we compiled with TCL_MEM_DEBUG, otherwise it does nothing. + */ + Tcl_InitMemory(slaveInterp); } return slaveInterp; @@ -1816,15 +1846,15 @@ SlaveObjCmd(clientData, interp, objc, objv) { Tcl_Interp *slaveInterp; int index; - static char *options[] = { + static CONST char *options[] = { "alias", "aliases", "eval", "expose", "hide", "hidden", "issafe", "invokehidden", - "marktrusted", NULL + "marktrusted", "recursionlimit", NULL }; enum options { OPT_ALIAS, OPT_ALIASES, OPT_EVAL, OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHIDDEN, - OPT_MARKTRUSTED + OPT_MARKTRUSTED, OPT_RECLIMIT }; slaveInterp = (Tcl_Interp *) clientData; @@ -1843,22 +1873,28 @@ SlaveObjCmd(clientData, interp, objc, objv) switch ((enum options) index) { case OPT_ALIAS: { - if (objc == 3) { - return AliasDescribe(interp, slaveInterp, objv[2]); - } - if (Tcl_GetString(objv[3])[0] == '\0') { - if (objc == 4) { - return AliasDelete(interp, slaveInterp, objv[2]); + if (objc > 2) { + if (objc == 3) { + return AliasDescribe(interp, slaveInterp, objv[2]); + } + if (Tcl_GetString(objv[3])[0] == '\0') { + if (objc == 4) { + return AliasDelete(interp, slaveInterp, objv[2]); + } + } else { + return AliasCreate(interp, slaveInterp, interp, objv[2], + objv[3], objc - 4, objv + 4); } - } else { - return AliasCreate(interp, slaveInterp, interp, objv[2], - objv[3], objc - 4, objv + 4); } Tcl_WrongNumArgs(interp, 2, objv, "aliasName ?targetName? ?args..?"); return TCL_ERROR; } case OPT_ALIASES: { + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) NULL); + return TCL_ERROR; + } return AliasList(interp, slaveInterp); } case OPT_EVAL: { @@ -1890,12 +1926,16 @@ SlaveObjCmd(clientData, interp, objc, objv) return SlaveHidden(interp, slaveInterp); } case OPT_ISSAFE: { + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) NULL); + return TCL_ERROR; + } Tcl_SetIntObj(Tcl_GetObjResult(interp), Tcl_IsSafe(slaveInterp)); return TCL_OK; } case OPT_INVOKEHIDDEN: { int global, i, index; - static char *hiddenOptions[] = { + static CONST char *hiddenOptions[] = { "-global", "--", NULL }; enum hiddenOption { @@ -1932,6 +1972,13 @@ SlaveObjCmd(clientData, interp, objc, objv) } return SlaveMarkTrusted(interp, slaveInterp); } + case OPT_RECLIMIT: { + if (objc != 2 && objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?newlimit?"); + return TCL_ERROR; + } + return SlaveRecursionLimit(interp, slaveInterp, objc - 2, objv + 2); + } } return TCL_ERROR; @@ -2074,6 +2121,65 @@ SlaveExpose(interp, slaveInterp, objc, objv) /* *---------------------------------------------------------------------- * + * SlaveRecursionLimit -- + * + * Helper function to set/query the Recursion limit of an interp + * + * Results: + * A standard Tcl result. + * + * Side effects: + * When (objc == 1), slaveInterp will be set to a new recursion + * limit of objv[0]. + * + *---------------------------------------------------------------------- + */ + +static int +SlaveRecursionLimit(interp, slaveInterp, objc, objv) + Tcl_Interp *interp; /* Interp for error return. */ + Tcl_Interp *slaveInterp; /* Interp in which limit is set/queried. */ + int objc; /* Set or Query. */ + Tcl_Obj *CONST objv[]; /* Argument strings. */ +{ + Interp *iPtr; + int limit; + + if (objc) { + if (Tcl_IsSafe(interp)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "permission denied: ", + "safe interpreters cannot change recursion limit", + (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetIntFromObj(interp, objv[0], &limit) == TCL_ERROR) { + return TCL_ERROR; + } + if (limit <= 0) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "recursion limit must be > 0", -1)); + return TCL_ERROR; + } + Tcl_SetRecursionLimit(slaveInterp, limit); + iPtr = (Interp *) slaveInterp; + if (interp == slaveInterp && iPtr->numLevels > limit) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "falling back due to new recursion limit", -1)); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, objv[0]); + return TCL_OK; + } else { + limit = Tcl_SetRecursionLimit(slaveInterp, 0); + Tcl_SetObjResult(interp, Tcl_NewIntObj(limit)); + return TCL_OK; + } +} + +/* + *---------------------------------------------------------------------- + * * SlaveHide -- * * Helper function to hide a command in a slave interpreter. diff --git a/tcl/generic/tclLink.c b/tcl/generic/tclLink.c index 13c5691a863..6edba23678a 100644 --- a/tcl/generic/tclLink.c +++ b/tcl/generic/tclLink.c @@ -26,7 +26,7 @@ typedef struct Link { Tcl_Interp *interp; /* Interpreter containing Tcl variable. */ - char *varName; /* Name of variable (must be global). This + Tcl_Obj *varName; /* Name of variable (must be global). This * is needed during trace callbacks, since * the actual variable may be aliased at * that time via upvar. */ @@ -35,6 +35,7 @@ typedef struct Link { union { int i; double d; + Tcl_WideInt w; } lastValue; /* Last known value of C variable; used to * avoid string conversions. */ int flags; /* Miscellaneous one-bit values; see below @@ -59,10 +60,9 @@ typedef struct Link { */ static char * LinkTraceProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, char *name1, char *name2, - int flags)); -static char * StringValue _ANSI_ARGS_((Link *linkPtr, - char *buffer)); + Tcl_Interp *interp, CONST char *name1, + CONST char *name2, int flags)); +static Tcl_Obj * ObjValue _ANSI_ARGS_((Link *linkPtr)); /* *---------------------------------------------------------------------- @@ -88,21 +88,21 @@ static char * StringValue _ANSI_ARGS_((Link *linkPtr, int Tcl_LinkVar(interp, varName, addr, type) Tcl_Interp *interp; /* Interpreter in which varName exists. */ - char *varName; /* Name of a global variable in interp. */ + CONST char *varName; /* Name of a global variable in interp. */ char *addr; /* Address of a C variable to be linked * to varName. */ int type; /* Type of C variable: TCL_LINK_INT, etc. * Also may have TCL_LINK_READ_ONLY * OR'ed in. */ { + Tcl_Obj *objPtr; Link *linkPtr; - char buffer[TCL_DOUBLE_SPACE]; int code; linkPtr = (Link *) ckalloc(sizeof(Link)); linkPtr->interp = interp; - linkPtr->varName = (char *) ckalloc((unsigned) (strlen(varName) + 1)); - strcpy(linkPtr->varName, varName); + linkPtr->varName = Tcl_NewStringObj(varName, -1); + Tcl_IncrRefCount(linkPtr->varName); linkPtr->addr = addr; linkPtr->type = type & ~TCL_LINK_READ_ONLY; if (type & TCL_LINK_READ_ONLY) { @@ -110,9 +110,11 @@ Tcl_LinkVar(interp, varName, addr, type) } else { linkPtr->flags = 0; } - if (Tcl_SetVar(interp, varName, StringValue(linkPtr, buffer), + objPtr = ObjValue(linkPtr); + if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr, TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { - ckfree(linkPtr->varName); + Tcl_DecrRefCount(linkPtr->varName); + Tcl_DecrRefCount(objPtr); ckfree((char *) linkPtr); return TCL_ERROR; } @@ -120,7 +122,7 @@ Tcl_LinkVar(interp, varName, addr, type) |TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, (ClientData) linkPtr); if (code != TCL_OK) { - ckfree(linkPtr->varName); + Tcl_DecrRefCount(linkPtr->varName); ckfree((char *) linkPtr); } return code; @@ -147,7 +149,7 @@ Tcl_LinkVar(interp, varName, addr, type) void Tcl_UnlinkVar(interp, varName) Tcl_Interp *interp; /* Interpreter containing variable to unlink. */ - char *varName; /* Global variable in interp to unlink. */ + CONST char *varName; /* Global variable in interp to unlink. */ { Link *linkPtr; @@ -159,7 +161,7 @@ Tcl_UnlinkVar(interp, varName) Tcl_UntraceVar(interp, varName, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, (ClientData) linkPtr); - ckfree(linkPtr->varName); + Tcl_DecrRefCount(linkPtr->varName); ckfree((char *) linkPtr); } @@ -185,10 +187,9 @@ Tcl_UnlinkVar(interp, varName) void Tcl_UpdateLinkedVar(interp, varName) Tcl_Interp *interp; /* Interpreter containing variable. */ - char *varName; /* Name of global variable that is linked. */ + CONST char *varName; /* Name of global variable that is linked. */ { Link *linkPtr; - char buffer[TCL_DOUBLE_SPACE]; int savedFlag; linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY, @@ -198,7 +199,7 @@ Tcl_UpdateLinkedVar(interp, varName) } savedFlag = linkPtr->flags & LINK_BEING_UPDATED; linkPtr->flags |= LINK_BEING_UPDATED; - Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer), + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); linkPtr->flags = (linkPtr->flags & ~LINK_BEING_UPDATED) | savedFlag; } @@ -228,15 +229,15 @@ static char * LinkTraceProc(clientData, interp, name1, name2, flags) ClientData clientData; /* Contains information about the link. */ Tcl_Interp *interp; /* Interpreter containing Tcl variable. */ - char *name1; /* First part of variable name. */ - char *name2; /* Second part of variable name. */ + CONST char *name1; /* First part of variable name. */ + CONST char *name2; /* Second part of variable name. */ int flags; /* Miscellaneous additional information. */ { Link *linkPtr = (Link *) clientData; - int changed; - char buffer[TCL_DOUBLE_SPACE]; - char *value, **pp, *result; - Tcl_Obj *objPtr; + int changed, valueLength; + CONST char *value; + char **pp, *result; + Tcl_Obj *objPtr, *valueObj; /* * If the variable is being unset, then just re-create it (with a @@ -245,14 +246,14 @@ LinkTraceProc(clientData, interp, name1, name2, flags) if (flags & TCL_TRACE_UNSETS) { if (flags & TCL_INTERP_DESTROYED) { - ckfree(linkPtr->varName); + Tcl_DecrRefCount(linkPtr->varName); ckfree((char *) linkPtr); } else if (flags & TCL_TRACE_DESTROYED) { - Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer), + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); - Tcl_TraceVar(interp, linkPtr->varName, TCL_GLOBAL_ONLY - |TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - LinkTraceProc, (ClientData) linkPtr); + Tcl_TraceVar(interp, Tcl_GetString(linkPtr->varName), + TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES + |TCL_TRACE_UNSETS, LinkTraceProc, (ClientData) linkPtr); } return NULL; } @@ -275,21 +276,24 @@ LinkTraceProc(clientData, interp, name1, name2, flags) if (flags & TCL_TRACE_READS) { switch (linkPtr->type) { - case TCL_LINK_INT: - case TCL_LINK_BOOLEAN: - changed = *(int *)(linkPtr->addr) != linkPtr->lastValue.i; - break; - case TCL_LINK_DOUBLE: - changed = *(double *)(linkPtr->addr) != linkPtr->lastValue.d; - break; - case TCL_LINK_STRING: - changed = 1; - break; - default: - return "internal error: bad linked variable type"; + case TCL_LINK_INT: + case TCL_LINK_BOOLEAN: + changed = *(int *)(linkPtr->addr) != linkPtr->lastValue.i; + break; + case TCL_LINK_DOUBLE: + changed = *(double *)(linkPtr->addr) != linkPtr->lastValue.d; + break; + case TCL_LINK_WIDE_INT: + changed = *(Tcl_WideInt *)(linkPtr->addr) != linkPtr->lastValue.w; + break; + case TCL_LINK_STRING: + changed = 1; + break; + default: + return "internal error: bad linked variable type"; } if (changed) { - Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer), + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); } return NULL; @@ -305,12 +309,12 @@ LinkTraceProc(clientData, interp, name1, name2, flags) */ if (linkPtr->flags & LINK_READ_ONLY) { - Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer), + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return "linked variable is read-only"; } - value = Tcl_GetVar(interp, linkPtr->varName, TCL_GLOBAL_ONLY); - if (value == NULL) { + valueObj = Tcl_ObjGetVar2(interp, linkPtr->varName,NULL, TCL_GLOBAL_ONLY); + if (valueObj == NULL) { /* * This shouldn't ever happen. */ @@ -323,48 +327,67 @@ LinkTraceProc(clientData, interp, name1, name2, flags) result = NULL; switch (linkPtr->type) { - case TCL_LINK_INT: - if (Tcl_GetInt(interp, value, &linkPtr->lastValue.i) != TCL_OK) { - Tcl_SetObjResult(interp, objPtr); - Tcl_SetVar(interp, linkPtr->varName, - StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY); - result = "variable must have integer value"; - goto end; - } - *(int *)(linkPtr->addr) = linkPtr->lastValue.i; - break; - case TCL_LINK_DOUBLE: - if (Tcl_GetDouble(interp, value, &linkPtr->lastValue.d) - != TCL_OK) { - Tcl_SetObjResult(interp, objPtr); - Tcl_SetVar(interp, linkPtr->varName, - StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY); - result = "variable must have real value"; - goto end; - } - *(double *)(linkPtr->addr) = linkPtr->lastValue.d; - break; - case TCL_LINK_BOOLEAN: - if (Tcl_GetBoolean(interp, value, &linkPtr->lastValue.i) - != TCL_OK) { - Tcl_SetObjResult(interp, objPtr); - Tcl_SetVar(interp, linkPtr->varName, - StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY); - result = "variable must have boolean value"; - goto end; - } - *(int *)(linkPtr->addr) = linkPtr->lastValue.i; - break; - case TCL_LINK_STRING: - pp = (char **)(linkPtr->addr); - if (*pp != NULL) { - ckfree(*pp); - } - *pp = (char *) ckalloc((unsigned) (strlen(value) + 1)); - strcpy(*pp, value); - break; - default: - return "internal error: bad linked variable type"; + case TCL_LINK_INT: + if (Tcl_GetIntFromObj(interp, valueObj, &linkPtr->lastValue.i) + != TCL_OK) { + Tcl_SetObjResult(interp, objPtr); + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + result = "variable must have integer value"; + goto end; + } + *(int *)(linkPtr->addr) = linkPtr->lastValue.i; + break; + + case TCL_LINK_WIDE_INT: + if (Tcl_GetWideIntFromObj(interp, valueObj, &linkPtr->lastValue.w) + != TCL_OK) { + Tcl_SetObjResult(interp, objPtr); + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + result = "variable must have integer value"; + goto end; + } + *(Tcl_WideInt *)(linkPtr->addr) = linkPtr->lastValue.w; + break; + + case TCL_LINK_DOUBLE: + if (Tcl_GetDoubleFromObj(interp, valueObj, &linkPtr->lastValue.d) + != TCL_OK) { + Tcl_SetObjResult(interp, objPtr); + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + result = "variable must have real value"; + goto end; + } + *(double *)(linkPtr->addr) = linkPtr->lastValue.d; + break; + + case TCL_LINK_BOOLEAN: + if (Tcl_GetBooleanFromObj(interp, valueObj, &linkPtr->lastValue.i) + != TCL_OK) { + Tcl_SetObjResult(interp, objPtr); + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + result = "variable must have boolean value"; + goto end; + } + *(int *)(linkPtr->addr) = linkPtr->lastValue.i; + break; + + case TCL_LINK_STRING: + value = Tcl_GetStringFromObj(valueObj, &valueLength); + valueLength++; + pp = (char **)(linkPtr->addr); + if (*pp != NULL) { + ckfree(*pp); + } + *pp = (char *) ckalloc((unsigned) valueLength); + memcpy(*pp, value, (unsigned) valueLength); + break; + + default: + return "internal error: bad linked variable type"; } end: Tcl_DecrRefCount(objPtr); @@ -374,13 +397,13 @@ LinkTraceProc(clientData, interp, name1, name2, flags) /* *---------------------------------------------------------------------- * - * StringValue -- + * ObjValue -- * - * Converts the value of a C variable to a string for use in a + * Converts the value of a C variable to a Tcl_Obj* for use in a * Tcl variable to which it is linked. * * Results: - * The return value is a pointer to a string that represents + * The return value is a pointer to a Tcl_Obj that represents * the value of the C variable given by linkPtr. * * Side effects: @@ -389,42 +412,37 @@ LinkTraceProc(clientData, interp, name1, name2, flags) *---------------------------------------------------------------------- */ -static char * -StringValue(linkPtr, buffer) +static Tcl_Obj * +ObjValue(linkPtr) Link *linkPtr; /* Structure describing linked variable. */ - char *buffer; /* Small buffer to use for converting - * values. Must have TCL_DOUBLE_SPACE - * bytes or more. */ { char *p; switch (linkPtr->type) { - case TCL_LINK_INT: - linkPtr->lastValue.i = *(int *)(linkPtr->addr); - TclFormatInt(buffer, linkPtr->lastValue.i); - return buffer; - case TCL_LINK_DOUBLE: - linkPtr->lastValue.d = *(double *)(linkPtr->addr); - Tcl_PrintDouble((Tcl_Interp *) NULL, linkPtr->lastValue.d, buffer); - return buffer; - case TCL_LINK_BOOLEAN: - linkPtr->lastValue.i = *(int *)(linkPtr->addr); - if (linkPtr->lastValue.i != 0) { - return "1"; - } - return "0"; - case TCL_LINK_STRING: - p = *(char **)(linkPtr->addr); - if (p == NULL) { - return "NULL"; - } - return p; - } + case TCL_LINK_INT: + linkPtr->lastValue.i = *(int *)(linkPtr->addr); + return Tcl_NewIntObj(linkPtr->lastValue.i); + case TCL_LINK_WIDE_INT: + linkPtr->lastValue.w = *(Tcl_WideInt *)(linkPtr->addr); + return Tcl_NewWideIntObj(linkPtr->lastValue.w); + case TCL_LINK_DOUBLE: + linkPtr->lastValue.d = *(double *)(linkPtr->addr); + return Tcl_NewDoubleObj(linkPtr->lastValue.d); + case TCL_LINK_BOOLEAN: + linkPtr->lastValue.i = *(int *)(linkPtr->addr); + return Tcl_NewBooleanObj(linkPtr->lastValue.i != 0); + case TCL_LINK_STRING: + p = *(char **)(linkPtr->addr); + if (p == NULL) { + return Tcl_NewStringObj("NULL", 4); + } + return Tcl_NewStringObj(p, -1); /* * This code only gets executed if the link type is unknown * (shouldn't ever happen). */ - - return "??"; + default: + return Tcl_NewStringObj("??", 2); + } } diff --git a/tcl/generic/tclListObj.c b/tcl/generic/tclListObj.c index 0e22a6020ac..88619f4c158 100644 --- a/tcl/generic/tclListObj.c +++ b/tcl/generic/tclListObj.c @@ -6,6 +6,7 @@ * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 1998 by Scriptics Corporation. + * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -29,6 +30,15 @@ static void UpdateStringOfList _ANSI_ARGS_((Tcl_Obj *listPtr)); /* * The structure below defines the list Tcl object type by means of * procedures 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. */ Tcl_ObjType tclListType = { @@ -105,7 +115,8 @@ Tcl_NewListObj(objc, objv) listRepPtr->elemCount = objc; listRepPtr->elements = elemPtrs; - listPtr->internalRep.otherValuePtr = (VOID *) listRepPtr; + listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr; + listPtr->internalRep.twoPtrValue.ptr2 = NULL; listPtr->typePtr = &tclListType; } return listPtr; @@ -121,9 +132,9 @@ Tcl_NewListObj(objc, objv) * TCL_MEM_DEBUG is defined. It creates new list objects. It is the * same as the Tcl_NewListObj procedure above except that it calls * Tcl_DbCkalloc directly with the file name and line number from its - * caller. This simplifies debugging since then the checkmem command - * will report the correct file name and line number when reporting - * objects that haven't been freed. + * 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. * * When TCL_MEM_DEBUG is not defined, this procedure just returns the * result of calling Tcl_NewListObj. @@ -147,7 +158,7 @@ Tcl_Obj * Tcl_DbNewListObj(objc, objv, file, line) int objc; /* Count of objects referenced by objv. */ Tcl_Obj *CONST objv[]; /* An array of pointers to Tcl objects. */ - char *file; /* The name of the source file calling this + 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. */ @@ -174,7 +185,8 @@ Tcl_DbNewListObj(objc, objv, file, line) listRepPtr->elemCount = objc; listRepPtr->elements = elemPtrs; - listPtr->internalRep.otherValuePtr = (VOID *) listRepPtr; + listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr; + listPtr->internalRep.twoPtrValue.ptr2 = NULL; listPtr->typePtr = &tclListType; } return listPtr; @@ -186,7 +198,7 @@ Tcl_Obj * Tcl_DbNewListObj(objc, objv, file, line) int objc; /* Count of objects referenced by objv. */ Tcl_Obj *CONST objv[]; /* An array of pointers to Tcl objects. */ - char *file; /* The name of the source file calling this + 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. */ @@ -261,10 +273,12 @@ Tcl_SetListObj(objPtr, objc, objv) listRepPtr->elemCount = objc; listRepPtr->elements = elemPtrs; - objPtr->internalRep.otherValuePtr = (VOID *) listRepPtr; + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = &tclListType; } else { objPtr->bytes = tclEmptyStringRep; + objPtr->length = 0; } } @@ -316,7 +330,7 @@ Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) return result; } } - listRepPtr = (List *) listPtr->internalRep.otherValuePtr; + listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; *objcPtr = listRepPtr->elemCount; *objvPtr = listRepPtr->elements; return TCL_OK; @@ -367,7 +381,7 @@ Tcl_ListObjAppendList(interp, listPtr, elemListPtr) return result; } } - listRepPtr = (List *) listPtr->internalRep.otherValuePtr; + listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; listLen = listRepPtr->elemCount; result = Tcl_ListObjGetElements(interp, elemListPtr, &objc, &objv); @@ -430,7 +444,7 @@ Tcl_ListObjAppendElement(interp, listPtr, objPtr) } } - listRepPtr = (List *) listPtr->internalRep.otherValuePtr; + listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; elemPtrs = listRepPtr->elements; numElems = listRepPtr->elemCount; numRequired = numElems + 1 ; @@ -514,7 +528,7 @@ Tcl_ListObjIndex(interp, listPtr, index, objPtrPtr) } } - listRepPtr = (List *) listPtr->internalRep.otherValuePtr; + listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; if ((index < 0) || (index >= listRepPtr->elemCount)) { *objPtrPtr = NULL; } else { @@ -561,7 +575,7 @@ Tcl_ListObjLength(interp, listPtr, intPtr) } } - listRepPtr = (List *) listPtr->internalRep.otherValuePtr; + listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; *intPtr = listRepPtr->elemCount; return TCL_OK; } @@ -629,7 +643,7 @@ Tcl_ListObjReplace(interp, listPtr, first, count, objc, objv) return result; } } - listRepPtr = (List *) listPtr->internalRep.otherValuePtr; + listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; elemPtrs = listRepPtr->elements; numElems = listRepPtr->elemCount; @@ -762,6 +776,586 @@ Tcl_ListObjReplace(interp, listPtr, first, count, objc, objv) /* *---------------------------------------------------------------------- * + * TclLsetList -- + * + * Core of the 'lset' command when objc == 4. Objv[2] may be + * either a scalar index or a list of indices. + * + * Results: + * Returns the new value of the list variable, or NULL if an + * error occurs. + * + * Side effects: + * Surgery is performed on the list value to produce the + * result. + * + * 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 procedure. + * + * 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_LsetFlat and related functions maintain a linked list of + * Tcl_Obj's whose string representations must be spoilt by threading + * via 'ptr2' of the two-pointer internal representation. On entry + * to Tcl_LsetList, the values of 'ptr2' are immaterial; on exit, + * the 'ptr2' field of any Tcl_Obj that has been modified is set to + * NULL. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj* +TclLsetList( interp, listPtr, indexArgPtr, valuePtr ) + 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' */ +{ + int indexCount; /* Number of indices in the index list */ + Tcl_Obj** indices; /* Vector of indices in the index list*/ + + int duplicated; /* Flag == 1 if the obj has been + * duplicated, 0 otherwise */ + Tcl_Obj* retValuePtr; /* Pointer to the list to be returned */ + int index; /* Current index in the list - discarded */ + int result; /* Status return from library calls */ + Tcl_Obj* subListPtr; /* Pointer to the current sublist */ + int elemCount; /* Count of elements in the current sublist */ + Tcl_Obj** elemPtrs; /* Pointers to elements of current sublist */ + Tcl_Obj* chainPtr; /* Pointer to the enclosing sublist + * of the current sublist */ + int i; + + + /* + * Determine whether the index arg 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 #23 for details. + */ + + if ( indexArgPtr->typePtr != &tclListType + && TclGetIntForIndex( NULL, indexArgPtr, 0, &index ) == TCL_OK ) { + + /* + * indexArgPtr designates a single index. + */ + + return TclLsetFlat( interp, listPtr, 1, &indexArgPtr, valuePtr ); + + } else if ( Tcl_ListObjGetElements( NULL, indexArgPtr, + &indexCount, &indices ) != TCL_OK ) { + + /* + * 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 ); + + } + + /* + * At this point, we know that argPtr designates a well formed list, + * and the 'else if' above has parsed it into indexCount and indices. + * If there are no indices, simply return 'valuePtr', counting the + * returned pointer as a reference. + */ + + if ( indexCount == 0 ) { + Tcl_IncrRefCount( valuePtr ); + return valuePtr; + } + + /* + * Duplicate the list arg if necessary. + */ + + if ( Tcl_IsShared( listPtr ) ) { + duplicated = 1; + listPtr = Tcl_DuplicateObj( listPtr ); + Tcl_IncrRefCount( listPtr ); + } else { + duplicated = 0; + } + + /* + * It would be tempting simply to go off to TclLsetFlat to finish the + * processing. Alas, it is also incorrect! The problem is that + * 'indexArgPtr' may designate a sublist of 'listPtr' whose value + * is to be manipulated. The fact that 'listPtr' is itself unshared + * does not guarantee that no sublist is. Therefore, it's necessary + * to replicate all the work here, expanding the index list on each + * trip through the loop. + */ + + /* + * Anchor the linked list of Tcl_Obj's whose string reps must be + * invalidated if the operation succeeds. + */ + + retValuePtr = listPtr; + chainPtr = NULL; + + /* + * Handle each index arg by diving into the appropriate sublist + */ + + for ( i = 0; ; ++i ) { + + /* + * Take the sublist apart. + */ + + result = Tcl_ListObjGetElements( interp, listPtr, + &elemCount, &elemPtrs ); + if ( result != TCL_OK ) { + break; + } + listPtr->internalRep.twoPtrValue.ptr2 = (VOID *) chainPtr; + + /* + * Reconstitute the index array + */ + + result = Tcl_ListObjGetElements( interp, indexArgPtr, + &indexCount, &indices ); + if ( result != TCL_OK ) { + /* + * Shouldn't be able to get here, because we already + * parsed the thing successfully once. + */ + break; + } + + /* + * Determine the index of the requested element. + */ + + result = TclGetIntForIndex( interp, indices[ i ], + (elemCount - 1), &index ); + if ( result != TCL_OK ) { + break; + } + + /* + * Check that the index is in range. + */ + + if ( ( index < 0 ) || ( index >= elemCount ) ) { + Tcl_SetObjResult( interp, + Tcl_NewStringObj( "list index out of range", + -1 ) ); + result = TCL_ERROR; + break; + } + + /* + * Break the loop after extracting the innermost sublist + */ + + if ( i >= indexCount-1 ) { + result = TCL_OK; + break; + } + + /* + * Extract the appropriate sublist, and make sure that it is unshared. + */ + + subListPtr = elemPtrs[ index ]; + if ( Tcl_IsShared( subListPtr ) ) { + subListPtr = Tcl_DuplicateObj( subListPtr ); + result = TclListObjSetElement( interp, listPtr, index, + subListPtr ); + if ( result != TCL_OK ) { + /* + * We actually shouldn't be able to get here, because + * we've already checked everything that TclListObjSetElement + * checks. If we were to get here, it would result in leaking + * subListPtr. + */ + break; + } + } + + /* + * Chain the current sublist onto the linked list of Tcl_Obj's + * whose string reps must be spoilt. + */ + + chainPtr = listPtr; + listPtr = subListPtr; + + } + + /* + * Store the new element into the correct slot in the innermost sublist. + */ + + if ( result == TCL_OK ) { + result = TclListObjSetElement( interp, listPtr, index, valuePtr ); + } + + if ( result == TCL_OK ) { + + listPtr->internalRep.twoPtrValue.ptr2 = (VOID *) chainPtr; + + /* Spoil all the string reps */ + + while ( listPtr != NULL ) { + subListPtr = (Tcl_Obj *) listPtr->internalRep.twoPtrValue.ptr2; + Tcl_InvalidateStringRep( listPtr ); + listPtr->internalRep.twoPtrValue.ptr2 = NULL; + listPtr = subListPtr; + } + + /* Return the new list if everything worked. */ + + if ( !duplicated ) { + Tcl_IncrRefCount( retValuePtr ); + } + return retValuePtr; + } + + /* Clean up the one dangling reference otherwise */ + + if ( duplicated ) { + Tcl_DecrRefCount( retValuePtr ); + } + return NULL; + +} + +/* + *---------------------------------------------------------------------- + * + * TclLsetFlat -- + * + * Core of the 'lset' command when objc>=5. Objv[2], ... , + * objv[objc-2] contain scalar indices. + * + * Results: + * Returns the new value of the list variable, or NULL if an + * error occurs. + * + * Side effects: + * Surgery is performed on the list value to produce the + * result. + * + * 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 procedure. + * + * 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_LsetList and related functions maintain a linked list of + * Tcl_Obj's whose string representations must be spoilt by threading + * via 'ptr2' of the two-pointer internal representation. On entry + * to Tcl_LsetList, the values of 'ptr2' are immaterial; on exit, + * the 'ptr2' field of any Tcl_Obj that has been modified is set to + * NULL. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj* +TclLsetFlat( interp, listPtr, indexCount, indexArray, valuePtr ) + Tcl_Interp* interp; /* Tcl interpreter */ + Tcl_Obj* listPtr; /* Pointer to the list being modified */ + int indexCount; /* Number of index args */ + Tcl_Obj *CONST indexArray[]; + /* Index args */ + Tcl_Obj* valuePtr; /* Value arg to 'lset' */ +{ + + int duplicated; /* Flag == 1 if the obj has been + * duplicated, 0 otherwise */ + Tcl_Obj* retValuePtr; /* Pointer to the list to be returned */ + + int elemCount; /* Length of one sublist being changed */ + Tcl_Obj** elemPtrs; /* Pointers to the elements of a sublist */ + + Tcl_Obj* subListPtr; /* Pointer to the current sublist */ + + int index; /* Index of the element to replace in the + * current sublist */ + Tcl_Obj* chainPtr; /* Pointer to the enclosing list of + * the current sublist. */ + + int result; /* Status return from library calls */ + + + + int i; + + /* + * If there are no indices, then simply return the new value, + * counting the returned pointer as a reference + */ + + if ( indexCount == 0 ) { + Tcl_IncrRefCount( valuePtr ); + return valuePtr; + } + + /* + * If the list is shared, make a private copy. + */ + + if ( Tcl_IsShared( listPtr ) ) { + duplicated = 1; + listPtr = Tcl_DuplicateObj( listPtr ); + Tcl_IncrRefCount( listPtr ); + } else { + duplicated = 0; + } + + /* + * Anchor the linked list of Tcl_Obj's whose string reps must be + * invalidated if the operation succeeds. + */ + + retValuePtr = listPtr; + chainPtr = NULL; + + /* + * Handle each index arg by diving into the appropriate sublist + */ + + for ( i = 0; ; ++i ) { + + /* + * Take the sublist apart. + */ + + result = Tcl_ListObjGetElements( interp, listPtr, + &elemCount, &elemPtrs ); + if ( result != TCL_OK ) { + break; + } + listPtr->internalRep.twoPtrValue.ptr2 = (VOID *) chainPtr; + + /* + * Determine the index of the requested element. + */ + + result = TclGetIntForIndex( interp, indexArray[ i ], + (elemCount - 1), &index ); + if ( result != TCL_OK ) { + break; + } + + /* + * Check that the index is in range. + */ + + if ( ( index < 0 ) || ( index >= elemCount ) ) { + Tcl_SetObjResult( interp, + Tcl_NewStringObj( "list index out of range", + -1 ) ); + result = TCL_ERROR; + break; + } + + /* + * Break the loop after extracting the innermost sublist + */ + + if ( i >= indexCount-1 ) { + result = TCL_OK; + break; + } + + /* + * Extract the appropriate sublist, and make sure that it is unshared. + */ + + subListPtr = elemPtrs[ index ]; + if ( Tcl_IsShared( subListPtr ) ) { + subListPtr = Tcl_DuplicateObj( subListPtr ); + result = TclListObjSetElement( interp, listPtr, index, + subListPtr ); + if ( result != TCL_OK ) { + /* + * We actually shouldn't be able to get here. + * If we do, it would result in leaking subListPtr, + * but everything's been validated already; the error + * exit from TclListObjSetElement should never happen. + */ + break; + } + } + + /* + * Chain the current sublist onto the linked list of Tcl_Obj's + * whose string reps must be spoilt. + */ + + chainPtr = listPtr; + listPtr = subListPtr; + + } + + /* Store the result in the list element */ + + if ( result == TCL_OK ) { + result = TclListObjSetElement( interp, listPtr, index, valuePtr ); + } + + if ( result == TCL_OK ) { + + listPtr->internalRep.twoPtrValue.ptr2 = (VOID *) chainPtr; + + /* Spoil all the string reps */ + + while ( listPtr != NULL ) { + subListPtr = (Tcl_Obj *) listPtr->internalRep.twoPtrValue.ptr2; + Tcl_InvalidateStringRep( listPtr ); + listPtr->internalRep.twoPtrValue.ptr2 = NULL; + listPtr = subListPtr; + } + + /* Return the new list if everything worked. */ + + if ( !duplicated ) { + Tcl_IncrRefCount( retValuePtr ); + } + return retValuePtr; + } + + /* Clean up the one dangling reference otherwise */ + + if ( duplicated ) { + Tcl_DecrRefCount( retValuePtr ); + } + return NULL; + +} + +/* + *---------------------------------------------------------------------- + * + * TclListObjSetElement -- + * + * Set a single element of a list to a specified value + * + * Results: + * + * The return value is normally TCL_OK. If listPtr 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 listPtr, TCL_ERROR is returned and an error message is left + * in the interpreter result. + * + * Side effects: + * + * Panics if listPtr designates a shared object. Otherwise, attempts + * to convert it to a list. Decrements the ref count of the object + * at the specified index within the list, replaces with the + * object designated by valuePtr, and increments the ref count + * of the replacement object. + * + * It is the caller's responsibility to invalidate the string + * representation of the object. + * + *---------------------------------------------------------------------- + */ + +int +TclListObjSetElement( interp, listPtr, index, valuePtr ) + Tcl_Interp* interp; /* Tcl interpreter; used for error reporting + * if not NULL */ + Tcl_Obj* listPtr; /* 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 element */ +{ + int result; /* Return value from this function */ + 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 */ + + /* Ensure that the listPtr parameter designates an unshared list */ + + if ( Tcl_IsShared( listPtr ) ) { + panic( "Tcl_ListObjSetElement called with shared object" ); + } + if ( listPtr->typePtr != &tclListType ) { + result = SetListFromAny( interp, listPtr ); + if ( result != TCL_OK ) { + return result; + } + } + listRepPtr = (List*) listPtr->internalRep.twoPtrValue.ptr1; + elemPtrs = listRepPtr->elements; + elemCount = listRepPtr->elemCount; + + /* 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 ) ); + return TCL_ERROR; + } + } + + /* Add a reference to the new list element */ + + Tcl_IncrRefCount( valuePtr ); + + /* Remove a reference from the old list element */ + + Tcl_DecrRefCount( elemPtrs[ index ] ); + + /* Stash the new object in the list */ + + elemPtrs[ index ] = valuePtr; + + return TCL_OK; + +} + +/* + *---------------------------------------------------------------------- + * * FreeListInternalRep -- * * Deallocate the storage associated with a list object's internal @@ -772,7 +1366,7 @@ Tcl_ListObjReplace(interp, listPtr, first, count, objc, objv) * * Side effects: * Frees listPtr's List* internal representation and sets listPtr's - * internalRep.otherValuePtr to NULL. Decrements the ref counts + * internalRep.twoPtrValue.ptr1 to NULL. Decrements the ref counts * of all element objects, which may free them. * *---------------------------------------------------------------------- @@ -782,7 +1376,7 @@ static void FreeListInternalRep(listPtr) Tcl_Obj *listPtr; /* List object with internal rep to free. */ { - register List *listRepPtr = (List *) listPtr->internalRep.otherValuePtr; + register List *listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; register Tcl_Obj **elemPtrs = listRepPtr->elements; register Tcl_Obj *objPtr; int numElems = listRepPtr->elemCount; @@ -794,6 +1388,9 @@ FreeListInternalRep(listPtr) } ckfree((char *) elemPtrs); ckfree((char *) listRepPtr); + + listPtr->internalRep.twoPtrValue.ptr1 = NULL; + listPtr->internalRep.twoPtrValue.ptr2 = NULL; } /* @@ -823,7 +1420,7 @@ DupListInternalRep(srcPtr, copyPtr) Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ Tcl_Obj *copyPtr; /* Object with internal rep to set. */ { - List *srcListRepPtr = (List *) srcPtr->internalRep.otherValuePtr; + List *srcListRepPtr = (List *) srcPtr->internalRep.twoPtrValue.ptr1; int numElems = srcListRepPtr->elemCount; int maxElems = srcListRepPtr->maxElemCount; register Tcl_Obj **srcElemPtrs = srcListRepPtr->elements; @@ -849,7 +1446,8 @@ DupListInternalRep(srcPtr, copyPtr) copyListRepPtr->elemCount = numElems; copyListRepPtr->elements = copyElemPtrs; - copyPtr->internalRep.otherValuePtr = (VOID *) copyListRepPtr; + copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) copyListRepPtr; + copyPtr->internalRep.twoPtrValue.ptr2 = NULL; copyPtr->typePtr = &tclListType; } @@ -975,7 +1573,8 @@ SetListFromAny(interp, objPtr) oldTypePtr->freeIntRepProc(objPtr); } - objPtr->internalRep.otherValuePtr = (VOID *) listRepPtr; + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = &tclListType; return TCL_OK; } @@ -1007,7 +1606,7 @@ UpdateStringOfList(listPtr) { # define LOCAL_SIZE 20 int localFlags[LOCAL_SIZE], *flagPtr; - List *listRepPtr = (List *) listPtr->internalRep.otherValuePtr; + List *listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; int numElems = listRepPtr->elemCount; register int i; char *elem, *dst; diff --git a/tcl/generic/tclLiteral.c b/tcl/generic/tclLiteral.c index 37b1d33aa84..bee26f4251a 100644 --- a/tcl/generic/tclLiteral.c +++ b/tcl/generic/tclLiteral.c @@ -696,31 +696,10 @@ TclReleaseLiteral(interp, objPtr) entryPtr->refCount--; /* - * We found the matching LiteralEntry. Check if it's only being - * kept alive only by a circular reference from a ByteCode - * stored as its internal rep. - */ - - if ((entryPtr->refCount == 1) - && (objPtr->typePtr == &tclByteCodeType)) { - codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; - if ((codePtr->numLitObjects == 1) - && (codePtr->objArrayPtr[0] == objPtr)) { - entryPtr->refCount = 0; - - /* - * Set the ByteCode object array entry NULL to signal - * to TclCleanupByteCode to not try to release this - * about to be freed literal again. - */ - - codePtr->objArrayPtr[0] = NULL; - } - } - - /* * If the literal is no longer being used by any ByteCode, - * delete the entry then decrement the ref count of its object. + * 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) { @@ -729,27 +708,40 @@ TclReleaseLiteral(interp, objPtr) } else { prevPtr->nextPtr = entryPtr->nextPtr; } -#ifdef TCL_COMPILE_STATS - iPtr->stats.currentLitStringBytes -= (double) (length + 1); -#endif /*TCL_COMPILE_STATS*/ ckfree((char *) entryPtr); globalTablePtr->numEntries--; + TclDecrRefCount(objPtr); + /* - * Remove the reference corresponding to the global - * literal table entry. + * Check if the LiteralEntry is only being kept alive by + * a circular reference from a ByteCode stored as its + * internal rep. In that case, set the ByteCode object array + * entry NULL to signal to TclCleanupByteCode to not try to + * release this about to be freed literal again. */ + + if (objPtr->typePtr == &tclByteCodeType) { + codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + if ((codePtr->numLitObjects == 1) + && (codePtr->objArrayPtr[0] == objPtr)) { + codePtr->objArrayPtr[0] = NULL; + } + } - TclDecrRefCount(objPtr); +#ifdef TCL_COMPILE_STATS + iPtr->stats.currentLitStringBytes -= (double) (length + 1); +#endif /*TCL_COMPILE_STATS*/ } break; } } - + /* * Remove the reference corresponding to the local literal table * entry. */ + Tcl_DecrRefCount(objPtr); } diff --git a/tcl/generic/tclLoad.c b/tcl/generic/tclLoad.c index 81e963a6e86..eb3dbefeddf 100644 --- a/tcl/generic/tclLoad.c +++ b/tcl/generic/tclLoad.c @@ -19,7 +19,8 @@ * 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, so these structures are never freed. + * are never unloaded, until the application exits, when + * TclFinalizeLoad is called, and these structures are freed. */ typedef struct LoadedPackage { @@ -31,8 +32,8 @@ typedef struct LoadedPackage { * properly capitalized (first letter UC, * others LC), no "_", as in "Net". * Malloc-ed. */ - ClientData clientData; /* Token for the loaded file which should be - * passed to TclpUnloadFile() when the file + Tcl_LoadHandle loadHandle; /* Token for the loaded file which should be + * passed to (*unLoadProcPtr)() when the file * is no longer needed. If fileName is NULL, * then this field is irrelevant. */ Tcl_PackageInitProc *initProc; @@ -46,6 +47,11 @@ typedef struct LoadedPackage { * untrusted scripts). NULL means the * package can't be used in unsafe * interpreters. */ + Tcl_FSUnloadFileProc *unLoadProcPtr; + /* Procedure to use to unload this package. + * If NULL, then we do not attempt to unload + * the package. If fileName is NULL, then + * this field is irrelevant. */ struct LoadedPackage *nextPtr; /* Next in list of all packages loaded into * this application process. NULL means @@ -113,12 +119,13 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) { Tcl_Interp *target; LoadedPackage *pkgPtr, *defaultPtr; - Tcl_DString pkgName, tmp, initName, safeInitName, fileName; + Tcl_DString pkgName, tmp, initName, safeInitName; Tcl_PackageInitProc *initProc, *safeInitProc; InterpPackage *ipFirstPtr, *ipPtr; int code, namesMatch, filesMatch; - char *p, *tempString, *fullFileName, *packageName; - ClientData clientData; + char *p, *fullFileName, *packageName; + Tcl_LoadHandle loadHandle; + Tcl_FSUnloadFileProc *unLoadProcPtr = NULL; Tcl_UniChar ch; int offset; @@ -126,11 +133,11 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) Tcl_WrongNumArgs(interp, 1, objv, "fileName ?packageName? ?interp?"); return TCL_ERROR; } - tempString = Tcl_GetString(objv[1]); - fullFileName = Tcl_TranslateFileName(interp, tempString, &fileName); - if (fullFileName == NULL) { + if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) { return TCL_ERROR; } + fullFileName = Tcl_GetString(objv[1]); + Tcl_DStringInit(&pkgName); Tcl_DStringInit(&initName); Tcl_DStringInit(&safeInitName); @@ -265,8 +272,10 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) */ retc = TclGuessPackageName(fullFileName, &pkgName); if (!retc) { - int pargc; - char **pargv, *pkgGuess; + Tcl_Obj *splitPtr; + Tcl_Obj *pkgGuessPtr; + int pElements; + char *pkgGuess; /* * The platform-specific code couldn't figure out the @@ -276,8 +285,9 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) * characters that follow that. */ - Tcl_SplitPath(fullFileName, &pargc, &pargv); - pkgGuess = pargv[pargc-1]; + 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; @@ -291,7 +301,7 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) } } if (p == pkgGuess) { - ckfree((char *)pargv); + Tcl_DecrRefCount(splitPtr); Tcl_AppendResult(interp, "couldn't figure out package name for ", fullFileName, (char *) NULL); @@ -299,7 +309,7 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) goto done; } Tcl_DStringAppend(&pkgName, pkgGuess, (p - pkgGuess)); - ckfree((char *)pargv); + Tcl_DecrRefCount(splitPtr); } } @@ -328,9 +338,9 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) */ Tcl_MutexLock(&packageMutex); - code = TclpLoadFile(interp, fullFileName, Tcl_DStringValue(&initName), + code = Tcl_FSLoadFile(interp, objv[1], Tcl_DStringValue(&initName), Tcl_DStringValue(&safeInitName), &initProc, &safeInitProc, - &clientData); + &loadHandle,&unLoadProcPtr); Tcl_MutexUnlock(&packageMutex); if (code != TCL_OK) { goto done; @@ -338,7 +348,9 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) if (initProc == NULL) { Tcl_AppendResult(interp, "couldn't find procedure ", Tcl_DStringValue(&initName), (char *) NULL); - TclpUnloadFile(clientData); + if (unLoadProcPtr != NULL) { + (*unLoadProcPtr)(loadHandle); + } code = TCL_ERROR; goto done; } @@ -354,7 +366,8 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) pkgPtr->packageName = (char *) ckalloc((unsigned) (Tcl_DStringLength(&pkgName) + 1)); strcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName)); - pkgPtr->clientData = clientData; + pkgPtr->loadHandle = loadHandle; + pkgPtr->unLoadProcPtr = unLoadProcPtr; pkgPtr->initProc = initProc; pkgPtr->safeInitProc = safeInitProc; Tcl_MutexLock(&packageMutex); @@ -410,7 +423,6 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) Tcl_DStringFree(&pkgName); Tcl_DStringFree(&initName); Tcl_DStringFree(&safeInitName); - Tcl_DStringFree(&fileName); Tcl_DStringFree(&tmp); return code; } @@ -439,7 +451,7 @@ Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc) * package has already been loaded * into the given interpreter by * calling the appropriate init proc. */ - char *pkgName; /* Name of package (must be properly + CONST char *pkgName; /* Name of package (must be properly * capitalized: first letter upper * case, others lower case). */ Tcl_PackageInitProc *initProc; /* Procedure to call to incorporate @@ -478,7 +490,7 @@ Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc) pkgPtr->packageName = (char *) ckalloc((unsigned) (strlen(pkgName) + 1)); strcpy(pkgPtr->packageName, pkgName); - pkgPtr->clientData = NULL; + pkgPtr->loadHandle = NULL; pkgPtr->initProc = initProc; pkgPtr->safeInitProc = safeInitProc; Tcl_MutexLock(&packageMutex); @@ -653,7 +665,10 @@ TclFinalizeLoad() * call a function in the dll after it's been unloaded. */ if (pkgPtr->fileName[0] != '\0') { - TclpUnloadFile(pkgPtr->clientData); + Tcl_FSUnloadFileProc *unLoadProcPtr = pkgPtr->unLoadProcPtr; + if (unLoadProcPtr != NULL) { + (*unLoadProcPtr)(pkgPtr->loadHandle); + } } #endif ckfree(pkgPtr->fileName); diff --git a/tcl/generic/tclLoadNone.c b/tcl/generic/tclLoadNone.c index 35180f5ff52..480331b3e34 100644 --- a/tcl/generic/tclLoadNone.c +++ b/tcl/generic/tclLoadNone.c @@ -18,7 +18,7 @@ /* *---------------------------------------------------------------------- * - * TclpLoadFile -- + * TclpDlopen -- * * This procedure is called to carry out dynamic loading of binary * code; it is intended for use only on systems that don't support @@ -35,18 +35,17 @@ */ int -TclpLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr) +TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr) Tcl_Interp *interp; /* Used for error reporting. */ - char *fileName; /* Name of the file containing the desired - * code. */ - char *sym1, *sym2; /* Names of two procedures to look up in - * the file's symbol table. */ - Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; - /* Where to return the addresses corresponding - * to sym1 and sym2. */ - ClientData *clientDataPtr; /* Filled with token for dynamically loaded + Tcl_Obj *pathPtr; /* Name of the file containing the desired + * code (UTF-8). */ + Tcl_LoadHandle *loadHandle; /* Filled with token for dynamically loaded * file which will be passed back to - * TclpUnloadFile() to unload the file. */ + * (*unloadProcPtr)() to unload the file. */ + Tcl_FSUnloadFileProc **unloadProcPtr; + /* Filled with address of Tcl_FSUnloadFileProc + * function which should be used for + * this file. */ { Tcl_SetResult(interp, "dynamic loading is not currently available on this system", @@ -57,6 +56,30 @@ TclpLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr) /* *---------------------------------------------------------------------- * + * TclpFindSymbol -- + * + * Looks up a symbol, by name, through a handle associated with + * a previously loaded piece of code (shared library). + * + * Results: + * Returns a pointer to the function associated with 'symbol' if + * it is found. Otherwise returns NULL and may leave an error + * message in the interp's result. + * + *---------------------------------------------------------------------- + */ +Tcl_PackageInitProc* +TclpFindSymbol(interp, loadHandle, symbol) + Tcl_Interp *interp; + Tcl_LoadHandle loadHandle; + CONST char *symbol; +{ + return NULL; +} + +/* + *---------------------------------------------------------------------- + * * TclGuessPackageName -- * * If the "load" command is invoked without providing a package @@ -76,7 +99,7 @@ TclpLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr) int TclGuessPackageName(fileName, bufPtr) - char *fileName; /* Name of file containing package (already + CONST char *fileName; /* Name of file containing package (already * translated to local form if needed). */ Tcl_DString *bufPtr; /* Initialized empty dstring. Append * package name to this if possible. */ @@ -103,10 +126,10 @@ TclGuessPackageName(fileName, bufPtr) */ void -TclpUnloadFile(clientData) - ClientData clientData; /* ClientData returned by a previous call - * to TclpLoadFile(). The clientData is - * a token that represents the loaded - * file. */ +TclpUnloadFile(loadHandle) + Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call + * to TclpDlopen(). The loadHandle is + * a token that represents the loaded + * file. */ { } diff --git a/tcl/generic/tclMain.c b/tcl/generic/tclMain.c index a89d0caf3f3..eedbd8d4a44 100644 --- a/tcl/generic/tclMain.c +++ b/tcl/generic/tclMain.c @@ -5,6 +5,7 @@ * * Copyright (c) 1988-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 2000 Ajuba Solutions. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -19,35 +20,111 @@ # define TCL_STORAGE_CLASS DLLEXPORT /* - * The following code ensures that tclLink.c is linked whenever - * Tcl is linked. Without this code there's no reference to the - * code in that file from anywhere in Tcl, so it may not be - * linked into the application. - */ - -EXTERN int Tcl_LinkVar(); -int (*tclDummyLinkVarPtr)() = Tcl_LinkVar; - -/* * Declarations for various library procedures and variables (don't want * to include tclPort.h here, because people might copy this file out of * the Tcl source directory to make their own modified versions). - * Note: "exit" should really be declared here, but there's no way to - * declare it without causing conflicts with other definitions elsewher - * on some systems, so it's better just to leave it out. */ +#if !defined(MAC_TCL) extern int isatty _ANSI_ARGS_((int fd)); -extern char * strcpy _ANSI_ARGS_((char *dst, CONST char *src)); +#else +#include <unistd.h> +#endif + +static Tcl_Obj *tclStartupScriptPath = NULL; -static char *tclStartupScriptFileName = NULL; +static Tcl_MainLoopProc *mainLoopProc = NULL; +/* + * Structure definition for information used to keep the state of + * an interactive command processor that reads lines from standard + * input and writes prompts and results to standard output. + */ + +typedef enum { + PROMPT_NONE, /* Print no prompt */ + PROMPT_START, /* Print prompt for command start */ + PROMPT_CONTINUE /* Print prompt for command continuation */ +} PromptType; + +typedef struct InteractiveState { + Tcl_Channel input; /* The standard input channel from which + * lines are read. */ + int tty; /* Non-zero means standard input is a + * terminal-like device. Zero means it's + * a file. */ + Tcl_Obj *commandPtr; /* Used to assemble lines of input into + * Tcl commands. */ + PromptType prompt; /* Next prompt to print */ + Tcl_Interp *interp; /* Interpreter that evaluates interactive + * commands. */ +} InteractiveState; + +/* + * Forward declarations for procedures defined later in this file. + */ +static void Prompt _ANSI_ARGS_((Tcl_Interp *interp, + PromptType *promptPtr)); +static void StdinProc _ANSI_ARGS_((ClientData clientData, + int mask)); /* *---------------------------------------------------------------------- * + * TclSetStartupScriptPath -- + * + * Primes the startup script VFS path, used to override the + * command line processing. + * + * Results: + * None. + * + * Side effects: + * This procedure initializes the VFS path of the Tcl script to + * run at startup. + * + *---------------------------------------------------------------------- + */ +void TclSetStartupScriptPath(pathPtr) + Tcl_Obj *pathPtr; +{ + if (tclStartupScriptPath != NULL) { + Tcl_DecrRefCount(tclStartupScriptPath); + } + tclStartupScriptPath = pathPtr; + if (tclStartupScriptPath != NULL) { + Tcl_IncrRefCount(tclStartupScriptPath); + } +} + + +/* + *---------------------------------------------------------------------- + * + * TclGetStartupScriptPath -- + * + * Gets the startup script VFS path, used to override the + * command line processing. + * + * Results: + * The startup script VFS path, NULL if none has been set. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +Tcl_Obj *TclGetStartupScriptPath() +{ + return tclStartupScriptPath; +} + + +/* + *---------------------------------------------------------------------- + * * TclSetStartupScriptFileName -- * * Primes the startup script file name, used to override the @@ -63,9 +140,10 @@ static char *tclStartupScriptFileName = NULL; *---------------------------------------------------------------------- */ void TclSetStartupScriptFileName(fileName) - char *fileName; + CONST char *fileName; { - tclStartupScriptFileName = fileName; + Tcl_Obj *pathPtr = Tcl_NewStringObj(fileName,-1); + TclSetStartupScriptPath(pathPtr); } @@ -85,9 +163,14 @@ void TclSetStartupScriptFileName(fileName) * *---------------------------------------------------------------------- */ -char *TclGetStartupScriptFileName() +CONST char *TclGetStartupScriptFileName() { - return tclStartupScriptFileName; + Tcl_Obj *pathPtr = TclGetStartupScriptPath(); + + if (pathPtr == NULL) { + return NULL; + } + return Tcl_GetString(pathPtr); } @@ -101,7 +184,7 @@ char *TclGetStartupScriptFileName() * * Results: * None. This procedure never returns (it exits the process when - * it's done. + * it's done). * * Side effects: * This procedure initializes the Tcl world and then starts @@ -123,18 +206,18 @@ Tcl_Main(argc, argv, appInitProc) { Tcl_Obj *resultPtr; Tcl_Obj *commandPtr = NULL; - char buffer[1000], *args; - int code, gotPartial, tty, length; + char buffer[TCL_INTEGER_SPACE + 5], *args; + PromptType prompt = PROMPT_START; + int code, length, tty; int exitCode = 0; Tcl_Channel inChannel, outChannel, errChannel; Tcl_Interp *interp; Tcl_DString argString; Tcl_FindExecutable(argv[0]); + interp = Tcl_CreateInterp(); -#ifdef TCL_MEM_DEBUG Tcl_InitMemory(interp); -#endif /* * Make command-line arguments available in the Tcl variables "argc" @@ -142,27 +225,34 @@ Tcl_Main(argc, argv, appInitProc) * strip it off and use it as the name of a script file to process. */ - if (tclStartupScriptFileName == NULL) { + if (TclGetStartupScriptPath() == NULL) { if ((argc > 1) && (argv[1][0] != '-')) { - tclStartupScriptFileName = argv[1]; + TclSetStartupScriptFileName(argv[1]); argc--; argv++; } } - args = Tcl_Merge(argc-1, argv+1); + + /* + * The CONST casting is safe, and better we do it here than force + * all callers of Tcl_Main to do it. (Those callers are likely + * in a main() that can't easily change its signature.) + */ + + args = Tcl_Merge(argc-1, (CONST char **)argv+1); Tcl_ExternalToUtfDString(NULL, args, -1, &argString); Tcl_SetVar(interp, "argv", Tcl_DStringValue(&argString), TCL_GLOBAL_ONLY); Tcl_DStringFree(&argString); ckfree(args); - if (tclStartupScriptFileName == NULL) { + if (TclGetStartupScriptPath() == NULL) { Tcl_ExternalToUtfDString(NULL, argv[0], -1, &argString); } else { - tclStartupScriptFileName = Tcl_ExternalToUtfDString(NULL, - tclStartupScriptFileName, -1, &argString); + TclSetStartupScriptFileName(Tcl_ExternalToUtfDString(NULL, + TclGetStartupScriptFileName(), -1, &argString)); } - TclFormatInt(buffer, argc-1); + TclFormatInt(buffer, (long) argc-1); Tcl_SetVar(interp, "argc", buffer, TCL_GLOBAL_ONLY); Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&argString), TCL_GLOBAL_ONLY); @@ -172,13 +262,14 @@ Tcl_Main(argc, argv, appInitProc) tty = isatty(0); Tcl_SetVar(interp, "tcl_interactive", - ((tclStartupScriptFileName == NULL) && tty) ? "1" : "0", + ((TclGetStartupScriptPath() == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY); /* * Invoke application-specific initialization. */ + Tcl_Preserve((ClientData) interp); if ((*appInitProc)(interp) != TCL_OK) { errChannel = Tcl_GetStdChannel(TCL_STDERR); if (errChannel) { @@ -188,17 +279,21 @@ Tcl_Main(argc, argv, appInitProc) Tcl_WriteChars(errChannel, "\n", 1); } } + if (Tcl_InterpDeleted(interp)) { + goto done; + } /* * If a script file was specified then just source that file * and quit. */ - if (tclStartupScriptFileName != NULL) { - code = Tcl_EvalFile(interp, tclStartupScriptFileName); + if (TclGetStartupScriptPath() != NULL) { + code = Tcl_FSEvalFile(interp, TclGetStartupScriptPath()); if (code != TCL_OK) { errChannel = Tcl_GetStdChannel(TCL_STDERR); if (errChannel) { + /* * The following statement guarantees that the errorInfo * variable is set properly. @@ -231,63 +326,68 @@ Tcl_Main(argc, argv, appInitProc) commandPtr = Tcl_NewObj(); Tcl_IncrRefCount(commandPtr); + /* + * Get a new value for tty if anyone writes to ::tcl_interactive + */ + Tcl_LinkVar(interp, "tcl_interactive", (char *) &tty, TCL_LINK_BOOLEAN); inChannel = Tcl_GetStdChannel(TCL_STDIN); outChannel = Tcl_GetStdChannel(TCL_STDOUT); - gotPartial = 0; - while (1) { + while ((inChannel != (Tcl_Channel) NULL) && !Tcl_InterpDeleted(interp)) { if (tty) { - Tcl_Obj *promptCmdPtr; - - promptCmdPtr = Tcl_GetVar2Ex(interp, - (gotPartial ? "tcl_prompt2" : "tcl_prompt1"), - NULL, TCL_GLOBAL_ONLY); - if (promptCmdPtr == NULL) { - defaultPrompt: - if (!gotPartial && outChannel) { - Tcl_WriteChars(outChannel, "% ", 2); - } - } else { - code = Tcl_EvalObjEx(interp, promptCmdPtr, 0); - inChannel = Tcl_GetStdChannel(TCL_STDIN); - outChannel = Tcl_GetStdChannel(TCL_STDOUT); - errChannel = Tcl_GetStdChannel(TCL_STDERR); - if (code != TCL_OK) { - if (errChannel) { - Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); - Tcl_WriteChars(errChannel, "\n", 1); - } - Tcl_AddErrorInfo(interp, - "\n (script that generates prompt)"); - goto defaultPrompt; - } + Prompt(interp, &prompt); + if (Tcl_InterpDeleted(interp)) { + break; } - if (outChannel) { - Tcl_Flush(outChannel); + inChannel = Tcl_GetStdChannel(TCL_STDIN); + if (inChannel == (Tcl_Channel) NULL) { + break; } } - if (!inChannel) { - goto done; + if (Tcl_IsShared(commandPtr)) { + Tcl_DecrRefCount(commandPtr); + commandPtr = Tcl_DuplicateObj(commandPtr); + Tcl_IncrRefCount(commandPtr); } length = Tcl_GetsObj(inChannel, commandPtr); if (length < 0) { - goto done; - } - if ((length == 0) && Tcl_Eof(inChannel) && (!gotPartial)) { - goto done; + if (Tcl_InputBlocked(inChannel)) { + + /* + * This can only happen if stdin has been set to + * non-blocking. In that case cycle back and try + * again. This sets up a tight polling loop (since + * we have no event loop running). If this causes + * bad CPU hogging, we might try toggling the blocking + * on stdin instead. + */ + + continue; + } + + /* + * Either EOF, or an error on stdin; we're done + */ + + break; } /* * Add the newline removed by Tcl_GetsObj back to the string. */ + if (Tcl_IsShared(commandPtr)) { + Tcl_DecrRefCount(commandPtr); + commandPtr = Tcl_DuplicateObj(commandPtr); + Tcl_IncrRefCount(commandPtr); + } Tcl_AppendToObj(commandPtr, "\n", 1); if (!TclObjCommandComplete(commandPtr)) { - gotPartial = 1; + prompt = PROMPT_CONTINUE; continue; } - gotPartial = 0; - code = Tcl_RecordAndEvalObj(interp, commandPtr, 0); + prompt = PROMPT_START; + code = Tcl_RecordAndEvalObj(interp, commandPtr, TCL_EVAL_GLOBAL); inChannel = Tcl_GetStdChannel(TCL_STDIN); outChannel = Tcl_GetStdChannel(TCL_STDOUT); errChannel = Tcl_GetStdChannel(TCL_STDERR); @@ -301,31 +401,325 @@ Tcl_Main(argc, argv, appInitProc) } } else if (tty) { resultPtr = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(resultPtr); Tcl_GetStringFromObj(resultPtr, &length); if ((length > 0) && outChannel) { Tcl_WriteObj(outChannel, resultPtr); Tcl_WriteChars(outChannel, "\n", 1); } + Tcl_DecrRefCount(resultPtr); + } + if (mainLoopProc != NULL) { + + /* + * If a main loop has been defined while running interactively, + * we want to start a fileevent based prompt by establishing a + * channel handler for stdin. + */ + + InteractiveState *isPtr = NULL; + + if (inChannel) { + if (tty) { + Prompt(interp, &prompt); + } + isPtr = (InteractiveState *) + ckalloc((int) sizeof(InteractiveState)); + isPtr->input = inChannel; + isPtr->tty = tty; + isPtr->commandPtr = commandPtr; + isPtr->prompt = prompt; + isPtr->interp = interp; + + Tcl_UnlinkVar(interp, "tcl_interactive"); + Tcl_LinkVar(interp, "tcl_interactive", (char *) &(isPtr->tty), + TCL_LINK_BOOLEAN); + + Tcl_CreateChannelHandler(inChannel, TCL_READABLE, StdinProc, + (ClientData) isPtr); + } + + (*mainLoopProc)(); + mainLoopProc = NULL; + + if (inChannel) { + tty = isPtr->tty; + Tcl_UnlinkVar(interp, "tcl_interactive"); + Tcl_LinkVar(interp, "tcl_interactive", (char *) &tty, + TCL_LINK_BOOLEAN); + prompt = isPtr->prompt; + commandPtr = isPtr->commandPtr; + if (isPtr->input != (Tcl_Channel) NULL) { + Tcl_DeleteChannelHandler(isPtr->input, StdinProc, + (ClientData) isPtr); + } + ckfree((char *)isPtr); + } + inChannel = Tcl_GetStdChannel(TCL_STDIN); + outChannel = Tcl_GetStdChannel(TCL_STDOUT); + errChannel = Tcl_GetStdChannel(TCL_STDERR); } #ifdef TCL_MEM_DEBUG + + /* + * This code here only for the (unsupported and deprecated) + * [checkmem] command. + */ + if (tclMemDumpFileName != NULL) { - Tcl_DecrRefCount(commandPtr); + mainLoopProc = NULL; Tcl_DeleteInterp(interp); - Tcl_Exit(0); } #endif } + done: + if ((exitCode == 0) && (mainLoopProc != NULL)) { + + /* + * If everything has gone OK so far, call the main loop proc, + * if it exists. Packages (like Tk) can set it to start processing + * events at this point. + */ + + (*mainLoopProc)(); + mainLoopProc = NULL; + } + if (commandPtr != NULL) { + Tcl_DecrRefCount(commandPtr); + } + /* * Rather than calling exit, invoke the "exit" command so that * users can replace "exit" with some other command to do additional * cleanup on exit. The Tcl_Eval call should never return. */ - done: - if (commandPtr != NULL) { + if (!Tcl_InterpDeleted(interp)) { + sprintf(buffer, "exit %d", exitCode); + Tcl_Eval(interp, buffer); + + /* + * If Tcl_Eval returns, trying to eval [exit], something + * unusual is happening. Maybe interp has been deleted; + * maybe [exit] was redefined. We still want to cleanup + * and exit. + */ + + if (!Tcl_InterpDeleted(interp)) { + Tcl_DeleteInterp(interp); + } + } + TclSetStartupScriptPath(NULL); + + /* + * If we get here, the master interp has been deleted. Allow + * its destruction with the last matching Tcl_Release. + */ + + Tcl_Release((ClientData) interp); + Tcl_Exit(exitCode); +} + +/* + *--------------------------------------------------------------- + * + * Tcl_SetMainLoop -- + * + * Sets an alternative main loop procedure. + * + * Results: + * Returns the previously defined main loop procedure. + * + * Side effects: + * This procedure will be called before Tcl exits, allowing for + * the creation of an event loop. + * + *--------------------------------------------------------------- + */ + +void +Tcl_SetMainLoop(proc) + Tcl_MainLoopProc *proc; +{ + mainLoopProc = proc; +} + +/* + *---------------------------------------------------------------------- + * + * StdinProc -- + * + * This procedure is invoked by the event dispatcher whenever + * standard input becomes readable. It grabs the next line of + * input characters, adds them to a command being assembled, and + * executes the command if it's complete. + * + * Results: + * None. + * + * Side effects: + * Could be almost arbitrary, depending on the command that's + * typed. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +StdinProc(clientData, mask) + ClientData clientData; /* The state of interactive cmd line */ + int mask; /* Not used. */ +{ + InteractiveState *isPtr = (InteractiveState *) clientData; + Tcl_Channel chan = isPtr->input; + Tcl_Obj *commandPtr = isPtr->commandPtr; + Tcl_Interp *interp = isPtr->interp; + int code, length; + + if (Tcl_IsShared(commandPtr)) { + Tcl_DecrRefCount(commandPtr); + commandPtr = Tcl_DuplicateObj(commandPtr); + Tcl_IncrRefCount(commandPtr); + } + length = Tcl_GetsObj(chan, commandPtr); + if (length < 0) { + if (Tcl_InputBlocked(chan)) { + return; + } + if (isPtr->tty) { + /* + * Would be better to find a way to exit the mainLoop? + * Or perhaps evaluate [exit]? Leaving as is for now due + * to compatibility concerns. + */ + Tcl_Exit(0); + } + Tcl_DeleteChannelHandler(chan, StdinProc, (ClientData) isPtr); + return; + } + + if (Tcl_IsShared(commandPtr)) { Tcl_DecrRefCount(commandPtr); + commandPtr = Tcl_DuplicateObj(commandPtr); + Tcl_IncrRefCount(commandPtr); + } + Tcl_AppendToObj(commandPtr, "\n", 1); + if (!TclObjCommandComplete(commandPtr)) { + isPtr->prompt = PROMPT_CONTINUE; + goto prompt; + } + isPtr->prompt = PROMPT_START; + + /* + * Disable the stdin channel handler while evaluating the command; + * otherwise if the command re-enters the event loop we might + * process commands from stdin before the current command is + * finished. Among other things, this will trash the text of the + * command being evaluated. + */ + + Tcl_CreateChannelHandler(chan, 0, StdinProc, (ClientData) isPtr); + code = Tcl_RecordAndEvalObj(interp, commandPtr, TCL_EVAL_GLOBAL); + isPtr->input = chan = Tcl_GetStdChannel(TCL_STDIN); + Tcl_DecrRefCount(commandPtr); + isPtr->commandPtr = commandPtr = Tcl_NewObj(); + Tcl_IncrRefCount(commandPtr); + if (chan != (Tcl_Channel) NULL) { + Tcl_CreateChannelHandler(chan, TCL_READABLE, StdinProc, + (ClientData) isPtr); + } + if (code != TCL_OK) { + Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel != (Tcl_Channel) NULL) { + Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); + Tcl_WriteChars(errChannel, "\n", 1); + } + } else if (isPtr->tty) { + Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); + Tcl_Channel outChannel = Tcl_GetStdChannel(TCL_STDOUT); + Tcl_IncrRefCount(resultPtr); + Tcl_GetStringFromObj(resultPtr, &length); + if ((length >0) && (outChannel != (Tcl_Channel) NULL)) { + Tcl_WriteObj(outChannel, resultPtr); + Tcl_WriteChars(outChannel, "\n", 1); + } + Tcl_DecrRefCount(resultPtr); + } + + /* + * If a tty stdin is still around, output a prompt. + */ + + prompt: + if (isPtr->tty && (isPtr->input != (Tcl_Channel) NULL)) { + Prompt(interp, &(isPtr->prompt)); + isPtr->input = Tcl_GetStdChannel(TCL_STDIN); + } +} + +/* + *---------------------------------------------------------------------- + * + * Prompt -- + * + * Issue a prompt on standard output, or invoke a script + * to issue the prompt. + * + * Results: + * None. + * + * Side effects: + * A prompt gets output, and a Tcl script may be evaluated + * in interp. + * + *---------------------------------------------------------------------- + */ + +static void +Prompt(interp, promptPtr) + Tcl_Interp *interp; /* Interpreter to use for prompting. */ + PromptType *promptPtr; /* Points to type of prompt to print. + * Filled with PROMPT_NONE after a + * prompt is printed. */ +{ + Tcl_Obj *promptCmdPtr; + int code; + Tcl_Channel outChannel, errChannel; + + if (*promptPtr == PROMPT_NONE) { + return; + } + + promptCmdPtr = Tcl_GetVar2Ex(interp, + ((*promptPtr == PROMPT_CONTINUE) ? "tcl_prompt2" : "tcl_prompt1"), + NULL, TCL_GLOBAL_ONLY); + if (Tcl_InterpDeleted(interp)) { + return; + } + if (promptCmdPtr == NULL) { + defaultPrompt: + outChannel = Tcl_GetStdChannel(TCL_STDOUT); + if ((*promptPtr == PROMPT_START) + && (outChannel != (Tcl_Channel) NULL)) { + Tcl_WriteChars(outChannel, "% ", 2); + } + } else { + code = Tcl_EvalObjEx(interp, promptCmdPtr, TCL_EVAL_GLOBAL); + if (code != TCL_OK) { + Tcl_AddErrorInfo(interp, + "\n (script that generates prompt)"); + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel != (Tcl_Channel) NULL) { + Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); + Tcl_WriteChars(errChannel, "\n", 1); + } + goto defaultPrompt; + } + } + outChannel = Tcl_GetStdChannel(TCL_STDOUT); + if (outChannel != (Tcl_Channel) NULL) { + Tcl_Flush(outChannel); } - sprintf(buffer, "exit %d", exitCode); - Tcl_Eval(interp, buffer); + *promptPtr = PROMPT_NONE; } diff --git a/tcl/generic/tclNamesp.c b/tcl/generic/tclNamesp.c index 38f7d2a794c..b628a35de72 100644 --- a/tcl/generic/tclNamesp.c +++ b/tcl/generic/tclNamesp.c @@ -104,6 +104,9 @@ static int NamespaceDeleteCmd _ANSI_ARGS_(( static int NamespaceEvalCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +static int NamespaceExistsCmd _ANSI_ARGS_(( + ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[])); static int NamespaceExportCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); @@ -163,7 +166,7 @@ Tcl_ObjType tclNsNameType = { * None. * * Side effects: - * The namespace object type is registered with the Tcl compiler. + * None. * *---------------------------------------------------------------------- */ @@ -171,7 +174,9 @@ Tcl_ObjType tclNsNameType = { void TclInitNamespaceSubsystem() { - Tcl_RegisterObjType(&tclNsNameType); + /* + * Does nothing for now. + */ } /* @@ -427,7 +432,7 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc) Tcl_Interp *interp; /* Interpreter in which a new namespace * is being created. Also used for * error reporting. */ - char *name; /* Name for the new namespace. May be a + CONST char *name; /* Name for the new namespace. May be a * qualified name with names of ancestor * namespaces separated by "::"s. */ ClientData clientData; /* One-word value to store with @@ -442,7 +447,7 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc) register Namespace *nsPtr, *ancestorPtr; Namespace *parentPtr, *dummy1Ptr, *dummy2Ptr; Namespace *globalNsPtr = iPtr->globalNsPtr; - char *simpleName; + CONST char *simpleName; Tcl_HashEntry *entryPtr; Tcl_DString buffer1, buffer2; int newEntry; @@ -715,7 +720,8 @@ TclTeardownNamespace(nsPtr) * variables, in case they had any traces on them. */ - char *str, *errorInfoStr, *errorCodeStr; + CONST char *str; + char *errorInfoStr, *errorCodeStr; str = Tcl_GetVar((Tcl_Interp *) iPtr, "errorInfo", TCL_GLOBAL_ONLY); if (str != NULL) { @@ -896,7 +902,7 @@ Tcl_Export(interp, namespacePtr, pattern, resetListFirst) Tcl_Namespace *namespacePtr; /* Points to the namespace from which * commands are to be exported. NULL for * the current namespace. */ - char *pattern; /* String pattern indicating which commands + CONST char *pattern; /* String pattern indicating which commands * to export. This pattern may not include * any namespace qualifiers; only commands * in the specified namespace may be @@ -909,7 +915,8 @@ Tcl_Export(interp, namespacePtr, pattern, resetListFirst) #define INIT_EXPORT_PATTERNS 5 Namespace *nsPtr, *exportNsPtr, *dummyPtr; Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); - char *simplePattern, *patternCpy; + CONST char *simplePattern; + char *patternCpy; int neededElems, len, i; /* @@ -1096,7 +1103,7 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite) Tcl_Namespace *namespacePtr; /* Points to the namespace into which the * commands are to be imported. NULL for * the current namespace. */ - char *pattern; /* String pattern indicating which commands + CONST char *pattern; /* String pattern indicating which commands * to import. This pattern should be * qualified by the name of the namespace * from which to import the command(s). */ @@ -1108,7 +1115,8 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite) Interp *iPtr = (Interp *) interp; Namespace *nsPtr, *importNsPtr, *dummyPtr; Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); - char *simplePattern, *cmdName; + CONST char *simplePattern; + char *cmdName; register Tcl_HashEntry *hPtr; Tcl_HashSearch search; Command *cmdPtr, *realCmdPtr; @@ -1265,6 +1273,7 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite) "import pattern \"", pattern, "\" would create a loop containing command \"", Tcl_DStringValue(&ds), "\"", (char *) NULL); + Tcl_DStringFree(&ds); return TCL_ERROR; } } @@ -1277,6 +1286,7 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite) dataPtr->realCmdPtr = cmdPtr; dataPtr->selfPtr = (Command *) importedCmd; dataPtr->selfPtr->compileProc = cmdPtr->compileProc; + Tcl_DStringFree(&ds); /* * Create an ImportRef structure describing this new import @@ -1328,14 +1338,15 @@ Tcl_ForgetImport(interp, namespacePtr, pattern) Tcl_Namespace *namespacePtr; /* Points to the namespace from which * previously imported commands should be * removed. NULL for current namespace. */ - char *pattern; /* String pattern indicating which imported + CONST char *pattern; /* String pattern indicating which imported * commands to remove. This pattern should * be qualified by the name of the * namespace from which the command(s) were * imported. */ { Namespace *nsPtr, *importNsPtr, *dummyPtr, *actualCtxPtr; - char *simplePattern, *cmdName; + CONST char *simplePattern; + char *cmdName; register Tcl_HashEntry *hPtr; Tcl_HashSearch search; Command *cmdPtr; @@ -1605,7 +1616,7 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, nsPtrPtr, altNsPtrPtr, actualCxtPtrPtr, simpleNamePtr) Tcl_Interp *interp; /* Interpreter in which to find the * namespace containing qualName. */ - register char *qualName; /* A namespace-qualified name of an + CONST char *qualName; /* A namespace-qualified name of an * command, variable, or namespace. */ Namespace *cxtNsPtr; /* The namespace in which to start the * search for qualName's namespace. If NULL @@ -1637,7 +1648,7 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, * the :: namespace if TCL_GLOBAL_ONLY was * specified, or the current namespace if * cxtNsPtr was NULL. */ - char **simpleNamePtr; /* Address where procedure stores the + CONST char **simpleNamePtr; /* Address where procedure stores the * simple name at end of the qualName, or * NULL if qualName is "::" or the flag * FIND_ONLY_NS was specified. */ @@ -1646,8 +1657,8 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, Namespace *nsPtr = cxtNsPtr; Namespace *altNsPtr; Namespace *globalNsPtr = iPtr->globalNsPtr; - register char *start, *end; - char *nsName; + CONST char *start, *end; + CONST char *nsName; Tcl_HashEntry *entryPtr; Tcl_DString buffer; int len; @@ -1870,7 +1881,7 @@ Tcl_Namespace * Tcl_FindNamespace(interp, name, contextNsPtr, flags) Tcl_Interp *interp; /* The interpreter in which to find the * namespace. */ - char *name; /* Namespace name. If it starts with "::", + CONST char *name; /* Namespace name. If it starts with "::", * will be looked up in global namespace. * Else, looked up first in contextNsPtr * (current namespace if contextNsPtr is @@ -1885,7 +1896,7 @@ Tcl_FindNamespace(interp, name, contextNsPtr, flags) * TCL_LEAVE_ERR_MSG flags. */ { Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; - char *dummy; + CONST char *dummy; /* * Find the namespace(s) that contain the specified namespace name. @@ -1929,7 +1940,7 @@ Tcl_Command Tcl_FindCommand(interp, name, contextNsPtr, flags) Tcl_Interp *interp; /* The interpreter in which to find the * command and to report errors. */ - char *name; /* Command's name. If it starts with "::", + CONST char *name; /* Command's name. If it starts with "::", * will be looked up in global namespace. * Else, looked up first in contextNsPtr * (current namespace if contextNsPtr is @@ -1952,7 +1963,7 @@ Tcl_FindCommand(interp, name, contextNsPtr, flags) ResolverScheme *resPtr; Namespace *nsPtr[2], *cxtNsPtr; - char *simpleName; + CONST char *simpleName; register Tcl_HashEntry *entryPtr; register Command *cmdPtr; register int search; @@ -2061,7 +2072,7 @@ Tcl_Var Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags) Tcl_Interp *interp; /* The interpreter in which to find the * variable. */ - char *name; /* Variable's name. If it starts with "::", + CONST char *name; /* Variable's name. If it starts with "::", * will be looked up in global namespace. * Else, looked up first in contextNsPtr * (current namespace if contextNsPtr is @@ -2083,7 +2094,7 @@ Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags) Interp *iPtr = (Interp*)interp; ResolverScheme *resPtr; Namespace *nsPtr[2], *cxtNsPtr; - char *simpleName; + CONST char *simpleName; Tcl_HashEntry *entryPtr; Var *varPtr; register int search; @@ -2275,6 +2286,17 @@ TclResetShadowedCmdRefs(interp, newCmdPtr) hPtr = Tcl_FindHashEntry(&shadowNsPtr->cmdTable, cmdName); if (hPtr != NULL) { nsPtr->cmdRefEpoch++; + + /* + * If the shadowed command was compiled to bytecodes, we + * invalidate all the bytecodes in nsPtr, to force a new + * compilation. We use the resolverEpoch to signal the need + * for a fresh compilation of every bytecode. + */ + + if ((((Command *) Tcl_GetHashValue(hPtr))->compileProc) != NULL) { + nsPtr->resolverEpoch++; + } } } @@ -2342,12 +2364,29 @@ GetNamespaceFromObj(interp, objPtr, nsPtrPtr) * of a namespace. */ Tcl_Namespace **nsPtrPtr; /* Result namespace pointer goes here. */ { + Interp *iPtr = (Interp *) interp; register ResolvedNsName *resNamePtr; register Namespace *nsPtr; - Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); - int result; + Namespace *currNsPtr; + CallFrame *savedFramePtr; + int result = TCL_OK; + char *name; /* + * If the namespace name is fully qualified, do as if the lookup were + * done from the global namespace; this helps avoid repeated lookups + * of fully qualified names. + */ + + savedFramePtr = iPtr->varFramePtr; + name = Tcl_GetString(objPtr); + if ((*name++ == ':') && (*name == ':')) { + iPtr->varFramePtr = NULL; + } + + currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + + /* * Get the internal representation, converting to a namespace type if * needed. The internal representation is a ResolvedNsName that points * to the actual namespace. @@ -2356,7 +2395,7 @@ GetNamespaceFromObj(interp, objPtr, nsPtrPtr) if (objPtr->typePtr != &tclNsNameType) { result = tclNsNameType.setFromAnyProc(interp, objPtr); if (result != TCL_OK) { - return TCL_ERROR; + goto done; } } resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr; @@ -2382,7 +2421,7 @@ GetNamespaceFromObj(interp, objPtr, nsPtrPtr) if (nsPtr == NULL) { /* try again */ result = tclNsNameType.setFromAnyProc(interp, objPtr); if (result != TCL_OK) { - return TCL_ERROR; + goto done; } resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr; if (resNamePtr != NULL) { @@ -2393,7 +2432,10 @@ GetNamespaceFromObj(interp, objPtr, nsPtrPtr) } } *nsPtrPtr = (Tcl_Namespace *) nsPtr; - return TCL_OK; + + done: + iPtr->varFramePtr = savedFramePtr; + return result; } /* @@ -2409,6 +2451,7 @@ GetNamespaceFromObj(interp, objPtr, nsPtrPtr) * namespace current * namespace delete ?name name...? * namespace eval name arg ?arg...? + * namespace exists name * namespace export ?-clear? ?pattern pattern...? * namespace forget ?pattern pattern...? * namespace import ?-force? ?pattern pattern...? @@ -2442,16 +2485,17 @@ Tcl_NamespaceObjCmd(clientData, interp, objc, objv) register int objc; /* Number of arguments. */ register Tcl_Obj *CONST objv[]; /* Argument objects. */ { - static char *subCmds[] = { - "children", "code", "current", "delete", - "eval", "export", "forget", "import", - "inscope", "origin", "parent", "qualifiers", - "tail", "which", (char *) NULL}; + static CONST char *subCmds[] = { + "children", "code", "current", "delete", + "eval", "exists", "export", "forget", "import", + "inscope", "origin", "parent", "qualifiers", + "tail", "which", (char *) NULL + }; enum NSSubCmdIdx { - NSChildrenIdx, NSCodeIdx, NSCurrentIdx, NSDeleteIdx, - NSEvalIdx, NSExportIdx, NSForgetIdx, NSImportIdx, - NSInscopeIdx, NSOriginIdx, NSParentIdx, NSQualifiersIdx, - NSTailIdx, NSWhichIdx + NSChildrenIdx, NSCodeIdx, NSCurrentIdx, NSDeleteIdx, + NSEvalIdx, NSExistsIdx, NSExportIdx, NSForgetIdx, NSImportIdx, + NSInscopeIdx, NSOriginIdx, NSParentIdx, NSQualifiersIdx, + NSTailIdx, NSWhichIdx }; int index, result; @@ -2486,6 +2530,9 @@ Tcl_NamespaceObjCmd(clientData, interp, objc, objv) case NSEvalIdx: result = NamespaceEvalCmd(clientData, interp, objc, objv); break; + case NSExistsIdx: + result = NamespaceExistsCmd(clientData, interp, objc, objv); + break; case NSExportIdx: result = NamespaceExportCmd(clientData, interp, objc, objv); break; @@ -2631,10 +2678,10 @@ NamespaceChildrenCmd(dummy, interp, objc, objv) * Here "arg" can be a list. "namespace code arg" produces a result * equivalent to that produced by the command * - * list namespace inscope [namespace current] $arg + * list ::namespace inscope [namespace current] $arg * * However, if "arg" is itself a scoped value starting with - * "namespace inscope", then the result is just "arg". + * "::namespace inscope", then the result is just "arg". * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. @@ -2668,6 +2715,10 @@ NamespaceCodeCmd(dummy, interp, objc, objv) */ arg = Tcl_GetStringFromObj(objv[2], &length); + while (*arg == ':') { + arg++; + length--; + } if ((*arg == 'n') && (length > 17) && (strncmp(arg, "namespace", 9) == 0)) { for (p = (arg + 9); (*p == ' '); p++) { @@ -2690,7 +2741,7 @@ NamespaceCodeCmd(dummy, interp, objc, objv) listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewStringObj("namespace", -1)); + Tcl_NewStringObj("::namespace", -1)); Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj("inscope", -1)); @@ -2877,7 +2928,7 @@ NamespaceEvalCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Namespace *namespacePtr; - Tcl_CallFrame frame; + CallFrame frame; Tcl_Obj *objPtr; char *name; int length, result; @@ -2915,11 +2966,13 @@ NamespaceEvalCmd(dummy, interp, objc, objv) * the command(s). */ - result = Tcl_PushCallFrame(interp, &frame, namespacePtr, - /*isProcCallFrame*/ 0); + result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) &frame, + namespacePtr, /*isProcCallFrame*/ 0); if (result != TCL_OK) { return TCL_ERROR; } + frame.objc = objc; + frame.objv = objv; /* ref counts do not need to be incremented here */ if (objc == 4) { result = Tcl_EvalObjEx(interp, objv[3], 0); @@ -2951,6 +3004,53 @@ NamespaceEvalCmd(dummy, interp, objc, objv) /* *---------------------------------------------------------------------- * + * NamespaceExistsCmd -- + * + * Invoked to implement the "namespace exists" command that returns + * true if the given namespace currently exists, and false otherwise. + * Handles the following syntax: + * + * namespace exists name + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. + * + * Side effects: + * Returns a result in the interpreter's result object. If anything + * goes wrong, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +NamespaceExistsCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Namespace *namespacePtr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "name"); + return TCL_ERROR; + } + + /* + * Check whether the given namespace exists + */ + + if (GetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) { + return TCL_ERROR; + } + + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), (namespacePtr != NULL)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * NamespaceExportCmd -- * * Invoked to implement the "namespace export" command that specifies @@ -3768,7 +3868,8 @@ SetNsNameFromAny(interp, objPtr) register Tcl_Obj *objPtr; /* The object to convert. */ { register Tcl_ObjType *oldTypePtr = objPtr->typePtr; - char *name, *dummy; + char *name; + CONST char *dummy; Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; register ResolvedNsName *resNamePtr; @@ -3880,4 +3981,3 @@ UpdateStringOfNsName(objPtr) } objPtr->length = length; } - diff --git a/tcl/generic/tclNotify.c b/tcl/generic/tclNotify.c index 2c386ab9e7c..9e68a6b5879 100644 --- a/tcl/generic/tclNotify.c +++ b/tcl/generic/tclNotify.c @@ -116,7 +116,7 @@ TclInitNotifier() Tcl_MutexLock(&listLock); tsdPtr->threadId = Tcl_GetCurrentThread(); - tsdPtr->clientData = Tcl_InitNotifier(); + tsdPtr->clientData = tclStubs.tcl_InitNotifier(); tsdPtr->nextPtr = firstNotifierPtr; firstNotifierPtr = tsdPtr; @@ -146,10 +146,21 @@ TclFinalizeNotifier() { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); ThreadSpecificData **prevPtrPtr; + Tcl_Event *evPtr, *hold; + + Tcl_MutexLock(&(tsdPtr->queueMutex)); + for (evPtr = tsdPtr->firstEventPtr; evPtr != (Tcl_Event *) NULL; ) { + hold = evPtr; + evPtr = evPtr->nextPtr; + ckfree((char *) hold); + } + tsdPtr->firstEventPtr = NULL; + tsdPtr->lastEventPtr = NULL; + Tcl_MutexUnlock(&(tsdPtr->queueMutex)); Tcl_MutexLock(&listLock); - Tcl_FinalizeNotifier(tsdPtr->clientData); + tclStubs.tcl_FinalizeNotifier(tsdPtr->clientData); Tcl_MutexFinalize(&(tsdPtr->queueMutex)); for (prevPtrPtr = &firstNotifierPtr; *prevPtrPtr != NULL; prevPtrPtr = &((*prevPtrPtr)->nextPtr)) { @@ -192,6 +203,10 @@ Tcl_SetNotifier(notifierProcPtr) #endif tclStubs.tcl_SetTimer = notifierProcPtr->setTimerProc; tclStubs.tcl_WaitForEvent = notifierProcPtr->waitForEventProc; + tclStubs.tcl_InitNotifier = notifierProcPtr->initNotifierProc; + tclStubs.tcl_FinalizeNotifier = notifierProcPtr->finalizeNotifierProc; + tclStubs.tcl_AlertNotifier = notifierProcPtr->alertNotifierProc; + tclStubs.tcl_ServiceModeHook = notifierProcPtr->serviceModeHookProc; } /* @@ -706,7 +721,7 @@ Tcl_SetServiceMode(mode) oldMode = tsdPtr->serviceMode; tsdPtr->serviceMode = mode; - Tcl_ServiceModeHook(mode); + tclStubs.tcl_ServiceModeHook(mode); return oldMode; } @@ -1072,10 +1087,9 @@ Tcl_ThreadAlert(threadId) Tcl_MutexLock(&listLock); for (tsdPtr = firstNotifierPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) { if (tsdPtr->threadId == threadId) { - Tcl_AlertNotifier(tsdPtr->clientData); + tclStubs.tcl_AlertNotifier(tsdPtr->clientData); break; } } Tcl_MutexUnlock(&listLock); } - diff --git a/tcl/generic/tclObj.c b/tcl/generic/tclObj.c index 581c6b0aaa5..6af1b59d002 100644 --- a/tcl/generic/tclObj.c +++ b/tcl/generic/tclObj.c @@ -6,6 +6,7 @@ * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 1999 by Scriptics Corporation. + * Copyright (c) 2001 by ActiveState Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -14,6 +15,7 @@ */ #include "tclInt.h" +#include "tclCompile.h" #include "tclPort.h" /* @@ -45,18 +47,8 @@ Tcl_Mutex tclObjMutex; * is shared by all new objects allocated by Tcl_NewObj. */ -static char emptyString; -char *tclEmptyStringRep = &emptyString; - -/* - * The number of Tcl objects ever allocated (by Tcl_NewObj) and freed - * (by TclFreeObj). - */ - -#ifdef TCL_COMPILE_STATS -long tclObjsAlloced = 0; -long tclObjsFreed = 0; -#endif /* TCL_COMPILE_STATS */ +char tclEmptyString = '\0'; +char *tclEmptyStringRep = &tclEmptyString; /* * Prototypes for procedures defined later in this file: @@ -71,6 +63,37 @@ static int SetIntFromAny _ANSI_ARGS_((Tcl_Interp *interp, static void UpdateStringOfBoolean _ANSI_ARGS_((Tcl_Obj *objPtr)); static void UpdateStringOfDouble _ANSI_ARGS_((Tcl_Obj *objPtr)); static void UpdateStringOfInt _ANSI_ARGS_((Tcl_Obj *objPtr)); +#ifndef TCL_WIDE_INT_IS_LONG +static int SetWideIntFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); +static void UpdateStringOfWideInt _ANSI_ARGS_((Tcl_Obj *objPtr)); +#endif + +/* + * Prototypes for the array hash key methods. + */ + +static Tcl_HashEntry * AllocObjEntry _ANSI_ARGS_(( + Tcl_HashTable *tablePtr, VOID *keyPtr)); +static int CompareObjKeys _ANSI_ARGS_(( + VOID *keyPtr, Tcl_HashEntry *hPtr)); +static void FreeObjEntry _ANSI_ARGS_(( + Tcl_HashEntry *hPtr)); +static unsigned int HashObjKey _ANSI_ARGS_(( + Tcl_HashTable *tablePtr, + VOID *keyPtr)); + +/* + * Prototypes for the CommandName object type. + */ + +static void DupCmdNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr, + Tcl_Obj *copyPtr)); +static void FreeCmdNameInternalRep _ANSI_ARGS_(( + Tcl_Obj *objPtr)); +static int SetCmdNameFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); + /* * The structures below defines the Tcl object types defined in this file by @@ -102,6 +125,81 @@ Tcl_ObjType tclIntType = { UpdateStringOfInt, /* updateStringProc */ SetIntFromAny /* setFromAnyProc */ }; + +#ifndef TCL_WIDE_INT_IS_LONG +Tcl_ObjType tclWideIntType = { + "wideInt", /* name */ + (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ + (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ + UpdateStringOfWideInt, /* updateStringProc */ + SetWideIntFromAny /* setFromAnyProc */ +}; +#endif + +/* + * The structure below defines the Tcl obj hash key type. + */ +Tcl_HashKeyType tclObjHashKeyType = { + TCL_HASH_KEY_TYPE_VERSION, /* version */ + 0, /* flags */ + HashObjKey, /* hashKeyProc */ + CompareObjKeys, /* compareKeysProc */ + AllocObjEntry, /* allocEntryProc */ + FreeObjEntry /* freeEntryProc */ +}; + +/* + * The structure below defines the command name Tcl object type by means of + * procedures that can be invoked by generic object code. Objects of this + * type cache the Command pointer that results from looking up command names + * in the command hashtable. Such objects appear as the zeroth ("command + * name") argument in a Tcl command. + */ + +static Tcl_ObjType tclCmdNameType = { + "cmdName", /* name */ + FreeCmdNameInternalRep, /* freeIntRepProc */ + DupCmdNameInternalRep, /* dupIntRepProc */ + (Tcl_UpdateStringProc *) NULL, /* updateStringProc */ + SetCmdNameFromAny /* setFromAnyProc */ +}; + + +/* + * Structure containing a cached pointer to a command that is the result + * of resolving the command's name in some namespace. It is the internal + * representation for a cmdName object. It contains the pointer along + * with some information that is used to check the pointer's validity. + */ + +typedef struct ResolvedCmdName { + Command *cmdPtr; /* A cached Command pointer. */ + Namespace *refNsPtr; /* Points to the namespace containing the + * reference (not the namespace that + * contains the referenced command). */ + 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 at the same address). */ + int refNsCmdEpoch; /* Value of the referencing namespace's + * cmdRefEpoch when the pointer was cached. + * Before using the cached pointer, we check + * if the namespace's epoch was incremented; + * if so, this cached pointer is invalid. */ + int cmdEpoch; /* Value of the command's cmdEpoch when this + * pointer was cached. Before using the + * cached pointer, we check if the cmd's + * epoch was 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 that has a pointer to this + * ResolvedCmdName structure as its internal + * rep. This structure can be freed when + * refCount becomes zero. */ +} ResolvedCmdName; + /* *------------------------------------------------------------------------- @@ -133,16 +231,30 @@ TclInitObjSubsystem() Tcl_RegisterObjType(&tclBooleanType); Tcl_RegisterObjType(&tclByteArrayType); Tcl_RegisterObjType(&tclDoubleType); + Tcl_RegisterObjType(&tclEndOffsetType); Tcl_RegisterObjType(&tclIntType); +#ifndef TCL_WIDE_INT_IS_LONG + Tcl_RegisterObjType(&tclWideIntType); +#endif Tcl_RegisterObjType(&tclStringType); Tcl_RegisterObjType(&tclListType); Tcl_RegisterObjType(&tclByteCodeType); Tcl_RegisterObjType(&tclProcBodyType); + Tcl_RegisterObjType(&tclArraySearchType); + Tcl_RegisterObjType(&tclIndexType); + Tcl_RegisterObjType(&tclNsNameType); + Tcl_RegisterObjType(&tclCmdNameType); #ifdef TCL_COMPILE_STATS Tcl_MutexLock(&tclObjMutex); tclObjsAlloced = 0; tclObjsFreed = 0; + { + int i; + for (i = 0; i < TCL_MAX_SHARED_OBJ_STATS; i++) { + tclObjsShared[i] = 0; + } + } Tcl_MutexUnlock(&tclObjMutex); #endif } @@ -306,7 +418,7 @@ Tcl_AppendAllObjTypes(interp, objPtr) Tcl_ObjType * Tcl_GetObjType(typeName) - char *typeName; /* Name of Tcl object type to look up. */ + CONST char *typeName; /* Name of Tcl object type to look up. */ { register Tcl_HashEntry *hPtr; Tcl_ObjType *typePtr; @@ -404,25 +516,11 @@ Tcl_NewObj() register Tcl_Obj *objPtr; /* - * Allocate the object using the list of free Tcl_Obj structs - * we maintain. + * Use the macro defined in tclInt.h - it will use the + * correct allocator. */ - Tcl_MutexLock(&tclObjMutex); - if (tclFreeObjList == NULL) { - TclAllocateFreeObjects(); - } - objPtr = tclFreeObjList; - tclFreeObjList = (Tcl_Obj *) tclFreeObjList->internalRep.otherValuePtr; - - objPtr->refCount = 0; - objPtr->bytes = tclEmptyStringRep; - objPtr->length = 0; - objPtr->typePtr = NULL; -#ifdef TCL_COMPILE_STATS - tclObjsAlloced++; -#endif /* TCL_COMPILE_STATS */ - Tcl_MutexUnlock(&tclObjMutex); + TclNewObj(objPtr); return objPtr; } #endif /* TCL_MEM_DEBUG */ @@ -437,7 +535,7 @@ Tcl_NewObj() * empty string. It is the same as the Tcl_NewObj procedure above * except that it calls Tcl_DbCkalloc directly with the file name and * line number from its caller. This simplifies debugging since then - * the checkmem command will report the correct file name and line + * 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 procedure just returns the @@ -458,7 +556,7 @@ Tcl_NewObj() Tcl_Obj * Tcl_DbNewObj(file, line) - register char *file; /* The name of the source file calling this + register CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ register int line; /* Line number in the source file; used * for debugging. */ @@ -466,29 +564,18 @@ Tcl_DbNewObj(file, line) register Tcl_Obj *objPtr; /* - * If debugging Tcl's memory usage, allocate the object using ckalloc. - * Otherwise, allocate it using the list of free Tcl_Obj structs we - * maintain. + * Use the macro defined in tclInt.h - it will use the + * correct allocator. */ - objPtr = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), file, line); - objPtr->refCount = 0; - objPtr->bytes = tclEmptyStringRep; - objPtr->length = 0; - objPtr->typePtr = NULL; -#ifdef TCL_COMPILE_STATS - Tcl_MutexLock(&tclObjMutex); - tclObjsAlloced++; - Tcl_MutexUnlock(&tclObjMutex); -#endif /* TCL_COMPILE_STATS */ + TclDbNewObj(objPtr, file, line); return objPtr; } - #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_DbNewObj(file, line) - char *file; /* The name of the source file calling this + 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. */ @@ -523,23 +610,27 @@ Tcl_DbNewObj(file, line) void TclAllocateFreeObjects() { - Tcl_Obj tmp[2]; - size_t objSizePlusPadding = /* NB: this assumes byte addressing. */ - ((int)(&(tmp[1])) - (int)(&(tmp[0]))); - size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * objSizePlusPadding); + size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * sizeof(Tcl_Obj)); char *basePtr; register Tcl_Obj *prevPtr, *objPtr; register int i; + /* + * This has been noted by Purify to be a potential leak. The problem is + * that Tcl, when not TCL_MEM_DEBUG compiled, keeps around all allocated + * Tcl_Obj's, pointed to by tclFreeObjList, when freed instead of + * actually freeing the memory. These never do get freed properly. + */ + basePtr = (char *) ckalloc(bytesToAlloc); memset(basePtr, 0, bytesToAlloc); prevPtr = NULL; objPtr = (Tcl_Obj *) basePtr; - for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) { + for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) { objPtr->internalRep.otherValuePtr = (VOID *) prevPtr; prevPtr = objPtr; - objPtr = (Tcl_Obj *) (((char *)objPtr) + objSizePlusPadding); + objPtr++; } tclFreeObjList = prevPtr; } @@ -593,18 +684,22 @@ TclFreeObj(objPtr) * Tcl_Obj structs we maintain. */ +#if defined(TCL_MEM_DEBUG) || defined(PURIFY) Tcl_MutexLock(&tclObjMutex); -#ifdef TCL_MEM_DEBUG ckfree((char *) objPtr); -#else + Tcl_MutexUnlock(&tclObjMutex); +#elif defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) + TclThreadFreeObj(objPtr); +#else + Tcl_MutexLock(&tclObjMutex); objPtr->internalRep.otherValuePtr = (VOID *) tclFreeObjList; tclFreeObjList = objPtr; + Tcl_MutexUnlock(&tclObjMutex); #endif /* TCL_MEM_DEBUG */ #ifdef TCL_COMPILE_STATS tclObjsFreed++; #endif /* TCL_COMPILE_STATS */ - Tcl_MutexUnlock(&tclObjMutex); } /* @@ -648,15 +743,7 @@ Tcl_DuplicateObj(objPtr) if (objPtr->bytes == NULL) { dupPtr->bytes = NULL; } else if (objPtr->bytes != tclEmptyStringRep) { - int len = objPtr->length; - - dupPtr->bytes = (char *) ckalloc((unsigned) len+1); - if (len > 0) { - memcpy((VOID *) dupPtr->bytes, (VOID *) objPtr->bytes, - (unsigned) len); - } - dupPtr->bytes[len] = '\0'; - dupPtr->length = len; + TclInitStringRep(dupPtr, objPtr->bytes, objPtr->length); } if (typePtr != NULL) { @@ -733,24 +820,20 @@ Tcl_GetString(objPtr) char * Tcl_GetStringFromObj(objPtr, lengthPtr) - register Tcl_Obj *objPtr; /* Object whose string rep byte pointer - * should be returned. */ - register int *lengthPtr; /* If non-NULL, the location where the - * string rep's byte array length should be - * stored. If NULL, no length is stored. */ + register Tcl_Obj *objPtr; /* Object whose string rep byte pointer should + * be returned. */ + register int *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) { - if (lengthPtr != NULL) { - *lengthPtr = objPtr->length; + if (objPtr->bytes == NULL) { + if (objPtr->typePtr->updateStringProc == NULL) { + panic("UpdateStringProc should not be invoked for type %s", + objPtr->typePtr->name); } - return objPtr->bytes; + (*objPtr->typePtr->updateStringProc)(objPtr); } - if (objPtr->typePtr->updateStringProc == NULL) { - panic("UpdateStringProc should not be invoked for type %s", - objPtr->typePtr->name); - } - (*objPtr->typePtr->updateStringProc)(objPtr); if (lengthPtr != NULL) { *lengthPtr = objPtr->length; } @@ -847,9 +930,9 @@ Tcl_NewBooleanObj(boolValue) * TCL_MEM_DEBUG is defined. It creates new boolean objects. It is the * same as the Tcl_NewBooleanObj procedure above except that it calls * Tcl_DbCkalloc directly with the file name and line number from its - * caller. This simplifies debugging since then the checkmem command - * will report the correct file name and line number when reporting - * objects that haven't been freed. + * 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. * * When TCL_MEM_DEBUG is not defined, this procedure just returns the * result of calling Tcl_NewBooleanObj. @@ -869,7 +952,7 @@ Tcl_NewBooleanObj(boolValue) Tcl_Obj * Tcl_DbNewBooleanObj(boolValue, file, line) register int boolValue; /* Boolean used to initialize new object. */ - char *file; /* The name of the source file calling this + 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. */ @@ -889,7 +972,7 @@ Tcl_DbNewBooleanObj(boolValue, file, line) Tcl_Obj * Tcl_DbNewBooleanObj(boolValue, file, line) register int boolValue; /* Boolean used to initialize new object. */ - char *file; /* The name of the source file calling this + 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. */ @@ -965,7 +1048,12 @@ Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) { register int result; - result = SetBooleanFromAny(interp, objPtr); + if (objPtr->typePtr == &tclBooleanType) { + result = TCL_OK; + } else { + result = SetBooleanFromAny(interp, objPtr); + } + if (result == TCL_OK) { *boolPtr = (int) objPtr->internalRep.longValue; } @@ -1003,88 +1091,142 @@ SetBooleanFromAny(interp, objPtr) char lowerCase[10]; int newBool, length; register int i; - double dbl; /* * Get the string representation. Make it up-to-date if necessary. */ - + string = Tcl_GetStringFromObj(objPtr, &length); /* - * Copy the string converting its characters to lower case. - */ - - for (i = 0; (i < 9) && (i < length); i++) { - c = string[i]; - /* - * Weed out international characters so we can safely operate - * on single bytes. - */ - - if (c & 0x80) { - goto badBoolean; - } - if (Tcl_UniCharIsUpper(UCHAR(c))) { - c = (char) Tcl_UniCharToLower(UCHAR(c)); - } - lowerCase[i] = c; - } - lowerCase[i] = 0; - - /* - * Parse the string as a boolean. We use an implementation here that - * doesn't report errors in interp if interp is NULL. + * Use the obvious shortcuts for numerical values; if objPtr is not + * of numerical type, parse its string rep. */ - - c = lowerCase[0]; - if ((c == '0') && (lowerCase[1] == '\0')) { - newBool = 0; - } else if ((c == '1') && (lowerCase[1] == '\0')) { - newBool = 1; - } else if ((c == 'y') && (strncmp(lowerCase, "yes", (size_t) length) == 0)) { - newBool = 1; - } else if ((c == 'n') && (strncmp(lowerCase, "no", (size_t) length) == 0)) { - newBool = 0; - } else if ((c == 't') && (strncmp(lowerCase, "true", (size_t) length) == 0)) { - newBool = 1; - } else if ((c == 'f') && (strncmp(lowerCase, "false", (size_t) length) == 0)) { - newBool = 0; - } else if ((c == 'o') && (length >= 2)) { - if (strncmp(lowerCase, "on", (size_t) length) == 0) { - newBool = 1; - } else if (strncmp(lowerCase, "off", (size_t) length) == 0) { - newBool = 0; - } else { - goto badBoolean; - } + + if (objPtr->typePtr == &tclIntType) { + newBool = (objPtr->internalRep.longValue != 0); + } else if (objPtr->typePtr == &tclDoubleType) { + newBool = (objPtr->internalRep.doubleValue != 0.0); +#ifndef TCL_WIDE_INT_IS_LONG + } else if (objPtr->typePtr == &tclWideIntType) { + newBool = (objPtr->internalRep.wideValue != Tcl_LongAsWide(0)); +#endif /* TCL_WIDE_INT_IS_LONG */ } else { - /* - * Still might be a string containing the characters representing an - * int or double that wasn't handled above. This would be a string - * like "27" or "1.0" that is non-zero and not "1". Such a string - * whould result in the boolean value true. We try converting to - * double. If that succeeds and the resulting double is non-zero, we - * have a "true". Note that numbers can't have embedded NULLs. + /* + * Copy the string converting its characters to lower case. */ - - dbl = strtod(string, &end); - if (end == string) { - goto badBoolean; + + for (i = 0; (i < 9) && (i < length); i++) { + c = string[i]; + /* + * Weed out international characters so we can safely operate + * on single bytes. + */ + + if (c & 0x80) { + goto badBoolean; + } + if (Tcl_UniCharIsUpper(UCHAR(c))) { + c = (char) Tcl_UniCharToLower(UCHAR(c)); + } + lowerCase[i] = c; } - + lowerCase[i] = 0; + /* - * Make sure the string has no garbage after the end of the double. + * Parse the string as a boolean. We use an implementation here that + * doesn't report errors in interp if interp is NULL. */ - while ((end < (string+length)) - && isspace(UCHAR(*end))) { /* INTL: ISO only */ - end++; - } - if (end != (string+length)) { - goto badBoolean; + c = lowerCase[0]; + if ((c == '0') && (lowerCase[1] == '\0')) { + newBool = 0; + } else if ((c == '1') && (lowerCase[1] == '\0')) { + newBool = 1; + } else if ((c == 'y') && (strncmp(lowerCase, "yes", (size_t) length) == 0)) { + newBool = 1; + } else if ((c == 'n') && (strncmp(lowerCase, "no", (size_t) length) == 0)) { + newBool = 0; + } else if ((c == 't') && (strncmp(lowerCase, "true", (size_t) length) == 0)) { + newBool = 1; + } else if ((c == 'f') && (strncmp(lowerCase, "false", (size_t) length) == 0)) { + newBool = 0; + } else if ((c == 'o') && (length >= 2)) { + if (strncmp(lowerCase, "on", (size_t) length) == 0) { + newBool = 1; + } else if (strncmp(lowerCase, "off", (size_t) length) == 0) { + newBool = 0; + } else { + goto badBoolean; + } + } else { + double dbl; + /* + * Boolean values can be extracted from ints or doubles. Note + * that we don't use strtoul or strtoull here because we don't + * care about what the value is, just whether it is equal to + * zero or not. + */ +#ifdef TCL_WIDE_INT_IS_LONG + newBool = strtol(string, &end, 0); + if (end != string) { + /* + * Make sure the string has no garbage after the end of + * the int. + */ + while ((end < (string+length)) + && isspace(UCHAR(*end))) { /* INTL: ISO only */ + end++; + } + if (end == (string+length)) { + newBool = (newBool != 0); + goto goodBoolean; + } + } +#else /* !TCL_WIDE_INT_IS_LONG */ + Tcl_WideInt wide = strtoll(string, &end, 0); + if (end != string) { + /* + * Make sure the string has no garbage after the end of + * the wide int. + */ + while ((end < (string+length)) + && isspace(UCHAR(*end))) { /* INTL: ISO only */ + end++; + } + if (end == (string+length)) { + newBool = (wide != Tcl_LongAsWide(0)); + goto goodBoolean; + } + } +#endif /* TCL_WIDE_INT_IS_LONG */ + /* + * Still might be a string containing the characters representing an + * int or double that wasn't handled above. This would be a string + * like "27" or "1.0" that is non-zero and not "1". Such a string + * would result in the boolean value true. We try converting to + * double. If that succeeds and the resulting double is non-zero, we + * have a "true". Note that numbers can't have embedded NULLs. + */ + + dbl = strtod(string, &end); + if (end == string) { + goto badBoolean; + } + + /* + * Make sure the string has no garbage after the end of the double. + */ + + while ((end < (string+length)) + && isspace(UCHAR(*end))) { /* INTL: ISO only */ + end++; + } + if (end != (string+length)) { + goto badBoolean; + } + newBool = (dbl != 0.0); } - newBool = (dbl != 0.0); } /* @@ -1093,6 +1235,7 @@ SetBooleanFromAny(interp, objPtr) * Tcl_GetStringFromObj, to use that old internalRep. */ + goodBoolean: if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { oldTypePtr->freeIntRepProc(objPtr); } @@ -1205,9 +1348,9 @@ Tcl_NewDoubleObj(dblValue) * TCL_MEM_DEBUG is defined. It creates new double objects. It is the * same as the Tcl_NewDoubleObj procedure above except that it calls * Tcl_DbCkalloc directly with the file name and line number from its - * caller. This simplifies debugging since then the checkmem command - * will report the correct file name and line number when reporting - * objects that haven't been freed. + * 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. * * When TCL_MEM_DEBUG is not defined, this procedure just returns the * result of calling Tcl_NewDoubleObj. @@ -1227,7 +1370,7 @@ Tcl_NewDoubleObj(dblValue) Tcl_Obj * Tcl_DbNewDoubleObj(dblValue, file, line) register double dblValue; /* Double used to initialize the object. */ - char *file; /* The name of the source file calling this + 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. */ @@ -1247,7 +1390,7 @@ Tcl_DbNewDoubleObj(dblValue, file, line) Tcl_Obj * Tcl_DbNewDoubleObj(dblValue, file, line) register double dblValue; /* Double used to initialize the object. */ - char *file; /* The name of the source file calling this + 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. */ @@ -1836,8 +1979,8 @@ Tcl_NewLongObj(longValue) * When the core is compiled with TCL_MEM_DEBUG defined, * Tcl_DbNewLongObj calls Tcl_DbCkalloc directly with the file name and * line number from its caller. This simplifies debugging since then - * the checkmem command will report the caller's file name and line - * number when reporting objects that haven't been freed. + * the [memory active] command will report the caller's file name and + * line number when reporting objects that haven't been freed. * * Otherwise, when the core is compiled without TCL_MEM_DEBUG defined, * this procedure just returns the result of calling Tcl_NewLongObj. @@ -1859,7 +2002,7 @@ Tcl_Obj * Tcl_DbNewLongObj(longValue, file, line) register long longValue; /* Long integer used to initialize the * new object. */ - char *file; /* The name of the source file calling this + 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. */ @@ -1880,7 +2023,7 @@ Tcl_Obj * Tcl_DbNewLongObj(longValue, file, line) register long longValue; /* Long integer used to initialize the * new object. */ - char *file; /* The name of the source file calling this + 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. */ @@ -1971,6 +2114,380 @@ Tcl_GetLongFromObj(interp, objPtr, longPtr) /* *---------------------------------------------------------------------- * + * SetWideIntFromAny -- + * + * Attempt to generate an integer internal form for the Tcl object + * "objPtr". + * + * Results: + * The return value is a standard object Tcl result. 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, an int is stored as "objPtr"s internal + * representation. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_WIDE_INT_IS_LONG +static int +SetWideIntFromAny(interp, objPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr; /* The object to convert. */ +{ + Tcl_ObjType *oldTypePtr = objPtr->typePtr; + char *string, *end; + int length; + register char *p; + Tcl_WideInt newWide; + + /* + * Get the string representation. Make it up-to-date if necessary. + */ + + string = Tcl_GetStringFromObj(objPtr, &length); + + /* + * Now parse "objPtr"s string as an int. We use an implementation here + * that doesn't report errors in interp if interp is NULL. Note: use + * strtoull instead of strtoll for integer conversions to allow full-size + * unsigned numbers, but don't depend on strtoull to handle sign + * characters; it won't in some implementations. + */ + + errno = 0; + for (p = string; isspace(UCHAR(*p)); p++) { /* INTL: ISO space. */ + /* Empty loop body. */ + } + if (*p == '-') { + p++; + newWide = -((Tcl_WideInt)strtoull(p, &end, 0)); + } else if (*p == '+') { + p++; + newWide = strtoull(p, &end, 0); + } else { + newWide = strtoull(p, &end, 0); + } + if (end == p) { + badInteger: + if (interp != NULL) { + /* + * Must copy string before resetting the result in case a caller + * is trying to convert the interpreter's result to an int. + */ + + char buf[100]; + sprintf(buf, "expected integer but got \"%.50s\"", string); + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); + TclCheckBadOctal(interp, string); + } + return TCL_ERROR; + } + if (errno == ERANGE) { + if (interp != NULL) { + char *s = "integer value too large to represent"; + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL); + } + return TCL_ERROR; + } + + /* + * Make sure that the string has no garbage after the end of the int. + */ + + while ((end < (string+length)) + && isspace(UCHAR(*end))) { /* INTL: ISO space. */ + end++; + } + if (end != (string+length)) { + goto badInteger; + } + + /* + * The conversion to int succeeded. Free the old internalRep before + * setting the new one. We do this as late as possible to allow the + * conversion code, in particular Tcl_GetStringFromObj, to use that old + * internalRep. + */ + + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); + } + + objPtr->internalRep.wideValue = newWide; + objPtr->typePtr = &tclWideIntType; + return TCL_OK; +} +#endif + +/* + *---------------------------------------------------------------------- + * + * UpdateStringOfWideInt -- + * + * Update the string representation for a wide integer object. + * Note: This procedure does not free an existing old string rep + * so storage will be lost if this has not already been done. + * + * Results: + * None. + * + * Side effects: + * The object's string is set to a valid string that results from + * the wideInt-to-string conversion. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_WIDE_INT_IS_LONG +static void +UpdateStringOfWideInt(objPtr) + register Tcl_Obj *objPtr; /* Int object whose string rep to update. */ +{ + char buffer[TCL_INTEGER_SPACE+2]; + register unsigned len; + register Tcl_WideInt wideVal = objPtr->internalRep.wideValue; + + sprintf(buffer, "%" TCL_LL_MODIFIER "d", wideVal); + len = strlen(buffer); + objPtr->bytes = ckalloc((unsigned) len + 1); + memcpy(objPtr->bytes, buffer, len + 1); + objPtr->length = len; +} +#endif /* TCL_WIDE_INT_IS_LONG */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_NewWideIntObj -- + * + * If a client is compiled with TCL_MEM_DEBUG defined, calls to + * Tcl_NewWideIntObj to create a new 64-bit integer object end up calling + * the debugging procedure Tcl_DbNewWideIntObj instead. + * + * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, + * calls to Tcl_NewWideIntObj result in a call to one of the two + * Tcl_NewWideIntObj implementations below. We provide two implementations + * so that the Tcl core can be compiled to do memory debugging of the + * core even if a client does not request it for itself. + * + * Results: + * The newly created object is returned. This object will have an + * invalid string representation. The returned object has ref count 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_MEM_DEBUG +#undef Tcl_NewWideIntObj + +Tcl_Obj * +Tcl_NewWideIntObj(wideValue) + register Tcl_WideInt wideValue; /* Wide integer used to initialize + * the new object. */ +{ + return Tcl_DbNewWideIntObj(wideValue, "unknown", 0); +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_NewWideIntObj(wideValue) + register Tcl_WideInt wideValue; /* Wide integer used to initialize + * the new object. */ +{ +#ifdef TCL_WIDE_INT_IS_LONG + return Tcl_NewLongObj(wideValue); +#else + register Tcl_Obj *objPtr; + + TclNewObj(objPtr); + objPtr->bytes = NULL; + + objPtr->internalRep.wideValue = wideValue; + objPtr->typePtr = &tclWideIntType; + return objPtr; +#endif /* TCL_WIDE_INT_IS_LONG */ +} +#endif /* if TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_DbNewWideIntObj -- + * + * If a client is compiled with TCL_MEM_DEBUG defined, calls to + * Tcl_NewWideIntObj to create new wide integer end up calling + * the debugging procedure Tcl_DbNewWideIntObj instead. We + * provide two implementations of Tcl_DbNewWideIntObj so that + * whether the Tcl core is compiled to do memory debugging of the + * core is independent of whether a client requests debugging for + * itself. + * + * When the core is compiled with TCL_MEM_DEBUG defined, + * Tcl_DbNewWideIntObj calls Tcl_DbCkalloc directly with the file + * name and line number from its caller. This simplifies + * debugging since then the checkmem command will report the + * caller's file name and line number when reporting objects that + * haven't been freed. + * + * Otherwise, when the core is compiled without TCL_MEM_DEBUG defined, + * this procedure just returns the result of calling Tcl_NewWideIntObj. + * + * Results: + * The newly created wide integer object is returned. This object + * will have an invalid string representation. The returned object has + * ref count 0. + * + * Side effects: + * Allocates memory. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_MEM_DEBUG + +Tcl_Obj * +Tcl_DbNewWideIntObj(wideValue, file, line) + register Tcl_WideInt wideValue; /* Wide integer used to initialize + * the new object. */ + 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_WIDE_INT_IS_LONG + return Tcl_DbNewLongObj(wideValue, file, line); +#else + register Tcl_Obj *objPtr; + + TclDbNewObj(objPtr, file, line); + objPtr->bytes = NULL; + + objPtr->internalRep.wideValue = wideValue; + objPtr->typePtr = &tclWideIntType; + return objPtr; +#endif +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_DbNewWideIntObj(wideValue, file, line) + register Tcl_WideInt wideValue; /* Long integer used to initialize + * the new object. */ + CONST char *file; /* The name of the source file + * calling this procedure; used for + * debugging. */ + int line; /* Line number in the source file; + * used for debugging. */ +{ + return Tcl_NewWideIntObj(wideValue); +} +#endif /* TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetWideIntObj -- + * + * Modify an object to be a wide integer object and to have the + * specified wide integer value. + * + * Results: + * None. + * + * Side effects: + * The object's old string rep, if any, is freed. Also, any old + * internal rep is freed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetWideIntObj(objPtr, wideValue) + register Tcl_Obj *objPtr; /* Object w. internal rep to init. */ + register Tcl_WideInt wideValue; /* Wide integer used to initialize + * the object's value. */ +{ +#ifdef TCL_WIDE_INT_IS_LONG + Tcl_SetLongObj(objPtr, wideValue); +#else + register Tcl_ObjType *oldTypePtr = objPtr->typePtr; + + if (Tcl_IsShared(objPtr)) { + panic("Tcl_SetWideIntObj called with shared object"); + } + + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); + } + + objPtr->internalRep.wideValue = wideValue; + objPtr->typePtr = &tclWideIntType; + Tcl_InvalidateStringRep(objPtr); +#endif +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetWideIntFromObj -- + * + * Attempt to return a wide integer from the Tcl object "objPtr". If + * the object is not already a wide int object, an attempt will be made + * to convert it to one. + * + * 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 object, the conversion will free + * any old internal representation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetWideIntFromObj(interp, objPtr, wideIntPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr; /* Object from which to get a wide int. */ + register Tcl_WideInt *wideIntPtr; /* Place to store resulting long. */ +{ +#ifdef TCL_WIDE_INT_IS_LONG + /* + * Next line is type-safe because we only do this when long = Tcl_WideInt + */ + return Tcl_GetLongFromObj(interp, objPtr, wideIntPtr); +#else + register int result; + + if (objPtr->typePtr == &tclWideIntType) { + *wideIntPtr = objPtr->internalRep.wideValue; + return TCL_OK; + } + result = SetWideIntFromAny(interp, objPtr); + if (result == TCL_OK) { + *wideIntPtr = objPtr->internalRep.wideValue; + } + return result; +#endif +} + +/* + *---------------------------------------------------------------------- + * * Tcl_DbIncrRefCount -- * * This procedure is normally called when debugging: i.e., when @@ -1993,7 +2510,7 @@ void Tcl_DbIncrRefCount(objPtr, file, line) register Tcl_Obj *objPtr; /* The object we are registering a * reference to. */ - char *file; /* The name of the source file calling this + 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. */ @@ -2033,7 +2550,7 @@ void Tcl_DbDecrRefCount(objPtr, file, line) register Tcl_Obj *objPtr; /* The object we are releasing a reference * to. */ - char *file; /* The name of the source file calling this + 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. */ @@ -2074,7 +2591,7 @@ Tcl_DbDecrRefCount(objPtr, file, line) int Tcl_DbIsShared(objPtr, file, line) register Tcl_Obj *objPtr; /* The object to test for being shared. */ - char *file; /* The name of the source file calling this + 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. */ @@ -2086,5 +2603,578 @@ Tcl_DbIsShared(objPtr, file, line) panic("Trying to check whether previously disposed object is shared."); } #endif +#ifdef TCL_COMPILE_STATS + Tcl_MutexLock(&tclObjMutex); + if ((objPtr)->refCount <= 1) { + tclObjsShared[1]++; + } else if ((objPtr)->refCount < TCL_MAX_SHARED_OBJ_STATS) { + tclObjsShared[(objPtr)->refCount]++; + } else { + tclObjsShared[0]++; + } + Tcl_MutexUnlock(&tclObjMutex); +#endif return ((objPtr)->refCount > 1); } + +/* + *---------------------------------------------------------------------- + * + * Tcl_InitObjHashTable -- + * + * Given storage for a hash table, set up the fields to prepare + * the hash table for use, the keys are Tcl_Obj *. + * + * Results: + * None. + * + * Side effects: + * TablePtr is now ready to be passed to Tcl_FindHashEntry and + * Tcl_CreateHashEntry. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_InitObjHashTable(tablePtr) + register Tcl_HashTable *tablePtr; /* Pointer to table record, which + * is supplied by the caller. */ +{ + Tcl_InitCustomHashTable(tablePtr, TCL_CUSTOM_PTR_KEYS, + &tclObjHashKeyType); +} + +/* + *---------------------------------------------------------------------- + * + * AllocObjEntry -- + * + * Allocate space for a Tcl_HashEntry containing the Tcl_Obj * key. + * + * Results: + * The return value is a pointer to the created entry. + * + * Side effects: + * Increments the reference count on the object. + * + *---------------------------------------------------------------------- + */ + +static Tcl_HashEntry * +AllocObjEntry(tablePtr, keyPtr) + Tcl_HashTable *tablePtr; /* Hash table. */ + VOID *keyPtr; /* Key to store in the hash table entry. */ +{ + Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr; + Tcl_HashEntry *hPtr; + + hPtr = (Tcl_HashEntry *) ckalloc((unsigned) (sizeof(Tcl_HashEntry))); + hPtr->key.oneWordValue = (char *) objPtr; + Tcl_IncrRefCount (objPtr); + + return hPtr; +} + +/* + *---------------------------------------------------------------------- + * + * CompareObjKeys -- + * + * Compares two Tcl_Obj * keys. + * + * Results: + * The return value is 0 if they are different and 1 if they are + * the same. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +CompareObjKeys(keyPtr, hPtr) + VOID *keyPtr; /* New key to compare. */ + Tcl_HashEntry *hPtr; /* Existing key to compare. */ +{ + Tcl_Obj *objPtr1 = (Tcl_Obj *) keyPtr; + Tcl_Obj *objPtr2 = (Tcl_Obj *) hPtr->key.oneWordValue; + register CONST char *p1, *p2; + register int l1, l2; + + /* + * If the object pointers are the same then they match. + */ + if (objPtr1 == objPtr2) { + return 1; + } + + /* + * Don't use Tcl_GetStringFromObj as it would prevent l1 and l2 being + * in a register. + */ + p1 = Tcl_GetString (objPtr1); + l1 = objPtr1->length; + p2 = Tcl_GetString (objPtr2); + l2 = objPtr2->length; + + /* + * Only compare if the string representations are of the same length. + */ + if (l1 == l2) { + for (;; p1++, p2++, l1--) { + if (*p1 != *p2) { + break; + } + if (l1 == 0) { + return 1; + } + } + } + + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * FreeObjEntry -- + * + * Frees space for a Tcl_HashEntry containing the Tcl_Obj * key. + * + * Results: + * The return value is a pointer to the created entry. + * + * Side effects: + * Decrements the reference count of the object. + * + *---------------------------------------------------------------------- + */ + +static void +FreeObjEntry(hPtr) + Tcl_HashEntry *hPtr; /* Hash entry to free. */ +{ + Tcl_Obj *objPtr = (Tcl_Obj *) hPtr->key.oneWordValue; + + Tcl_DecrRefCount (objPtr); + ckfree ((char *) hPtr); +} + +/* + *---------------------------------------------------------------------- + * + * HashObjKey -- + * + * Compute a one-word summary of the string representation of the + * Tcl_Obj, which can be used to generate a hash index. + * + * Results: + * The return value is a one-word summary of the information in + * the string representation of the Tcl_Obj. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static unsigned int +HashObjKey(tablePtr, keyPtr) + Tcl_HashTable *tablePtr; /* Hash table. */ + VOID *keyPtr; /* Key from which to compute hash value. */ +{ + Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr; + register CONST char *string; + register int length; + register unsigned int result; + register int c; + + string = Tcl_GetString (objPtr); + length = objPtr->length; + + /* + * I tried a zillion different hash functions and asked many other + * people for advice. Many people had their own favorite functions, + * all different, but no-one had much idea why they were good ones. + * I chose the one below (multiply by 9 and add new character) + * because of the following reasons: + * + * 1. Multiplying by 10 is perfect for keys that are decimal strings, + * and multiplying by 9 is just about as good. + * 2. Times-9 is (shift-left-3) plus (old). This means that each + * character's bits hang around in the low-order bits of the + * hash value for ever, plus they spread fairly rapidly up to + * the high-order bits to fill out the hash value. This seems + * works well both for decimal and non-decimal strings. + */ + + result = 0; + while (length) { + c = *string; + string++; + length--; + if (length == 0) { + break; + } + result += (result<<3) + c; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetCommandFromObj -- + * + * Returns the command specified by the name in a Tcl_Obj. + * + * Results: + * Returns a token for the command if it is found. Otherwise, if it + * can't be found or there is an error, returns NULL. + * + * Side effects: + * May update the internal representation for the object, caching + * the command reference so that the next time this procedure is + * called with the same object, the command can be found quickly. + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +Tcl_GetCommandFromObj(interp, objPtr) + Tcl_Interp *interp; /* The interpreter in which to resolve the + * command and to report errors. */ + register Tcl_Obj *objPtr; /* The object containing the command's + * name. If the name starts with "::", will + * be looked up in global namespace. Else, + * looked up first in the current namespace, + * then in global namespace. */ +{ + Interp *iPtr = (Interp *) interp; + register ResolvedCmdName *resPtr; + register Command *cmdPtr; + Namespace *currNsPtr; + int result; + CallFrame *savedFramePtr; + char *name; + + /* + * If the variable name is fully qualified, do as if the lookup were + * done from the global namespace; this helps avoid repeated lookups + * of fully qualified names. It costs close to nothing, and may be very + * helpful for OO applications which pass along a command name ("this"), + * [Patch 456668] + */ + + savedFramePtr = iPtr->varFramePtr; + name = Tcl_GetString(objPtr); + if ((*name++ == ':') && (*name == ':')) { + iPtr->varFramePtr = NULL; + } + + /* + * Get the internal representation, converting to a command type if + * needed. The internal representation is a ResolvedCmdName that points + * to the actual command. + */ + + if (objPtr->typePtr != &tclCmdNameType) { + result = tclCmdNameType.setFromAnyProc(interp, objPtr); + if (result != TCL_OK) { + iPtr->varFramePtr = savedFramePtr; + return (Tcl_Command) NULL; + } + } + resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr; + + /* + * Get the current namespace. + */ + + if (iPtr->varFramePtr != NULL) { + currNsPtr = iPtr->varFramePtr->nsPtr; + } else { + currNsPtr = iPtr->globalNsPtr; + } + + /* + * Check the context namespace and the namespace epoch of the resolved + * symbol to make sure that it is fresh. If not, then force another + * conversion to the command type, to discard the old rep and create a + * new one. Note that we verify that the namespace id of the context + * namespace is the same as the one we cached; this insures that the + * namespace wasn't deleted and a new one created at the same address + * with the same command epoch. + */ + + cmdPtr = NULL; + if ((resPtr != NULL) + && (resPtr->refNsPtr == currNsPtr) + && (resPtr->refNsId == currNsPtr->nsId) + && (resPtr->refNsCmdEpoch == currNsPtr->cmdRefEpoch)) { + cmdPtr = resPtr->cmdPtr; + if (cmdPtr->cmdEpoch != resPtr->cmdEpoch) { + cmdPtr = NULL; + } + } + + if (cmdPtr == NULL) { + result = tclCmdNameType.setFromAnyProc(interp, objPtr); + if (result != TCL_OK) { + iPtr->varFramePtr = savedFramePtr; + return (Tcl_Command) NULL; + } + resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr; + if (resPtr != NULL) { + cmdPtr = resPtr->cmdPtr; + } + } + iPtr->varFramePtr = savedFramePtr; + return (Tcl_Command) cmdPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclSetCmdNameObj -- + * + * Modify an object to be an CmdName object that refers to the argument + * Command structure. + * + * Results: + * None. + * + * Side effects: + * The object's old internal rep is freed. It's string rep is not + * changed. The refcount in the Command structure is incremented to + * keep it from being freed if the command is later deleted until + * TclExecuteByteCode has a chance to recognize that it was deleted. + * + *---------------------------------------------------------------------- + */ + +void +TclSetCmdNameObj(interp, objPtr, cmdPtr) + Tcl_Interp *interp; /* Points to interpreter containing command + * that should be cached in objPtr. */ + register Tcl_Obj *objPtr; /* Points to Tcl object to be changed to + * a CmdName object. */ + Command *cmdPtr; /* Points to Command structure that the + * CmdName object should refer to. */ +{ + Interp *iPtr = (Interp *) interp; + register ResolvedCmdName *resPtr; + Tcl_ObjType *oldTypePtr = objPtr->typePtr; + register Namespace *currNsPtr; + + if (oldTypePtr == &tclCmdNameType) { + return; + } + + /* + * Get the current namespace. + */ + + if (iPtr->varFramePtr != NULL) { + currNsPtr = iPtr->varFramePtr->nsPtr; + } else { + currNsPtr = iPtr->globalNsPtr; + } + + cmdPtr->refCount++; + resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName)); + resPtr->cmdPtr = cmdPtr; + resPtr->refNsPtr = currNsPtr; + resPtr->refNsId = currNsPtr->nsId; + resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; + resPtr->cmdEpoch = cmdPtr->cmdEpoch; + resPtr->refCount = 1; + + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); + } + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; + objPtr->typePtr = &tclCmdNameType; +} + +/* + *---------------------------------------------------------------------- + * + * FreeCmdNameInternalRep -- + * + * Frees the resources associated with a cmdName object's internal + * representation. + * + * Results: + * None. + * + * Side effects: + * Decrements the ref count of any cached ResolvedCmdName structure + * pointed to by the cmdName's internal representation. If this is + * the last use of the ResolvedCmdName, it is freed. This in turn + * decrements the ref count of the Command structure pointed to by + * the ResolvedSymbol, which may free the Command structure. + * + *---------------------------------------------------------------------- + */ + +static void +FreeCmdNameInternalRep(objPtr) + register Tcl_Obj *objPtr; /* CmdName object with internal + * representation to free. */ +{ + register ResolvedCmdName *resPtr = + (ResolvedCmdName *) objPtr->internalRep.otherValuePtr; + + if (resPtr != NULL) { + /* + * Decrement the reference count of the ResolvedCmdName structure. + * If there are no more uses, free the ResolvedCmdName structure. + */ + + resPtr->refCount--; + if (resPtr->refCount == 0) { + /* + * Now free the cached command, unless it is still in its + * hash table or if there are other references to it + * from other cmdName objects. + */ + + Command *cmdPtr = resPtr->cmdPtr; + TclCleanupCommand(cmdPtr); + ckfree((char *) resPtr); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * DupCmdNameInternalRep -- + * + * Initialize the internal representation of an cmdName Tcl_Obj to a + * copy of the internal representation of an existing cmdName object. + * + * Results: + * None. + * + * Side effects: + * "copyPtr"s internal rep is set to point to the ResolvedCmdName + * structure corresponding to "srcPtr"s internal rep. Increments the + * ref count of the ResolvedCmdName structure pointed to by the + * cmdName's internal representation. + * + *---------------------------------------------------------------------- + */ + +static void +DupCmdNameInternalRep(srcPtr, copyPtr) + Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ + register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ +{ + register ResolvedCmdName *resPtr = + (ResolvedCmdName *) srcPtr->internalRep.otherValuePtr; + + copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; + copyPtr->internalRep.twoPtrValue.ptr2 = NULL; + if (resPtr != NULL) { + resPtr->refCount++; + } + copyPtr->typePtr = &tclCmdNameType; +} + +/* + *---------------------------------------------------------------------- + * + * SetCmdNameFromAny -- + * + * Generate an cmdName internal form for the Tcl object "objPtr". + * + * Results: + * The return value is a standard Tcl result. The conversion always + * succeeds and TCL_OK is returned. + * + * Side effects: + * A pointer to a ResolvedCmdName structure that holds a cached pointer + * to the command with a name that matches objPtr's string rep is + * stored as objPtr's internal representation. This ResolvedCmdName + * pointer will be NULL if no matching command was found. The ref count + * of the cached Command's structure (if any) is also incremented. + * + *---------------------------------------------------------------------- + */ + +static int +SetCmdNameFromAny(interp, objPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr; /* The object to convert. */ +{ + Interp *iPtr = (Interp *) interp; + char *name; + Tcl_Command cmd; + register Command *cmdPtr; + Namespace *currNsPtr; + register ResolvedCmdName *resPtr; + + /* + * Get "objPtr"s string representation. Make it up-to-date if necessary. + */ + + name = objPtr->bytes; + if (name == NULL) { + name = Tcl_GetString(objPtr); + } + + /* + * Find the Command structure, if any, that describes the command called + * "name". Build a ResolvedCmdName that holds a cached pointer to this + * Command, and bump the reference count in the referenced Command + * structure. A Command structure will not be deleted as long as it is + * referenced from a CmdName object. + */ + + cmd = Tcl_FindCommand(interp, name, (Tcl_Namespace *) NULL, + /*flags*/ 0); + cmdPtr = (Command *) cmd; + if (cmdPtr != NULL) { + /* + * Get the current namespace. + */ + + if (iPtr->varFramePtr != NULL) { + currNsPtr = iPtr->varFramePtr->nsPtr; + } else { + currNsPtr = iPtr->globalNsPtr; + } + + cmdPtr->refCount++; + resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName)); + resPtr->cmdPtr = cmdPtr; + resPtr->refNsPtr = currNsPtr; + resPtr->refNsId = currNsPtr->nsId; + resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; + resPtr->cmdEpoch = cmdPtr->cmdEpoch; + resPtr->refCount = 1; + } else { + resPtr = NULL; /* no command named "name" was found */ + } + + /* + * Free the old internalRep before setting the new one. We do this as + * late as possible to allow the conversion code, in particular + * GetStringFromObj, to use that old internalRep. If no Command + * structure was found, leave NULL as the cached value. + */ + + if ((objPtr->typePtr != NULL) + && (objPtr->typePtr->freeIntRepProc != NULL)) { + objPtr->typePtr->freeIntRepProc(objPtr); + } + + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; + objPtr->typePtr = &tclCmdNameType; + return TCL_OK; +} diff --git a/tcl/generic/tclPanic.c b/tcl/generic/tclPanic.c index 4e8cc1e2365..4f446b329cf 100644 --- a/tcl/generic/tclPanic.c +++ b/tcl/generic/tclPanic.c @@ -2,8 +2,8 @@ * tclPanic.c -- * * Source code for the "Tcl_Panic" library procedure for Tcl; - * individual applications will probably override this with - * an application-specific panic procedure. + * individual 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. @@ -16,13 +16,23 @@ */ #include "tclInt.h" +#include "tclPort.h" /* * The panicProc variable contains a pointer to an application * specific panic procedure. */ -void (*panicProc) _ANSI_ARGS_(TCL_VARARGS(char *,format)) = NULL; +static Tcl_PanicProc *panicProc = NULL; + +/* + * The platformPanicProc variable contains a pointer to a platform + * specific panic procedure, if any. ( TclpPanic may be NULL via + * a macro. ) + */ + +static Tcl_PanicProc * CONST platformPanicProc = TclpPanic; + /* *---------------------------------------------------------------------- @@ -42,7 +52,7 @@ void (*panicProc) _ANSI_ARGS_(TCL_VARARGS(char *,format)) = NULL; void Tcl_SetPanicProc(proc) - void (*proc) _ANSI_ARGS_(TCL_VARARGS(char *,format)); + Tcl_PanicProc *proc; { panicProc = proc; } @@ -65,7 +75,7 @@ Tcl_SetPanicProc(proc) void Tcl_PanicVA (format, argList) - char *format; /* Format string, suitable for passing to + CONST char *format; /* Format string, suitable for passing to * fprintf. */ va_list argList; /* Variable argument list. */ { @@ -85,6 +95,9 @@ Tcl_PanicVA (format, argList) if (panicProc != NULL) { (void) (*panicProc)(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); + } else if (platformPanicProc != NULL) { + (void) (*platformPanicProc)(format, arg1, arg2, arg3, arg4, + arg5, arg6, arg7, arg8); } else { (void) fprintf(stderr, format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); @@ -97,7 +110,7 @@ Tcl_PanicVA (format, argList) /* *---------------------------------------------------------------------- * - * panic -- + * Tcl_Panic -- * * Print an error message and kill the process. * @@ -112,12 +125,12 @@ Tcl_PanicVA (format, argList) /* VARARGS ARGSUSED */ void -panic TCL_VARARGS_DEF(char *,arg1) +Tcl_Panic TCL_VARARGS_DEF(CONST char *,arg1) { va_list argList; - char *format; + CONST char *format; - format = TCL_VARARGS_START(char *,arg1,argList); + format = TCL_VARARGS_START(CONST char *,arg1,argList); Tcl_PanicVA(format, argList); va_end (argList); } diff --git a/tcl/generic/tclParse.c b/tcl/generic/tclParse.c index 1422cd02336..c39f8f57156 100644 --- a/tcl/generic/tclParse.c +++ b/tcl/generic/tclParse.c @@ -4,12 +4,11 @@ * This file contains procedures that parse Tcl scripts. They * do so in a general-purpose fashion that can be used for many * different purposes, including compilation, direct execution, - * code analysis, etc. This file also includes a few additional - * procedures such as Tcl_EvalObjv, Tcl_Eval, and Tcl_EvalEx, which - * allow scripts to be evaluated directly, without compiling. + * code analysis, etc. * * Copyright (c) 1997 Sun Microsystems, Inc. - * Copyright (c) 1998 by Scriptics Corporation. + * Copyright (c) 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 this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -33,32 +32,32 @@ * information about its character argument. The following return * values are defined. * - * TYPE_NORMAL - All characters that don't have special significance - * to the Tcl parser. - * TYPE_SPACE - The character is a whitespace character other - * than newline. - * TYPE_COMMAND_END - Character is newline or semicolon. - * TYPE_SUBS - Character begins a substitution or has other - * special meaning in ParseTokens: backslash, dollar - * sign, open bracket, or null. - * TYPE_QUOTE - Character is a double quote. - * TYPE_CLOSE_PAREN - Character is a right parenthesis. - * TYPE_CLOSE_BRACK - Character is a right square bracket. - * TYPE_BRACE - Character is a curly brace (either left or right). + * TYPE_NORMAL - All characters that don't have special significance + * to the Tcl parser. + * TYPE_SPACE - The character is a whitespace character other + * than newline. + * TYPE_COMMAND_END - Character is newline or semicolon. + * TYPE_SUBS - Character begins a substitution or has other + * special meaning in ParseTokens: backslash, dollar + * sign, or open bracket. + * TYPE_QUOTE - Character is a double quote. + * TYPE_CLOSE_PAREN - Character is a right parenthesis. + * TYPE_CLOSE_BRACK - Character is a right square bracket. + * TYPE_BRACE - Character is a curly brace (either left or right). */ -#define TYPE_NORMAL 0 -#define TYPE_SPACE 0x1 -#define TYPE_COMMAND_END 0x2 -#define TYPE_SUBS 0x4 -#define TYPE_QUOTE 0x8 -#define TYPE_CLOSE_PAREN 0x10 -#define TYPE_CLOSE_BRACK 0x20 -#define TYPE_BRACE 0x40 +#define TYPE_NORMAL 0 +#define TYPE_SPACE 0x1 +#define TYPE_COMMAND_END 0x2 +#define TYPE_SUBS 0x4 +#define TYPE_QUOTE 0x8 +#define TYPE_CLOSE_PAREN 0x10 +#define TYPE_CLOSE_BRACK 0x20 +#define TYPE_BRACE 0x40 -#define CHAR_TYPE(c) (typeTable+128)[(int)(c)] +#define CHAR_TYPE(c) (charTypeTable+128)[(int)(c)] -char typeTable[] = { +static CONST char charTypeTable[] = { /* * Negative character values, from -128 to -1: */ @@ -175,14 +174,13 @@ char typeTable[] = { * Prototypes for local procedures defined in this file: */ -static int CommandComplete _ANSI_ARGS_((char *script, - int length)); -static int ParseTokens _ANSI_ARGS_((char *src, int mask, +static int CommandComplete _ANSI_ARGS_((CONST char *script, + int numBytes)); +static int ParseComment _ANSI_ARGS_((CONST char *src, int numBytes, Tcl_Parse *parsePtr)); -static int EvalObjv _ANSI_ARGS_((Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[], char *command, int length, - int flags)); - +static int ParseTokens _ANSI_ARGS_((CONST char *src, int numBytes, + int mask, Tcl_Parse *parsePtr)); + /* *---------------------------------------------------------------------- * @@ -214,14 +212,9 @@ Tcl_ParseCommand(interp, string, numBytes, nested, parsePtr) Tcl_Interp *interp; /* Interpreter to use for error reporting; * if NULL, then no error message is * provided. */ - char *string; /* First character of string containing - * one or more Tcl commands. The string - * must be in writable memory and must - * have one additional byte of space at - * string[length] where we can - * temporarily store a 0 sentinel - * character. */ - int numBytes; /* Total number of bytes in string. If < 0, + CONST char *string; /* First character of string containing + * one or more Tcl commands. */ + register int numBytes; /* Total number of bytes in string. If < 0, * the script consists of all bytes up to * the first null character. */ int nested; /* Non-zero means this is a nested command: @@ -234,21 +227,25 @@ Tcl_ParseCommand(interp, string, numBytes, nested, parsePtr) * information in the structure is * ignored. */ { - register char *src; /* Points to current character + register CONST char *src; /* Points to current character * in the command. */ - int type; /* Result returned by CHAR_TYPE(*src). */ + char type; /* Result returned by CHAR_TYPE(*src). */ Tcl_Token *tokenPtr; /* Pointer to token being filled in. */ int wordIndex; /* Index of word token for current word. */ - char utfBytes[TCL_UTF_MAX]; /* Holds result of backslash substitution. */ int terminators; /* CHAR_TYPE bits that indicate the end * of a command. */ - char *termPtr; /* Set by Tcl_ParseBraces/QuotedString to + CONST char *termPtr; /* Set by Tcl_ParseBraces/QuotedString to * point to char after terminating one. */ - int length, savedChar; - - + int scanned; + + if ((string == NULL) && (numBytes>0)) { + if (interp != NULL) { + Tcl_SetResult(interp, "can't parse a NULL pointer", TCL_STATIC); + } + return TCL_ERROR; + } if (numBytes < 0) { - numBytes = (string? strlen(string) : 0); + numBytes = strlen(string); } parsePtr->commentStart = NULL; parsePtr->commentSize = 0; @@ -271,66 +268,15 @@ Tcl_ParseCommand(interp, string, numBytes, nested, parsePtr) } /* - * Temporarily overwrite the character just after the end of the - * string with a 0 byte. This acts as a sentinel and reduces the - * number of places where we have to check for the end of the - * input string. The original value of the byte is restored at - * the end of the parse. - */ - - savedChar = string[numBytes]; - if (savedChar != 0) { - string[numBytes] = 0; - } - - /* * Parse any leading space and comments before the first word of the * command. */ - src = string; - while (1) { - while ((CHAR_TYPE(*src) == TYPE_SPACE) || (*src == '\n')) { - src++; - } - if ((*src == '\\') && (src[1] == '\n')) { - /* - * Skip backslash-newline sequence: it should be treated - * just like white space. - */ - - if ((src + 2) == parsePtr->end) { - parsePtr->incomplete = 1; - } - src += 2; - continue; - } - if (*src != '#') { - break; - } - if (parsePtr->commentStart == NULL) { - parsePtr->commentStart = src; - } - while (1) { - if (src == parsePtr->end) { - if (nested) { - parsePtr->incomplete = nested; - } - parsePtr->commentSize = src - parsePtr->commentStart; - break; - } else if (*src == '\\') { - if ((src[1] == '\n') && ((src + 2) == parsePtr->end)) { - parsePtr->incomplete = 1; - } - Tcl_UtfBackslash(src, &length, utfBytes); - src += length; - } else if (*src == '\n') { - src++; - parsePtr->commentSize = src - parsePtr->commentStart; - break; - } else { - src++; - } + scanned = ParseComment(string, numBytes, parsePtr); + src = (string + scanned); numBytes -= scanned; + if (numBytes == 0) { + if (nested) { + parsePtr->incomplete = nested; } } @@ -357,19 +303,9 @@ Tcl_ParseCommand(interp, string, numBytes, nested, parsePtr) * sequence: it should be treated just like white space. */ - while (1) { - type = CHAR_TYPE(*src); - if (type == TYPE_SPACE) { - src++; - continue; - } else if ((*src == '\\') && (src[1] == '\n')) { - if ((src + 2) == parsePtr->end) { - parsePtr->incomplete = 1; - } - Tcl_UtfBackslash(src, &length, utfBytes); - src += length; - continue; - } + scanned = TclParseWhiteSpace(src, numBytes, parsePtr, &type); + src += scanned; numBytes -= scanned; + if (numBytes == 0) { break; } if ((type & terminators) != 0) { @@ -377,9 +313,6 @@ Tcl_ParseCommand(interp, string, numBytes, nested, parsePtr) src++; break; } - if (src == parsePtr->end) { - break; - } tokenPtr->start = src; parsePtr->numTokens++; parsePtr->numWords++; @@ -391,28 +324,28 @@ Tcl_ParseCommand(interp, string, numBytes, nested, parsePtr) */ if (*src == '"') { - if (Tcl_ParseQuotedString(interp, src, (parsePtr->end - src), - parsePtr, 1, &termPtr) != TCL_OK) { + if (Tcl_ParseQuotedString(interp, src, numBytes, + parsePtr, 1, &termPtr) != TCL_OK) { goto error; } - src = termPtr; + src = termPtr; numBytes = parsePtr->end - src; } else if (*src == '{') { - if (Tcl_ParseBraces(interp, src, (parsePtr->end - src), - parsePtr, 1, &termPtr) != TCL_OK) { + if (Tcl_ParseBraces(interp, src, numBytes, + parsePtr, 1, &termPtr) != TCL_OK) { goto error; } - src = termPtr; + src = termPtr; numBytes = parsePtr->end - src; } else { /* * This is an unquoted word. Call ParseTokens and let it do * all of the work. */ - if (ParseTokens(src, TYPE_SPACE|terminators, + if (ParseTokens(src, numBytes, TYPE_SPACE|terminators, parsePtr) != TCL_OK) { goto error; } - src = parsePtr->term; + src = parsePtr->term; numBytes = parsePtr->end - src; } /* @@ -436,32 +369,18 @@ Tcl_ParseCommand(interp, string, numBytes, nested, parsePtr) * command. */ - type = CHAR_TYPE(*src); - if (type == TYPE_SPACE) { - src++; + scanned = TclParseWhiteSpace(src, numBytes, parsePtr, &type); + if (scanned) { + src += scanned; numBytes -= scanned; continue; - } else { - /* - * Backslash-newline (and any following white space) must be - * treated as if it were a space character. - */ - - if ((*src == '\\') && (src[1] == '\n')) { - if ((src + 2) == parsePtr->end) { - parsePtr->incomplete = 1; - } - Tcl_UtfBackslash(src, &length, utfBytes); - src += length; - continue; - } } - if ((type & terminators) != 0) { - parsePtr->term = src; - src++; + if (numBytes == 0) { break; } - if (src == parsePtr->end) { + if ((type & terminators) != 0) { + parsePtr->term = src; + src++; break; } if (src[-1] == '"') { @@ -481,17 +400,10 @@ Tcl_ParseCommand(interp, string, numBytes, nested, parsePtr) goto error; } - parsePtr->commandSize = src - parsePtr->commandStart; - if (savedChar != 0) { - string[numBytes] = (char) savedChar; - } return TCL_OK; error: - if (savedChar != 0) { - string[numBytes] = (char) savedChar; - } Tcl_FreeParse(parsePtr); if (parsePtr->commandStart == NULL) { parsePtr->commandStart = string; @@ -499,17 +411,361 @@ Tcl_ParseCommand(interp, string, numBytes, nested, parsePtr) parsePtr->commandSize = parsePtr->term - parsePtr->commandStart; return TCL_ERROR; } + +/* + *---------------------------------------------------------------------- + * + * TclParseWhiteSpace -- + * + * Scans up to numBytes bytes starting at src, consuming white + * space as defined by Tcl's parsing rules. + * + * Results: + * Returns the number of bytes recognized as white space. Records + * at parsePtr, information about the parse. Records at typePtr + * the character type of the non-whitespace character that terminated + * the scan. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +int +TclParseWhiteSpace(src, numBytes, parsePtr, typePtr) + CONST char *src; /* First character to parse. */ + register int numBytes; /* Max number of bytes to scan. */ + Tcl_Parse *parsePtr; /* Information about parse in progress. + * Updated if parsing indicates + * an incomplete command. */ + char *typePtr; /* Points to location to store character + * type of character that ends run + * of whitespace */ +{ + register char type = TYPE_NORMAL; + register CONST char *p = src; + + while (1) { + while (numBytes && ((type = CHAR_TYPE(*p)) & TYPE_SPACE)) { + numBytes--; p++; + } + if (numBytes && (type & TYPE_SUBS)) { + if (*p != '\\') { + break; + } + if (--numBytes == 0) { + break; + } + if (p[1] != '\n') { + break; + } + p+=2; + if (--numBytes == 0) { + parsePtr->incomplete = 1; + break; + } + continue; + } + break; + } + *typePtr = type; + return (p - src); +} /* *---------------------------------------------------------------------- * + * TclParseHex -- + * + * Scans a hexadecimal number as a Tcl_UniChar value. + * (e.g., for parsing \x and \u escape sequences). + * At most numBytes bytes are scanned. + * + * Results: + * The numeric value is stored in *resultPtr. + * Returns the number of bytes consumed. + * + * Notes: + * Relies on the following properties of the ASCII + * character set, with which UTF-8 is compatible: + * + * The digits '0' .. '9' and the letters 'A' .. 'Z' and 'a' .. 'z' + * occupy consecutive code points, and '0' < 'A' < 'a'. + * + *---------------------------------------------------------------------- + */ +int +TclParseHex(src, numBytes, resultPtr) + CONST char *src; /* First character to parse. */ + int numBytes; /* Max number of byes to scan */ + Tcl_UniChar *resultPtr; /* Points to storage provided by + * caller where the Tcl_UniChar + * resulting from the conversion is + * to be written. */ +{ + Tcl_UniChar result = 0; + register CONST char *p = src; + + while (numBytes--) { + unsigned char digit = UCHAR(*p); + + if (!isxdigit(digit)) + break; + + ++p; + result <<= 4; + + if (digit >= 'a') { + result |= (10 + digit - 'a'); + } else if (digit >= 'A') { + result |= (10 + digit - 'A'); + } else { + result |= (digit - '0'); + } + } + + *resultPtr = result; + return (p - src); +} + +/* + *---------------------------------------------------------------------- + * + * TclParseBackslash -- + * + * Scans up to numBytes bytes starting at src, consuming a + * backslash sequence as defined by Tcl's parsing rules. + * + * Results: + * Records at readPtr the number of bytes making up the backslash + * sequence. Records at dst the UTF-8 encoded equivalent of + * that backslash sequence. Returns the number of bytes written + * to dst, at most TCL_UTF_MAX. Either readPtr or dst may be + * NULL, if the results are not needed, but the return value is + * the same either way. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +int +TclParseBackslash(src, numBytes, readPtr, dst) + CONST char * src; /* Points to the backslash character of a + * a backslash sequence */ + int numBytes; /* Max number of bytes to scan */ + int *readPtr; /* NULL, or points to storage where the + * number 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. */ +{ + register CONST char *p = src+1; + Tcl_UniChar result; + int count; + char buf[TCL_UTF_MAX]; + + if (numBytes == 0) { + if (readPtr != NULL) { + *readPtr = 0; + } + return 0; + } + + if (dst == NULL) { + dst = buf; + } + + if (numBytes == 1) { + /* Can only scan the backslash. Return it. */ + result = '\\'; + count = 1; + goto done; + } + + count = 2; + switch (*p) { + /* + * Note: in the conversions below, use absolute values (e.g., + * 0xa) rather than symbolic values (e.g. \n) that get converted + * by the compiler. It's possible that compilers on some + * platforms will do the symbolic conversions differently, which + * could result in non-portable Tcl scripts. + */ + + case 'a': + result = 0x7; + break; + case 'b': + result = 0x8; + break; + case 'f': + result = 0xc; + break; + case 'n': + result = 0xa; + break; + case 'r': + result = 0xd; + break; + case 't': + result = 0x9; + break; + case 'v': + result = 0xb; + break; + case 'x': + count += TclParseHex(p+1, numBytes-1, &result); + if (count == 2) { + /* No hexadigits -> This is just "x". */ + result = 'x'; + } else { + /* Keep only the last byte (2 hex digits) */ + result = (unsigned char) result; + } + break; + case 'u': + count += TclParseHex(p+1, (numBytes > 5) ? 4 : numBytes-1, &result); + if (count == 2) { + /* No hexadigits -> This is just "u". */ + result = 'u'; + } + break; + case '\n': + count--; + do { + p++; count++; + } while ((count < numBytes) && ((*p == ' ') || (*p == '\t'))); + result = ' '; + break; + case 0: + result = '\\'; + count = 1; + break; + default: + /* + * Check for an octal number \oo?o? + */ + if (isdigit(UCHAR(*p)) && (UCHAR(*p) < '8')) { /* INTL: digit */ + result = (unsigned char)(*p - '0'); + p++; + if ((numBytes == 2) || !isdigit(UCHAR(*p)) /* INTL: digit */ + || (UCHAR(*p) >= '8')) { + break; + } + count = 3; + result = (unsigned char)((result << 3) + (*p - '0')); + p++; + if ((numBytes == 3) || !isdigit(UCHAR(*p)) /* INTL: digit */ + || (UCHAR(*p) >= '8')) { + break; + } + count = 4; + result = (unsigned char)((result << 3) + (*p - '0')); + break; + } + /* + * We have to convert here in case the user has put a + * backslash in front of a multi-byte utf-8 character. + * While this means nothing special, we shouldn't break up + * a correct utf-8 character. [Bug #217987] test subst-3.2 + */ + if (Tcl_UtfCharComplete(p, numBytes - 1)) { + count = Tcl_UtfToUniChar(p, &result) + 1; /* +1 for '\' */ + } else { + char utfBytes[TCL_UTF_MAX]; + memcpy(utfBytes, p, (size_t) (numBytes - 1)); + utfBytes[numBytes - 1] = '\0'; + count = Tcl_UtfToUniChar(utfBytes, &result) + 1; + } + break; + } + + done: + if (readPtr != NULL) { + *readPtr = count; + } + return Tcl_UniCharToUtf((int) result, dst); +} + +/* + *---------------------------------------------------------------------- + * + * ParseComment -- + * + * Scans up to numBytes bytes starting at src, consuming a + * Tcl comment as defined by Tcl's parsing rules. + * + * Results: + * Records in parsePtr information about the parse. Returns the + * number of bytes consumed. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +static int +ParseComment(src, numBytes, parsePtr) + CONST char *src; /* First character to parse. */ + register int numBytes; /* Max number of bytes to scan. */ + Tcl_Parse *parsePtr; /* Information about parse in progress. + * Updated if parsing indicates + * an incomplete command. */ +{ + register CONST char *p = src; + while (numBytes) { + char type; + int scanned; + do { + scanned = TclParseWhiteSpace(p, numBytes, parsePtr, &type); + p += scanned; numBytes -= scanned; + } while (numBytes && (*p == '\n') && (p++,numBytes--)); + if ((numBytes == 0) || (*p != '#')) { + break; + } + if (parsePtr->commentStart == NULL) { + parsePtr->commentStart = p; + } + while (numBytes) { + if (*p == '\\') { + scanned = TclParseWhiteSpace(p, numBytes, parsePtr, &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') { + break; + } + } + } + parsePtr->commentSize = p - parsePtr->commentStart; + } + return (p - src); +} + +/* + *---------------------------------------------------------------------- + * * ParseTokens -- * * This procedure forms the heart of the Tcl parser. It parses one * or more tokens from a string, up to a termination point * specified by the caller. This procedure is used to parse * unquoted command words (those not in quotes or braces), words in - * quotes, and array indices for variables. + * quotes, and array indices for variables. No more than numBytes + * bytes will be scanned. * * Results: * Tokens are added to parsePtr and parsePtr->term is filled in @@ -527,8 +783,9 @@ Tcl_ParseCommand(interp, string, numBytes, nested, parsePtr) */ static int -ParseTokens(src, mask, parsePtr) - register char *src; /* First character to parse. */ +ParseTokens(src, numBytes, mask, parsePtr) + register CONST char *src; /* First character to parse. */ + register int numBytes; /* Max number of bytes to scan. */ int mask; /* Specifies when to stop parsing. The * parse stops at the first unquoted * character whose CHAR_TYPE contains @@ -537,8 +794,8 @@ ParseTokens(src, mask, parsePtr) * Updated with additional tokens and * termination information. */ { - int type, originalTokens, varToken; - char utfBytes[TCL_UTF_MAX]; + char type; + int originalTokens, varToken; Tcl_Token *tokenPtr; Tcl_Parse nested; @@ -550,7 +807,7 @@ ParseTokens(src, mask, parsePtr) */ originalTokens = parsePtr->numTokens; - while (1) { + while (numBytes && !((type = CHAR_TYPE(*src)) & mask)) { if (parsePtr->numTokens == parsePtr->tokensAvailable) { TclExpandTokenArray(parsePtr); } @@ -558,22 +815,15 @@ ParseTokens(src, mask, parsePtr) tokenPtr->start = src; tokenPtr->numComponents = 0; - type = CHAR_TYPE(*src); - if (type & mask) { - break; - } - if ((type & TYPE_SUBS) == 0) { /* * This is a simple range of characters. Scan to find the end * of the range. */ - while (1) { - src++; - if (CHAR_TYPE(*src) & (mask | TYPE_SUBS)) { - break; - } + while ((++src, --numBytes) + && !(CHAR_TYPE(*src) & (mask | TYPE_SUBS))) { + /* empty loop */ } tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->size = src - tokenPtr->start; @@ -585,11 +835,12 @@ ParseTokens(src, mask, parsePtr) */ varToken = parsePtr->numTokens; - if (Tcl_ParseVarName(parsePtr->interp, src, parsePtr->end - src, + if (Tcl_ParseVarName(parsePtr->interp, src, numBytes, parsePtr, 1) != TCL_OK) { return TCL_ERROR; } src += parsePtr->tokenPtr[varToken].size; + numBytes -= parsePtr->tokenPtr[varToken].size; } else if (*src == '[') { /* * Command substitution. Call Tcl_ParseCommand recursively @@ -597,23 +848,24 @@ ParseTokens(src, mask, parsePtr) * throw away the parse information. */ - src++; + src++; numBytes--; while (1) { if (Tcl_ParseCommand(parsePtr->interp, src, - parsePtr->end - src, 1, &nested) != TCL_OK) { + numBytes, 1, &nested) != TCL_OK) { parsePtr->errorType = nested.errorType; parsePtr->term = nested.term; parsePtr->incomplete = nested.incomplete; return TCL_ERROR; } src = nested.commandStart + nested.commandSize; + numBytes = parsePtr->end - src; if (nested.tokenPtr != nested.staticTokens) { ckfree((char *) nested.tokenPtr); } if ((*nested.term == ']') && !nested.incomplete) { break; } - if (src == parsePtr->end) { + if (numBytes == 0) { if (parsePtr->interp != NULL) { Tcl_SetResult(parsePtr->interp, "missing close-bracket", TCL_STATIC); @@ -631,9 +883,18 @@ ParseTokens(src, mask, parsePtr) /* * Backslash substitution. */ + TclParseBackslash(src, numBytes, &tokenPtr->size, NULL); + + if (tokenPtr->size == 1) { + /* Just a backslash, due to end of string */ + tokenPtr->type = TCL_TOKEN_TEXT; + parsePtr->numTokens++; + src++; numBytes--; + continue; + } if (src[1] == '\n') { - if ((src + 2) == parsePtr->end) { + if (numBytes == 2) { parsePtr->incomplete = 1; } @@ -644,28 +905,22 @@ ParseTokens(src, mask, parsePtr) */ if (mask & TYPE_SPACE) { + if (parsePtr->numTokens == originalTokens) { + goto finishToken; + } break; } } + tokenPtr->type = TCL_TOKEN_BS; - Tcl_UtfBackslash(src, &tokenPtr->size, utfBytes); parsePtr->numTokens++; src += tokenPtr->size; + numBytes -= tokenPtr->size; } else if (*src == 0) { - /* - * We encountered a null character. If it is the null - * character at the end of the string, then return. - * Otherwise generate a text token for the single - * character. - */ - - if (src == parsePtr->end) { - break; - } tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->size = 1; parsePtr->numTokens++; - src++; + src++; numBytes--; } else { panic("ParseTokens encountered unknown character"); } @@ -676,7 +931,14 @@ ParseTokens(src, mask, parsePtr) * for the empty range, so that there is always at least one * token added. */ + if (parsePtr->numTokens == parsePtr->tokensAvailable) { + TclExpandTokenArray(parsePtr); + } + tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens]; + tokenPtr->start = src; + tokenPtr->numComponents = 0; + finishToken: tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->size = 0; parsePtr->numTokens++; @@ -684,7 +946,7 @@ ParseTokens(src, mask, parsePtr) parsePtr->term = src; return TCL_OK; } - + /* *---------------------------------------------------------------------- * @@ -713,7 +975,7 @@ Tcl_FreeParse(parsePtr) parsePtr->tokenPtr = parsePtr->staticTokens; } } - + /* *---------------------------------------------------------------------- * @@ -751,819 +1013,15 @@ TclExpandTokenArray(parsePtr) parsePtr->tokenPtr = newPtr; parsePtr->tokensAvailable = newCount; } - -/* - *---------------------------------------------------------------------- - * - * EvalObjv -- - * - * This procedure evaluates a Tcl command that has already been - * parsed into words, with one Tcl_Obj holding each word. - * - * Results: - * The return value is a standard Tcl completion code such as - * TCL_OK or TCL_ERROR. A result or error message is left in - * interp's result. If an error occurs, this procedure does - * NOT add any information to the errorInfo variable. - * - * Side effects: - * Depends on the command. - * - *---------------------------------------------------------------------- - */ - -static int -EvalObjv(interp, objc, objv, command, length, flags) - Tcl_Interp *interp; /* Interpreter in which to evaluate the - * command. Also used for error - * reporting. */ - int objc; /* Number of words in command. */ - Tcl_Obj *CONST objv[]; /* An array of pointers to objects that are - * the words that make up the command. */ - char *command; /* Points to the beginning of the string - * representation of the command; this - * is used for traces. If the string - * representation of the command is - * unknown, an empty string should be - * supplied. */ - int length; /* Number of bytes in command; if -1, all - * characters up to the first null byte are - * used. */ - int flags; /* Collection of OR-ed bits that control - * the evaluation of the script. Only - * TCL_EVAL_GLOBAL is currently - * supported. */ - -{ - Command *cmdPtr; - Interp *iPtr = (Interp *) interp; - Tcl_Obj **newObjv; - int i, code; - Trace *tracePtr, *nextPtr; - char **argv, *commandCopy; - CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr - * in case TCL_EVAL_GLOBAL was set. */ - Tcl_ResetResult(interp); - if (objc == 0) { - return TCL_OK; - } - - /* - * If the interpreter was deleted, return an error. - */ - - if (iPtr->flags & DELETED) { - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "attempt to call eval in deleted interpreter", -1); - Tcl_SetErrorCode(interp, "CORE", "IDELETE", - "attempt to call eval in deleted interpreter", - (char *) NULL); - return TCL_ERROR; - } - - /* - * Check depth of nested calls to Tcl_Eval: if this gets too large, - * it's probably because of an infinite loop somewhere. - */ - - if (iPtr->numLevels >= iPtr->maxNestingDepth) { - iPtr->result = "too many nested calls to Tcl_Eval (infinite loop?)"; - return TCL_ERROR; - } - iPtr->numLevels++; - - /* - * On the Mac, we will never reach the default recursion limit before - * blowing the stack. So we need to do a check here. - */ - - if (TclpCheckStackSpace() == 0) { - /*NOTREACHED*/ - iPtr->numLevels--; - iPtr->result = "too many nested calls to Tcl_Eval (infinite loop?)"; - return TCL_ERROR; - } - - /* - * Find the procedure to execute this command. If there isn't one, - * then see if there is a command "unknown". If so, create a new - * word array with "unknown" as the first word and the original - * command words as arguments. Then call ourselves recursively - * to execute it. - */ - - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); - if (cmdPtr == NULL) { - newObjv = (Tcl_Obj **) ckalloc((unsigned) - ((objc + 1) * sizeof (Tcl_Obj *))); - for (i = objc-1; i >= 0; i--) { - newObjv[i+1] = objv[i]; - } - newObjv[0] = Tcl_NewStringObj("unknown", -1); - Tcl_IncrRefCount(newObjv[0]); - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]); - if (cmdPtr == NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "invalid command name \"", Tcl_GetString(objv[0]), "\"", - (char *) NULL); - code = TCL_ERROR; - } else { - code = EvalObjv(interp, objc+1, newObjv, command, length, 0); - } - Tcl_DecrRefCount(newObjv[0]); - ckfree((char *) newObjv); - goto done; - } - - /* - * Call trace procedures if needed. - */ - - argv = NULL; - commandCopy = command; - - for (tracePtr = iPtr->tracePtr; tracePtr != NULL; tracePtr = nextPtr) { - nextPtr = tracePtr->nextPtr; - if (iPtr->numLevels > tracePtr->level) { - continue; - } - - /* - * This is a bit messy because we have to emulate the old trace - * interface, which uses strings for everything. - */ - - if (argv == NULL) { - argv = (char **) ckalloc((unsigned) (objc + 1) * sizeof(char *)); - for (i = 0; i < objc; i++) { - argv[i] = Tcl_GetString(objv[i]); - } - argv[objc] = 0; - - if (length < 0) { - length = strlen(command); - } else if ((size_t)length < strlen(command)) { - commandCopy = (char *) ckalloc((unsigned) (length + 1)); - strncpy(commandCopy, command, (size_t) length); - commandCopy[length] = 0; - } - } - (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels, - commandCopy, cmdPtr->proc, cmdPtr->clientData, - objc, argv); - } - if (argv != NULL) { - ckfree((char *) argv); - } - if (commandCopy != command) { - ckfree((char *) commandCopy); - } - - /* - * Finally, invoke the command's Tcl_ObjCmdProc. - */ - - iPtr->cmdCount++; - savedVarFramePtr = iPtr->varFramePtr; - if (flags & TCL_EVAL_GLOBAL) { - iPtr->varFramePtr = NULL; - } - code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv); - iPtr->varFramePtr = savedVarFramePtr; - if (Tcl_AsyncReady()) { - code = Tcl_AsyncInvoke(interp, code); - } - - /* - * If the interpreter has a non-empty string result, the result - * object is either empty or stale because some procedure set - * interp->result directly. If so, move the string result to the - * result object, then reset the string result. - */ - - if (*(iPtr->result) != 0) { - (void) Tcl_GetObjResult(interp); - } - - done: - iPtr->numLevels--; - return code; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_EvalObjv -- - * - * This procedure evaluates a Tcl command that has already been - * parsed into words, with one Tcl_Obj holding each word. - * - * Results: - * The return value is a standard Tcl completion code such as - * TCL_OK or TCL_ERROR. A result or error message is left in - * interp's result. - * - * Side effects: - * Depends on the command. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_EvalObjv(interp, objc, objv, flags) - Tcl_Interp *interp; /* Interpreter in which to evaluate the - * command. Also used for error - * reporting. */ - int objc; /* Number of words in command. */ - Tcl_Obj *CONST objv[]; /* An array of pointers to objects that are - * the words that make up the command. */ - int flags; /* Collection of OR-ed bits that control - * the evaluation of the script. Only - * TCL_EVAL_GLOBAL is currently - * supported. */ -{ - Interp *iPtr = (Interp *)interp; - Trace *tracePtr; - Tcl_DString cmdBuf; - char *cmdString = ""; - int cmdLen = 0; - int code = TCL_OK; - - for (tracePtr = iPtr->tracePtr; tracePtr; tracePtr = tracePtr->nextPtr) { - /* - * EvalObjv will increment numLevels so use "<" rather than "<=" - */ - if (iPtr->numLevels < tracePtr->level) { - int i; - /* - * The command will be needed for an execution trace or stack trace - * generate a command string. - */ - cmdtraced: - Tcl_DStringInit(&cmdBuf); - for (i = 0; i < objc; i++) { - Tcl_DStringAppendElement(&cmdBuf, Tcl_GetString(objv[i])); - } - cmdString = Tcl_DStringValue(&cmdBuf); - cmdLen = Tcl_DStringLength(&cmdBuf); - break; - } - } - - /* - * Execute the command if we have not done so already - */ - switch (code) { - case TCL_OK: - code = EvalObjv(interp, objc, objv, cmdString, cmdLen, flags); - if (code == TCL_ERROR && cmdLen == 0) - goto cmdtraced; - break; - case TCL_ERROR: - Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen); - break; - default: - /*NOTREACHED*/ - break; - } - - if (cmdLen != 0) { - Tcl_DStringFree(&cmdBuf); - } - return code; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_LogCommandInfo -- - * - * This procedure is invoked after an error occurs in an interpreter. - * It adds information to the "errorInfo" variable to describe the - * command that was being executed when the error occurred. - * - * Results: - * None. - * - * Side effects: - * Information about the command is added to errorInfo and the - * line number stored internally in the interpreter is set. If this - * is the first call to this procedure or Tcl_AddObjErrorInfo since - * an error occurred, then old information in errorInfo is - * deleted. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_LogCommandInfo(interp, script, command, length) - Tcl_Interp *interp; /* Interpreter in which to log information. */ - char *script; /* First character in script containing - * command (must be <= command). */ - char *command; /* First character in command that - * generated the error. */ - int length; /* Number of bytes in command (-1 means - * use all bytes up to first null byte). */ -{ - char buffer[200]; - register char *p; - char *ellipsis = ""; - Interp *iPtr = (Interp *) interp; - - if (iPtr->flags & ERR_ALREADY_LOGGED) { - /* - * Someone else has already logged error information for this - * command; we shouldn't add anything more. - */ - - return; - } - - /* - * Compute the line number where the error occurred. - */ - - iPtr->errorLine = 1; - for (p = script; p != command; p++) { - if (*p == '\n') { - iPtr->errorLine++; - } - } - - /* - * Create an error message to add to errorInfo, including up to a - * maximum number of characters of the command. - */ - - if (length < 0) { - length = strlen(command); - } - if (length > 150) { - length = 150; - ellipsis = "..."; - } - if (!(iPtr->flags & ERR_IN_PROGRESS)) { - sprintf(buffer, "\n while executing\n\"%.*s%s\"", - length, command, ellipsis); - } else { - sprintf(buffer, "\n invoked from within\n\"%.*s%s\"", - length, command, ellipsis); - } - Tcl_AddObjErrorInfo(interp, buffer, -1); - iPtr->flags &= ~ERR_ALREADY_LOGGED; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_EvalTokens -- - * - * Given an array of tokens parsed from a Tcl command (e.g., the - * tokens that make up a word or the index for an array variable) - * this procedure evaluates the tokens and concatenates their - * values to form a single result value. - * - * Results: - * The return value is a pointer to a newly allocated Tcl_Obj - * containing the value of the array of tokens. The reference - * count of the returned object has been incremented. If an error - * occurs in evaluating the tokens then a NULL value is returned - * and an error message is left in interp's result. - * - * Side effects: - * A new object is allocated to hold the result. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -Tcl_EvalTokens(interp, tokenPtr, count) - Tcl_Interp *interp; /* Interpreter in which to lookup - * variables, execute nested commands, - * and report errors. */ - Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens - * to evaluate and concatenate. */ - int count; /* Number of tokens to consider at tokenPtr. - * Must be at least 1. */ -{ - Tcl_Obj *resultPtr, *indexPtr, *valuePtr, *newPtr; - char buffer[TCL_UTF_MAX]; -#ifdef TCL_MEM_DEBUG -# define MAX_VAR_CHARS 5 -#else -# define MAX_VAR_CHARS 30 -#endif - char nameBuffer[MAX_VAR_CHARS+1]; - char *varName, *index; - char *p = NULL; /* Initialized to avoid compiler warning. */ - int length, code; - - /* - * The only tricky thing about this procedure is that it attempts to - * avoid object creation and string copying whenever possible. For - * example, if the value is just a nested command, then use the - * command's result object directly. - */ - - resultPtr = NULL; - for ( ; count > 0; count--, tokenPtr++) { - valuePtr = NULL; - - /* - * The switch statement below computes the next value to be - * concat to the result, as either a range of text or an - * object. - */ - - switch (tokenPtr->type) { - case TCL_TOKEN_TEXT: - p = tokenPtr->start; - length = tokenPtr->size; - break; - - case TCL_TOKEN_BS: - length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL, - buffer); - p = buffer; - break; - - case TCL_TOKEN_COMMAND: - code = Tcl_EvalEx(interp, tokenPtr->start+1, tokenPtr->size-2, - 0); - if (code != TCL_OK) { - goto error; - } - valuePtr = Tcl_GetObjResult(interp); - break; - - case TCL_TOKEN_VARIABLE: - if (tokenPtr->numComponents == 1) { - indexPtr = NULL; - } else { - indexPtr = Tcl_EvalTokens(interp, tokenPtr+2, - tokenPtr->numComponents - 1); - if (indexPtr == NULL) { - goto error; - } - } - - /* - * We have to make a copy of the variable name in order - * to have a null-terminated string. We can't make a - * temporary modification to the script to null-terminate - * the name, because a trace callback might potentially - * reuse the script and be affected by the null character. - */ - - if (tokenPtr[1].size <= MAX_VAR_CHARS) { - varName = nameBuffer; - } else { - varName = ckalloc((unsigned) (tokenPtr[1].size + 1)); - } - strncpy(varName, tokenPtr[1].start, (size_t) tokenPtr[1].size); - varName[tokenPtr[1].size] = 0; - if (indexPtr != NULL) { - index = TclGetString(indexPtr); - } else { - index = NULL; - } - valuePtr = Tcl_GetVar2Ex(interp, varName, index, - TCL_LEAVE_ERR_MSG); - if (varName != nameBuffer) { - ckfree(varName); - } - if (indexPtr != NULL) { - Tcl_DecrRefCount(indexPtr); - } - if (valuePtr == NULL) { - goto error; - } - count -= tokenPtr->numComponents; - tokenPtr += tokenPtr->numComponents; - break; - - default: - panic("unexpected token type in Tcl_EvalTokens"); - } - - /* - * If valuePtr isn't NULL, the next piece of text comes from that - * object; otherwise, take length bytes starting at p. - */ - - if (resultPtr == NULL) { - if (valuePtr != NULL) { - resultPtr = valuePtr; - } else { - resultPtr = Tcl_NewStringObj(p, length); - } - Tcl_IncrRefCount(resultPtr); - } else { - if (Tcl_IsShared(resultPtr)) { - newPtr = Tcl_DuplicateObj(resultPtr); - Tcl_DecrRefCount(resultPtr); - resultPtr = newPtr; - Tcl_IncrRefCount(resultPtr); - } - if (valuePtr != NULL) { - p = Tcl_GetStringFromObj(valuePtr, &length); - } - Tcl_AppendToObj(resultPtr, p, length); - } - } - return resultPtr; - - error: - if (resultPtr != NULL) { - Tcl_DecrRefCount(resultPtr); - } - return NULL; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_EvalEx -- - * - * This procedure evaluates a Tcl script without using the compiler - * or byte-code interpreter. It just parses the script, creates - * values for each word of each command, then calls EvalObjv - * to execute each command. - * - * Results: - * The return value is a standard Tcl completion code such as - * TCL_OK or TCL_ERROR. A result or error message is left in - * interp's result. - * - * Side effects: - * Depends on the script. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_EvalEx(interp, script, numBytes, flags) - Tcl_Interp *interp; /* Interpreter in which to evaluate the - * script. Also used for error reporting. */ - char *script; /* First character of script to evaluate. */ - int numBytes; /* Number of bytes in script. If < 0, the - * script consists of all bytes up to the - * first null character. */ - int flags; /* Collection of OR-ed bits that control - * the evaluation of the script. Only - * TCL_EVAL_GLOBAL is currently - * supported. */ -{ - Interp *iPtr = (Interp *) interp; - char *p, *next; - Tcl_Parse parse; -#define NUM_STATIC_OBJS 20 - Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv; - Tcl_Token *tokenPtr; - int i, code, commandLength, bytesLeft, nested; - CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr - * in case TCL_EVAL_GLOBAL was set. */ - - /* - * The variables below keep track of how much state has been - * allocated while evaluating the script, so that it can be freed - * properly if an error occurs. - */ - - int gotParse = 0, objectsUsed = 0; - - if (numBytes < 0) { - numBytes = strlen(script); - } - Tcl_ResetResult(interp); - - savedVarFramePtr = iPtr->varFramePtr; - if (flags & TCL_EVAL_GLOBAL) { - iPtr->varFramePtr = NULL; - } - - /* - * Each iteration through the following loop parses the next - * command from the script and then executes it. - */ - - objv = staticObjArray; - p = script; - bytesLeft = numBytes; - if (iPtr->evalFlags & TCL_BRACKET_TERM) { - nested = 1; - } else { - nested = 0; - } - iPtr->evalFlags = 0; - do { - if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse) - != TCL_OK) { - code = TCL_ERROR; - goto error; - } - gotParse = 1; - if (parse.numWords > 0) { - /* - * Generate an array of objects for the words of the command. - */ - - if (parse.numWords <= NUM_STATIC_OBJS) { - objv = staticObjArray; - } else { - objv = (Tcl_Obj **) ckalloc((unsigned) - (parse.numWords * sizeof (Tcl_Obj *))); - } - for (objectsUsed = 0, tokenPtr = parse.tokenPtr; - objectsUsed < parse.numWords; - objectsUsed++, tokenPtr += (tokenPtr->numComponents + 1)) { - objv[objectsUsed] = Tcl_EvalTokens(interp, tokenPtr+1, - tokenPtr->numComponents); - if (objv[objectsUsed] == NULL) { - code = TCL_ERROR; - goto error; - } - } - - /* - * Execute the command and free the objects for its words. - */ - - code = EvalObjv(interp, objectsUsed, objv, p, bytesLeft, 0); - if (code != TCL_OK) { - goto error; - } - for (i = 0; i < objectsUsed; i++) { - Tcl_DecrRefCount(objv[i]); - } - objectsUsed = 0; - if (objv != staticObjArray) { - ckfree((char *) objv); - objv = staticObjArray; - } - } - - /* - * Advance to the next command in the script. - */ - - next = parse.commandStart + parse.commandSize; - bytesLeft -= next - p; - p = next; - Tcl_FreeParse(&parse); - gotParse = 0; - if ((nested != 0) && (p > script) && (p[-1] == ']')) { - /* - * We get here in the special case where the TCL_BRACKET_TERM - * flag was set in the interpreter and we reached a close - * bracket in the script. Return immediately. - */ - - iPtr->termOffset = (p - 1) - script; - iPtr->varFramePtr = savedVarFramePtr; - return TCL_OK; - } - } while (bytesLeft > 0); - iPtr->termOffset = p - script; - iPtr->varFramePtr = savedVarFramePtr; - return TCL_OK; - - error: - /* - * Generate various pieces of error information, such as the line - * number where the error occurred and information to add to the - * errorInfo variable. Then free resources that had been allocated - * to the command. - */ - - if ((code == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { - commandLength = parse.commandSize; - if ((parse.commandStart + commandLength) != (script + numBytes)) { - /* - * The command where the error occurred didn't end at the end - * of the script (i.e. it ended at a terminator character such - * as ";". Reduce the length by one so that the error message - * doesn't include the terminator character. - */ - - commandLength -= 1; - } - Tcl_LogCommandInfo(interp, script, parse.commandStart, commandLength); - } - - for (i = 0; i < objectsUsed; i++) { - Tcl_DecrRefCount(objv[i]); - } - if (gotParse) { - p = parse.commandStart + parse.commandSize; - Tcl_FreeParse(&parse); - if ((nested != 0) && (p > script) && (p[-1] == ']')) { - /* - * We get here in the special case where the TCL_BRACKET_TERM - * flag was set in the interpreter and we reached a close - * bracket in the script. Return immediately. - */ - - iPtr->termOffset = (p - 1) - script; - } else { - iPtr->termOffset = p - script; - } - } - if (objv != staticObjArray) { - ckfree((char *) objv); - } - iPtr->varFramePtr = savedVarFramePtr; - return code; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_Eval -- - * - * Execute a Tcl command in a string. This procedure executes the - * script directly, rather than compiling it to bytecodes. Before - * the arrival of the bytecode compiler in Tcl 8.0 Tcl_Eval was - * the main procedure used for executing Tcl commands, but nowadays - * it isn't used much. - * - * Results: - * The return value is one of the return codes defined in tcl.h - * (such as TCL_OK), and interp's result contains a value - * to supplement the return code. The value of the result - * will persist only until the next call to Tcl_Eval or Tcl_EvalObj: - * you must copy it or lose it! - * - * Side effects: - * Can be almost arbitrary, depending on the commands in the script. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_Eval(interp, string) - Tcl_Interp *interp; /* Token for command interpreter (returned - * by previous call to Tcl_CreateInterp). */ - char *string; /* Pointer to TCL command to execute. */ -{ - int code; - - code = Tcl_EvalEx(interp, string, -1, 0); - - /* - * For backwards compatibility with old C code that predates the - * object system in Tcl 8.0, we have to mirror the object result - * back into the string result (some callers may expect it there). - */ - - Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), - TCL_VOLATILE); - return code; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_EvalObj, Tcl_GlobalEvalObj -- - * - * These functions are deprecated but we keep them around for backwards - * compatibility reasons. - * - * Results: - * See the functions they call. - * - * Side effects: - * See the functions they call. - * - *---------------------------------------------------------------------- - */ - -#undef Tcl_EvalObj -int -Tcl_EvalObj(interp, objPtr) - Tcl_Interp * interp; - Tcl_Obj * objPtr; -{ - return Tcl_EvalObjEx(interp, objPtr, 0); -} - -#undef Tcl_GlobalEvalObj -int -Tcl_GlobalEvalObj(interp, objPtr) - Tcl_Interp * interp; - Tcl_Obj * objPtr; -{ - return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL); -} - /* *---------------------------------------------------------------------- * * Tcl_ParseVarName -- * * Given a string starting with a $ sign, parse off a variable - * name and return information about the parse. + * name and return information about the parse. No more than + * numBytes bytes will be scanned. * * Results: * The return value is TCL_OK if the command was parsed @@ -1590,9 +1048,9 @@ Tcl_ParseVarName(interp, string, numBytes, parsePtr, append) Tcl_Interp *interp; /* Interpreter to use for error reporting; * if NULL, then no error message is * provided. */ - char *string; /* String containing variable name. First + CONST char *string; /* String containing variable name. First * character must be "$". */ - int numBytes; /* Total number of bytes in string. If < 0, + register int numBytes; /* Total number of bytes in string. If < 0, * the string consists of all bytes up to the * first null character. */ Tcl_Parse *parsePtr; /* Structure to fill in with information @@ -1603,16 +1061,17 @@ Tcl_ParseVarName(interp, string, numBytes, parsePtr, append) * it. */ { Tcl_Token *tokenPtr; - char *end, *src; + register CONST char *src; unsigned char c; int varIndex, offset; Tcl_UniChar ch; unsigned array; - if (numBytes >= 0) { - end = string + numBytes; - } else { - end = string + strlen(string); + if ((numBytes == 0) || (string == NULL)) { + return TCL_ERROR; + } + if (numBytes < 0) { + numBytes = strlen(string); } if (!append) { @@ -1621,7 +1080,7 @@ Tcl_ParseVarName(interp, string, numBytes, parsePtr, append) parsePtr->numTokens = 0; parsePtr->tokensAvailable = NUM_STATIC_TOKENS; parsePtr->string = string; - parsePtr->end = end; + parsePtr->end = (string + numBytes); parsePtr->interp = interp; parsePtr->errorType = TCL_PARSE_SUCCESS; parsePtr->incomplete = 0; @@ -1643,8 +1102,8 @@ Tcl_ParseVarName(interp, string, numBytes, parsePtr, append) varIndex = parsePtr->numTokens; parsePtr->numTokens++; tokenPtr++; - src++; - if (src >= end) { + src++; numBytes--; + if (numBytes == 0) { goto justADollarSign; } tokenPtr->type = TCL_TOKEN_TEXT; @@ -1669,26 +1128,23 @@ Tcl_ParseVarName(interp, string, numBytes, parsePtr, append) */ if (*src == '{') { - src++; + src++; numBytes--; tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->start = src; tokenPtr->numComponents = 0; - while (1) { - if (src == end) { - if (interp != NULL) { - Tcl_SetResult(interp, - "missing close-brace for variable name", + + while (numBytes && (*src != '}')) { + numBytes--; src++; + } + if (numBytes == 0) { + if (interp != NULL) { + Tcl_SetResult(interp, "missing close-brace for variable name", TCL_STATIC); - } - parsePtr->errorType = TCL_PARSE_MISSING_VAR_BRACE; - parsePtr->term = tokenPtr->start-1; - parsePtr->incomplete = 1; - goto error; } - if (*src == '}') { - break; - } - src++; + parsePtr->errorType = TCL_PARSE_MISSING_VAR_BRACE; + parsePtr->term = tokenPtr->start-1; + parsePtr->incomplete = 1; + goto error; } tokenPtr->size = src - tokenPtr->start; tokenPtr[-1].size = src - tokenPtr[-1].start; @@ -1698,17 +1154,24 @@ Tcl_ParseVarName(interp, string, numBytes, parsePtr, append) tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->start = src; tokenPtr->numComponents = 0; - while (src != end) { - offset = Tcl_UtfToUniChar(src, &ch); + while (numBytes) { + if (Tcl_UtfCharComplete(src, numBytes)) { + offset = Tcl_UtfToUniChar(src, &ch); + } else { + char utfBytes[TCL_UTF_MAX]; + memcpy(utfBytes, src, (size_t) numBytes); + utfBytes[numBytes] = '\0'; + offset = Tcl_UtfToUniChar(utfBytes, &ch); + } c = UCHAR(ch); if (isalnum(c) || (c == '_')) { /* INTL: ISO only, UCHAR. */ - src += offset; + src += offset; numBytes -= offset; continue; } - if ((c == ':') && (((src+1) != end) && (src[1] == ':'))) { - src += 2; - while ((src != end) && (*src == ':')) { - src += 1; + if ((c == ':') && (numBytes != 1) && (src[1] == ':')) { + src += 2; numBytes -= 2; + while (numBytes && (*src == ':')) { + src++; numBytes--; } continue; } @@ -1718,9 +1181,9 @@ Tcl_ParseVarName(interp, string, numBytes, parsePtr, append) /* * Support for empty array names here. */ - array = ((src != end) && (*src == '(')); + array = (numBytes && (*src == '(')); tokenPtr->size = src - tokenPtr->start; - if (tokenPtr->size == 0 && !array) { + if ((tokenPtr->size == 0) && !array) { goto justADollarSign; } parsePtr->numTokens++; @@ -1731,11 +1194,12 @@ Tcl_ParseVarName(interp, string, numBytes, parsePtr, append) * since it could contain any number of substitutions. */ - if (ParseTokens(src+1, TYPE_CLOSE_PAREN, parsePtr) + if (ParseTokens(src+1, numBytes-1, TYPE_CLOSE_PAREN, parsePtr) != TCL_OK) { goto error; } - if ((parsePtr->term == end) || (*parsePtr->term != ')')) { + if ((parsePtr->term == (src + numBytes)) + || (*parsePtr->term != ')')) { if (parsePtr->interp != NULL) { Tcl_SetResult(parsePtr->interp, "missing )", TCL_STATIC); @@ -1770,7 +1234,7 @@ Tcl_ParseVarName(interp, string, numBytes, parsePtr, append) Tcl_FreeParse(parsePtr); return TCL_ERROR; } - + /* *---------------------------------------------------------------------- * @@ -1793,18 +1257,19 @@ Tcl_ParseVarName(interp, string, numBytes, parsePtr, append) *---------------------------------------------------------------------- */ -char * +CONST char * Tcl_ParseVar(interp, string, termPtr) Tcl_Interp *interp; /* Context for looking up variable. */ - register char *string; /* String containing variable name. + register CONST char *string; /* String containing variable name. * First character must be "$". */ - char **termPtr; /* If non-NULL, points to word to fill + CONST char **termPtr; /* If non-NULL, points to word to fill * in with character just after last * one in the variable specifier. */ { Tcl_Parse parse; register Tcl_Obj *objPtr; + int code; if (Tcl_ParseVarName(interp, string, -1, &parse, 0) != TCL_OK) { return NULL; @@ -1821,25 +1286,30 @@ Tcl_ParseVar(interp, string, termPtr) return "$"; } - objPtr = Tcl_EvalTokens(interp, parse.tokenPtr, parse.numTokens); - if (objPtr == NULL) { + code = Tcl_EvalTokensStandard(interp, parse.tokenPtr, parse.numTokens); + if (code != TCL_OK) { return NULL; } + objPtr = Tcl_GetObjResult(interp); /* * At this point we should have an object containing the value of * a variable. Just return the string from that object. + * + * This should have returned the object for the user to manage, but + * instead we have some weak reference to the string value in the + * object, which is why we make sure the object exists after resetting + * the result. This isn't ideal, but it's the best we can do with the + * current documented interface. -- hobbs */ -#ifdef TCL_COMPILE_DEBUG - if (objPtr->refCount < 2) { - panic("Tcl_ParseVar got temporary object from Tcl_EvalTokens"); + if (!Tcl_IsShared(objPtr)) { + Tcl_IncrRefCount(objPtr); } -#endif /*TCL_COMPILE_DEBUG*/ - TclDecrRefCount(objPtr); + Tcl_ResetResult(interp); return TclGetString(objPtr); } - + /* *---------------------------------------------------------------------- * @@ -1847,7 +1317,8 @@ Tcl_ParseVar(interp, string, termPtr) * * Given a string in braces such as a Tcl command argument or a string * value in a Tcl expression, this procedure parses the string and - * returns information about the parse. + * returns information about the parse. No more than numBytes bytes + * will be scanned. * * Results: * The return value is TCL_OK if the string was parsed successfully and @@ -1873,9 +1344,9 @@ Tcl_ParseBraces(interp, string, numBytes, parsePtr, append, termPtr) Tcl_Interp *interp; /* Interpreter to use for error reporting; * if NULL, then no error message is * provided. */ - char *string; /* String containing the string in braces. + CONST char *string; /* String containing the string in braces. * The first character must be '{'. */ - int numBytes; /* Total number of bytes in string. If < 0, + register int numBytes; /* Total number of bytes in string. If < 0, * the string consists of all bytes up to * the first null character. */ register Tcl_Parse *parsePtr; @@ -1885,35 +1356,35 @@ Tcl_ParseBraces(interp, string, numBytes, parsePtr, append, termPtr) * information in parsePtr; zero means * ignore existing tokens in parsePtr and * reinitialize it. */ - char **termPtr; /* If non-NULL, points to word in which to + CONST char **termPtr; /* If non-NULL, points to word in which to * store a pointer to the character just * after the terminating '}' if the parse * was successful. */ { - char utfBytes[TCL_UTF_MAX]; /* For result of backslash substitution. */ Tcl_Token *tokenPtr; - register char *src, *end; + register CONST char *src; int startIndex, level, length; - if ((numBytes >= 0) || (string == NULL)) { - end = string + numBytes; - } else { - end = string + strlen(string); + if ((numBytes == 0) || (string == NULL)) { + return TCL_ERROR; } - + if (numBytes < 0) { + numBytes = strlen(string); + } + if (!append) { parsePtr->numWords = 0; parsePtr->tokenPtr = parsePtr->staticTokens; parsePtr->numTokens = 0; parsePtr->tokensAvailable = NUM_STATIC_TOKENS; parsePtr->string = string; - parsePtr->end = end; + parsePtr->end = (string + numBytes); parsePtr->interp = interp; parsePtr->errorType = TCL_PARSE_SUCCESS; } - src = string+1; + src = string; startIndex = parsePtr->numTokens; if (parsePtr->numTokens == parsePtr->tokensAvailable) { @@ -1921,130 +1392,135 @@ Tcl_ParseBraces(interp, string, numBytes, parsePtr, append, termPtr) } tokenPtr = &parsePtr->tokenPtr[startIndex]; tokenPtr->type = TCL_TOKEN_TEXT; - tokenPtr->start = src; + tokenPtr->start = src+1; tokenPtr->numComponents = 0; level = 1; while (1) { - while (CHAR_TYPE(*src) == TYPE_NORMAL) { - src++; - } - if (*src == '}') { - level--; - if (level == 0) { + while (++src, --numBytes) { + if (CHAR_TYPE(*src) != TYPE_NORMAL) { break; } - src++; - } else if (*src == '{') { - level++; - src++; - } else if (*src == '\\') { - Tcl_UtfBackslash(src, &length, utfBytes); - if (src[1] == '\n') { + } + if (numBytes == 0) { + register int openBrace = 0; + + parsePtr->errorType = TCL_PARSE_MISSING_BRACE; + parsePtr->term = string; + parsePtr->incomplete = 1; + if (interp == NULL) { /* - * A backslash-newline sequence must be collapsed, even - * inside braces, so we have to split the word into - * multiple tokens so that the backslash-newline can be - * represented explicitly. + * Skip straight to the exit code since we have no + * interpreter to put error message in. */ - - if ((src + 2) == end) { - parsePtr->incomplete = 1; - } - tokenPtr->size = (src - tokenPtr->start); - if (tokenPtr->size != 0) { - parsePtr->numTokens++; - } - if ((parsePtr->numTokens+1) >= parsePtr->tokensAvailable) { - TclExpandTokenArray(parsePtr); - } - tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens]; - tokenPtr->type = TCL_TOKEN_BS; - tokenPtr->start = src; - tokenPtr->size = length; - tokenPtr->numComponents = 0; - parsePtr->numTokens++; - - src += length; - tokenPtr++; - tokenPtr->type = TCL_TOKEN_TEXT; - tokenPtr->start = src; - tokenPtr->numComponents = 0; - } else { - src += length; + goto error; } - } else if (src == end) { - int openBrace; - if (interp != NULL) { - Tcl_SetResult(interp, "missing close-brace", TCL_STATIC); - } + Tcl_SetResult(interp, "missing close-brace", TCL_STATIC); + /* - * Search the source string for a possible open - * brace within the context of a comment. Since we - * aren't performing a full Tcl parse, just look for - * an open brace preceeded by a '<whitspace>#' on - * the same line. + * Guess if the problem is due to comments by searching + * the source string for a possible open brace within the + * context of a comment. Since we aren't performing a + * full Tcl parse, just look for an open brace preceded + * by a '<whitespace>#' on the same line. */ - openBrace = 0; - while (src > string ) { + + for (; src > string; src--) { switch (*src) { - case '{': - openBrace = 1; + case '{': + openBrace = 1; break; case '\n': - openBrace = 0; + openBrace = 0; break; - case '#': - if ((openBrace == 1) && (isspace(UCHAR(src[-1])))) { - if (interp != NULL) { - Tcl_AppendResult(interp, - ": possible unbalanced brace in comment", - (char *) NULL); - } - openBrace = -1; - break; + case '#' : + if (openBrace && (isspace(UCHAR(src[-1])))) { + Tcl_AppendResult(interp, + ": possible unbalanced brace in comment", + (char *) NULL); + goto error; } break; } - if (openBrace == -1) { - break; - } - src--; } - parsePtr->errorType = TCL_PARSE_MISSING_BRACE; - parsePtr->term = string; - parsePtr->incomplete = 1; - goto error; - } else { - src++; - } - } - /* - * Decide if we need to finish emitting a partially-finished token. - * There are 3 cases: - * {abc \newline xyz} or {xyz} - finish emitting "xyz" token - * {abc \newline} - don't emit token after \newline - * {} - finish emitting zero-sized token - * The last case ensures that there is a token (even if empty) that - * describes the braced string. - */ + error: + Tcl_FreeParse(parsePtr); + return TCL_ERROR; + } + switch (*src) { + case '{': + level++; + break; + case '}': + if (--level == 0) { + + /* + * Decide if we need to finish emitting a + * partially-finished token. There are 3 cases: + * {abc \newline xyz} or {xyz} + * - finish emitting "xyz" token + * {abc \newline} + * - don't emit token after \newline + * {} - finish emitting zero-sized token + * + * The last case ensures that there is a token + * (even if empty) that describes the braced string. + */ - if ((src != tokenPtr->start) - || (parsePtr->numTokens == startIndex)) { - tokenPtr->size = (src - tokenPtr->start); - parsePtr->numTokens++; - } - if (termPtr != NULL) { - *termPtr = src+1; + if ((src != tokenPtr->start) + || (parsePtr->numTokens == startIndex)) { + tokenPtr->size = (src - tokenPtr->start); + parsePtr->numTokens++; + } + if (termPtr != NULL) { + *termPtr = src+1; + } + return TCL_OK; + } + break; + case '\\': + TclParseBackslash(src, numBytes, &length, NULL); + if ((length > 1) && (src[1] == '\n')) { + /* + * A backslash-newline sequence must be collapsed, even + * inside braces, so we have to split the word into + * multiple tokens so that the backslash-newline can be + * represented explicitly. + */ + + if (numBytes == 2) { + parsePtr->incomplete = 1; + } + tokenPtr->size = (src - tokenPtr->start); + if (tokenPtr->size != 0) { + parsePtr->numTokens++; + } + if ((parsePtr->numTokens+1) >= parsePtr->tokensAvailable) { + TclExpandTokenArray(parsePtr); + } + tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens]; + tokenPtr->type = TCL_TOKEN_BS; + tokenPtr->start = src; + tokenPtr->size = length; + tokenPtr->numComponents = 0; + parsePtr->numTokens++; + + src += length - 1; + numBytes -= length - 1; + tokenPtr++; + tokenPtr->type = TCL_TOKEN_TEXT; + tokenPtr->start = src + 1; + tokenPtr->numComponents = 0; + } else { + src += length - 1; + numBytes -= length - 1; + } + break; + } } - return TCL_OK; - - error: - Tcl_FreeParse(parsePtr); - return TCL_ERROR; } - + /* *---------------------------------------------------------------------- * @@ -2052,7 +1528,8 @@ Tcl_ParseBraces(interp, string, numBytes, parsePtr, append, termPtr) * * Given a double-quoted string such as a quoted Tcl command argument * or a quoted value in a Tcl expression, this procedure parses the - * string and returns information about the parse. + * string and returns information about the parse. No more than + * numBytes bytes will be scanned. * * Results: * The return value is TCL_OK if the string was parsed successfully and @@ -2078,9 +1555,9 @@ Tcl_ParseQuotedString(interp, string, numBytes, parsePtr, append, termPtr) Tcl_Interp *interp; /* Interpreter to use for error reporting; * if NULL, then no error message is * provided. */ - char *string; /* String containing the quoted string. + CONST char *string; /* String containing the quoted string. * The first character must be '"'. */ - int numBytes; /* Total number of bytes in string. If < 0, + register int numBytes; /* Total number of bytes in string. If < 0, * the string consists of all bytes up to * the first null character. */ register Tcl_Parse *parsePtr; @@ -2090,31 +1567,30 @@ Tcl_ParseQuotedString(interp, string, numBytes, parsePtr, append, termPtr) * information in parsePtr; zero means * ignore existing tokens in parsePtr and * reinitialize it. */ - char **termPtr; /* If non-NULL, points to word in which to + CONST char **termPtr; /* If non-NULL, points to word in which to * store a pointer to the character just * after the quoted string's terminating * close-quote if the parse succeeds. */ { - char *end; - - if ((numBytes >= 0) || (string == NULL)) { - end = string + numBytes; - } else { - end = string + strlen(string); + if ((numBytes == 0) || (string == NULL)) { + return TCL_ERROR; } - + if (numBytes < 0) { + numBytes = strlen(string); + } + if (!append) { parsePtr->numWords = 0; parsePtr->tokenPtr = parsePtr->staticTokens; parsePtr->numTokens = 0; parsePtr->tokensAvailable = NUM_STATIC_TOKENS; parsePtr->string = string; - parsePtr->end = end; + parsePtr->end = (string + numBytes); parsePtr->interp = interp; parsePtr->errorType = TCL_PARSE_SUCCESS; } - if (ParseTokens(string+1, TYPE_QUOTE, parsePtr) != TCL_OK) { + if (ParseTokens(string+1, numBytes-1, TYPE_QUOTE, parsePtr) != TCL_OK) { goto error; } if (*parsePtr->term != '"') { @@ -2135,7 +1611,7 @@ Tcl_ParseQuotedString(interp, string, numBytes, parsePtr, append, termPtr) Tcl_FreeParse(parsePtr); return TCL_ERROR; } - + /* *---------------------------------------------------------------------- * @@ -2157,16 +1633,16 @@ Tcl_ParseQuotedString(interp, string, numBytes, parsePtr, append, termPtr) */ static int -CommandComplete(script, length) - char *script; /* Script to check. */ - int length; /* Number of bytes in script. */ +CommandComplete(script, numBytes) + CONST char *script; /* Script to check. */ + int numBytes; /* Number of bytes in script. */ { Tcl_Parse parse; - char *p, *end; + CONST char *p, *end; int result; p = script; - end = p + length; + end = p + numBytes; while (Tcl_ParseCommand((Tcl_Interp *) NULL, p, end - p, 0, &parse) == TCL_OK) { p = parse.commandStart + parse.commandSize; @@ -2183,7 +1659,7 @@ CommandComplete(script, length) Tcl_FreeParse(&parse); return result; } - + /* *---------------------------------------------------------------------- * @@ -2206,11 +1682,11 @@ CommandComplete(script, length) int Tcl_CommandComplete(script) - char *script; /* Script to check. */ + CONST char *script; /* Script to check. */ { return CommandComplete(script, (int) strlen(script)); } - + /* *---------------------------------------------------------------------- * @@ -2234,13 +1710,13 @@ TclObjCommandComplete(objPtr) Tcl_Obj *objPtr; /* Points to object holding script * to check. */ { - char *script; + CONST char *script; int length; script = Tcl_GetStringFromObj(objPtr, &length); return CommandComplete(script, length); } - + /* *---------------------------------------------------------------------- * diff --git a/tcl/generic/tclParseExpr.c b/tcl/generic/tclParseExpr.c index 00612db7efa..cde02d2898b 100644 --- a/tcl/generic/tclParseExpr.c +++ b/tcl/generic/tclParseExpr.c @@ -7,6 +7,8 @@ * code analysis, etc. * * Copyright (c) 1997 Sun Microsystems, Inc. + * Copyright (c) 1998-2000 by Scriptics Corporation. + * Contributions from Don Porter, NIST, 2002. (not subject to US copyright) * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -15,7 +17,6 @@ */ #include "tclInt.h" -#include "tclCompile.h" /* * The stuff below is a bit of a hack so that this file can be used in @@ -55,22 +56,24 @@ typedef struct ParseInfo { int lexeme; /* Type of last lexeme scanned in expr. * See below for definitions. Corresponds to * size characters beginning at start. */ - char *start; /* First character in lexeme. */ + CONST char *start; /* First character in lexeme. */ int size; /* Number of bytes in lexeme. */ - char *next; /* Position of the next character to be + CONST char *next; /* Position of the next character to be * scanned in the expression string. */ - char *prevEnd; /* Points to the character just after the + CONST char *prevEnd; /* Points to the character just after the * last one in the previous lexeme. Used to * compute size of subexpression tokens. */ - char *originalExpr; /* Points to the start of the expression + CONST char *originalExpr; /* Points to the start of the expression * originally passed to Tcl_ParseExpr. */ - char *lastChar; /* Points just after last byte of expr. */ + CONST char *lastChar; /* Points just after last byte of expr. */ } ParseInfo; /* * Definitions of the different lexemes that appear in expressions. The * order of these must match the corresponding entries in the * operatorStrings array below. + * + * Basic lexemes: */ #define LITERAL 0 @@ -84,62 +87,69 @@ typedef struct ParseInfo { #define COMMA 8 #define END 9 #define UNKNOWN 10 +#define UNKNOWN_CHAR 11 /* - * Binary operators: + * Binary numeric operators: */ -#define MULT 11 -#define DIVIDE 12 -#define MOD 13 -#define PLUS 14 -#define MINUS 15 -#define LEFT_SHIFT 16 -#define RIGHT_SHIFT 17 -#define LESS 18 -#define GREATER 19 -#define LEQ 20 -#define GEQ 21 -#define EQUAL 22 -#define NEQ 23 -#define BIT_AND 24 -#define BIT_XOR 25 -#define BIT_OR 26 -#define AND 27 -#define OR 28 -#define QUESTY 29 -#define COLON 30 +#define MULT 12 +#define DIVIDE 13 +#define MOD 14 +#define PLUS 15 +#define MINUS 16 +#define LEFT_SHIFT 17 +#define RIGHT_SHIFT 18 +#define LESS 19 +#define GREATER 20 +#define LEQ 21 +#define GEQ 22 +#define EQUAL 23 +#define NEQ 24 +#define BIT_AND 25 +#define BIT_XOR 26 +#define BIT_OR 27 +#define AND 28 +#define OR 29 +#define QUESTY 30 +#define COLON 31 /* * Unary operators. Unary minus and plus are represented by the (binary) * lexemes MINUS and PLUS. */ -#define NOT 31 -#define BIT_NOT 32 +#define NOT 32 +#define BIT_NOT 33 + +/* + * Binary string operators: + */ + +#define STREQ 34 +#define STRNEQ 35 /* * Mapping from lexemes to strings; used for debugging messages. These * entries must match the order and number of the lexeme definitions above. */ -#ifdef TCL_COMPILE_DEBUG static char *lexemeStrings[] = { "LITERAL", "FUNCNAME", - "[", "{", "(", ")", "$", "\"", ",", "END", "UNKNOWN", + "[", "{", "(", ")", "$", "\"", ",", "END", "UNKNOWN", "UNKNOWN_CHAR", "*", "/", "%", "+", "-", "<<", ">>", "<", ">", "<=", ">=", "==", "!=", "&", "^", "|", "&&", "||", "?", ":", - "!", "~" + "!", "~", "eq", "ne", }; -#endif /* TCL_COMPILE_DEBUG */ /* * Declarations for local procedures to this file: */ static int GetLexeme _ANSI_ARGS_((ParseInfo *infoPtr)); -static void LogSyntaxError _ANSI_ARGS_((ParseInfo *infoPtr)); +static void LogSyntaxError _ANSI_ARGS_((ParseInfo *infoPtr, + CONST char *extraInfo)); static int ParseAddExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParseBitAndExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParseBitOrExpr _ANSI_ARGS_((ParseInfo *infoPtr)); @@ -148,14 +158,16 @@ static int ParseCondExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParseEqualityExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParseLandExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParseLorExpr _ANSI_ARGS_((ParseInfo *infoPtr)); +static int ParseMaxDoubleLength _ANSI_ARGS_((CONST char *string, + CONST char *end)); static int ParseMultiplyExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParsePrimaryExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParseRelationalExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParseShiftExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParseUnaryExpr _ANSI_ARGS_((ParseInfo *infoPtr)); -static void PrependSubExprTokens _ANSI_ARGS_((char *op, - int opBytes, char *src, int srcBytes, - int firstIndex, ParseInfo *infoPtr)); +static void PrependSubExprTokens _ANSI_ARGS_((CONST char *op, + int opBytes, CONST char *src, int srcBytes, + int firstIndex, ParseInfo *infoPtr)); /* * Macro used to debug the execution of the recursive descent parser used @@ -181,7 +193,8 @@ static void PrependSubExprTokens _ANSI_ARGS_((char *op, * Given a string, this procedure parses the first Tcl expression * in the string and returns information about the structure of * the expression. This procedure is the top-level interface to the - * the expression parsing module. + * the expression parsing module. No more that numBytes bytes will + * be scanned. * * Results: * The return value is TCL_OK if the command was parsed successfully @@ -203,7 +216,7 @@ static void PrependSubExprTokens _ANSI_ARGS_((char *op, int Tcl_ParseExpr(interp, string, numBytes, parsePtr) Tcl_Interp *interp; /* Used for error reporting. */ - char *string; /* The source string to parse. */ + CONST char *string; /* The source string to parse. */ int numBytes; /* Number of bytes in string. If < 0, the * string consists of all bytes up to the * first null character. */ @@ -214,7 +227,6 @@ Tcl_ParseExpr(interp, string, numBytes, parsePtr) { ParseInfo info; int code; - char savedChar; if (numBytes < 0) { numBytes = (string? strlen(string) : 0); @@ -241,17 +253,6 @@ Tcl_ParseExpr(interp, string, numBytes, parsePtr) parsePtr->incomplete = 0; /* - * Temporarily overwrite the character just after the end of the - * string with a 0 byte. This acts as a sentinel and reduces the - * number of places where we have to check for the end of the - * input string. The original value of the byte is restored at - * the end of the parse. - */ - - savedChar = string[numBytes]; - string[numBytes] = 0; - - /* * Initialize the ParseInfo structure that holds state while parsing * the expression. */ @@ -278,14 +279,12 @@ Tcl_ParseExpr(interp, string, numBytes, parsePtr) goto error; } if (info.lexeme != END) { - LogSyntaxError(&info); + LogSyntaxError(&info, "extra tokens at end of expression"); goto error; } - string[numBytes] = (char) savedChar; return TCL_OK; error: - string[numBytes] = (char) savedChar; if (parsePtr->tokenPtr != parsePtr->staticTokens) { ckfree((char *) parsePtr->tokenPtr); } @@ -301,7 +300,7 @@ Tcl_ParseExpr(interp, string, numBytes, parsePtr) * condExpr ::= lorExpr ['?' condExpr ':' condExpr] * * Note that this is the topmost recursive-descent parsing routine used - * by TclParseExpr to parse expressions. This avoids an extra procedure + * by Tcl_ParseExpr to parse expressions. This avoids an extra procedure * call since such a procedure would only return the result of calling * ParseCondExpr. Other recursive-descent procedures that need to parse * complete expressions also call ParseCondExpr. @@ -327,7 +326,7 @@ ParseCondExpr(infoPtr) Tcl_Parse *parsePtr = infoPtr->parsePtr; Tcl_Token *tokenPtr, *firstTokenPtr, *condTokenPtr; int firstIndex, numToMove, code; - char *srcStart; + CONST char *srcStart; HERE("condExpr", 1); srcStart = infoPtr->start; @@ -384,7 +383,7 @@ ParseCondExpr(infoPtr) return code; } if (infoPtr->lexeme != COLON) { - LogSyntaxError(infoPtr); + LogSyntaxError(infoPtr, "missing colon from ternary conditional"); return TCL_ERROR; } code = GetLexeme(infoPtr); /* skip over the ':' */ @@ -440,7 +439,7 @@ ParseLorExpr(infoPtr) { Tcl_Parse *parsePtr = infoPtr->parsePtr; int firstIndex, code; - char *srcStart, *operator; + CONST char *srcStart, *operator; HERE("lorExpr", 2); srcStart = infoPtr->start; @@ -500,7 +499,7 @@ ParseLandExpr(infoPtr) { Tcl_Parse *parsePtr = infoPtr->parsePtr; int firstIndex, code; - char *srcStart, *operator; + CONST char *srcStart, *operator; HERE("landExpr", 3); srcStart = infoPtr->start; @@ -560,7 +559,7 @@ ParseBitOrExpr(infoPtr) { Tcl_Parse *parsePtr = infoPtr->parsePtr; int firstIndex, code; - char *srcStart, *operator; + CONST char *srcStart, *operator; HERE("bitOrExpr", 4); srcStart = infoPtr->start; @@ -621,7 +620,7 @@ ParseBitXorExpr(infoPtr) { Tcl_Parse *parsePtr = infoPtr->parsePtr; int firstIndex, code; - char *srcStart, *operator; + CONST char *srcStart, *operator; HERE("bitXorExpr", 5); srcStart = infoPtr->start; @@ -682,7 +681,7 @@ ParseBitAndExpr(infoPtr) { Tcl_Parse *parsePtr = infoPtr->parsePtr; int firstIndex, code; - char *srcStart, *operator; + CONST char *srcStart, *operator; HERE("bitAndExpr", 6); srcStart = infoPtr->start; @@ -720,7 +719,8 @@ ParseBitAndExpr(infoPtr) * ParseEqualityExpr -- * * This procedure parses a Tcl equality (inequality) expression: - * equalityExpr ::= relationalExpr {('==' | '!=') relationalExpr} + * equalityExpr ::= relationalExpr + * {('==' | '!=' | 'ne' | 'eq') relationalExpr} * * Results: * The return value is TCL_OK on a successful parse and TCL_ERROR @@ -742,7 +742,7 @@ ParseEqualityExpr(infoPtr) { Tcl_Parse *parsePtr = infoPtr->parsePtr; int firstIndex, lexeme, code; - char *srcStart, *operator; + CONST char *srcStart, *operator; HERE("equalityExpr", 7); srcStart = infoPtr->start; @@ -754,9 +754,10 @@ ParseEqualityExpr(infoPtr) } lexeme = infoPtr->lexeme; - while ((lexeme == EQUAL) || (lexeme == NEQ)) { + while ((lexeme == EQUAL) || (lexeme == NEQ) + || (lexeme == STREQ) || (lexeme == STRNEQ)) { operator = infoPtr->start; - code = GetLexeme(infoPtr); /* skip over == or != */ + code = GetLexeme(infoPtr); /* skip over ==, !=, 'eq' or 'ne' */ if (code != TCL_OK) { return code; } @@ -766,7 +767,8 @@ ParseEqualityExpr(infoPtr) } /* - * Generate tokens for the subexpression and '==' or '!=' operator. + * Generate tokens for the subexpression and '==', '!=', 'eq' or 'ne' + * operator. */ PrependSubExprTokens(operator, 2, srcStart, @@ -804,7 +806,7 @@ ParseRelationalExpr(infoPtr) { Tcl_Parse *parsePtr = infoPtr->parsePtr; int firstIndex, lexeme, operatorSize, code; - char *srcStart, *operator; + CONST char *srcStart, *operator; HERE("relationalExpr", 8); srcStart = infoPtr->start; @@ -872,7 +874,7 @@ ParseShiftExpr(infoPtr) { Tcl_Parse *parsePtr = infoPtr->parsePtr; int firstIndex, lexeme, code; - char *srcStart, *operator; + CONST char *srcStart, *operator; HERE("shiftExpr", 9); srcStart = infoPtr->start; @@ -934,7 +936,7 @@ ParseAddExpr(infoPtr) { Tcl_Parse *parsePtr = infoPtr->parsePtr; int firstIndex, lexeme, code; - char *srcStart, *operator; + CONST char *srcStart, *operator; HERE("addExpr", 10); srcStart = infoPtr->start; @@ -996,7 +998,7 @@ ParseMultiplyExpr(infoPtr) { Tcl_Parse *parsePtr = infoPtr->parsePtr; int firstIndex, lexeme, code; - char *srcStart, *operator; + CONST char *srcStart, *operator; HERE("multiplyExpr", 11); srcStart = infoPtr->start; @@ -1058,7 +1060,7 @@ ParseUnaryExpr(infoPtr) { Tcl_Parse *parsePtr = infoPtr->parsePtr; int firstIndex, lexeme, code; - char *srcStart, *operator; + CONST char *srcStart, *operator; HERE("unaryExpr", 12); srcStart = infoPtr->start; @@ -1123,7 +1125,7 @@ ParsePrimaryExpr(infoPtr) Tcl_Interp *interp = parsePtr->interp; Tcl_Token *tokenPtr, *exprTokenPtr; Tcl_Parse nested; - char *dollarPtr, *stringStart, *termPtr, *src; + CONST char *dollarPtr, *stringStart, *termPtr, *src; int lexeme, exprIndex, firstIndex, numToMove, code; /* @@ -1142,7 +1144,8 @@ ParsePrimaryExpr(infoPtr) return code; } if (infoPtr->lexeme != CLOSE_PAREN) { - goto syntaxError; + LogSyntaxError(infoPtr, "looking for close parenthesis"); + return TCL_ERROR; } code = GetLexeme(infoPtr); /* skip over the ')' */ if (code != TCL_OK) { @@ -1192,7 +1195,7 @@ ParsePrimaryExpr(infoPtr) exprTokenPtr->size = infoPtr->size; exprTokenPtr->numComponents = 1; break; - + case DOLLAR: /* * $var variable reference. @@ -1372,7 +1375,43 @@ ParsePrimaryExpr(infoPtr) return code; } if (infoPtr->lexeme != OPEN_PAREN) { - goto syntaxError; + /* + * Guess what kind of error we have by trying to tell + * whether we have a function or variable name here. + * Alas, this makes the parser more tightly bound with the + * rest of the interpreter, but that is the only way to + * give a sensible message here. Still, it is not too + * serious as this is only done when generating an error. + */ + Interp *iPtr = (Interp *) infoPtr->parsePtr->interp; + Tcl_DString functionName; + Tcl_HashEntry *hPtr; + + /* + * Look up the name as a function name. We need a writable + * copy (DString) so we can terminate it with a NULL for + * the benefit of Tcl_FindHashEntry which operates on + * NULL-terminated string keys. + */ + Tcl_DStringInit(&functionName); + hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, + Tcl_DStringAppend(&functionName, tokenPtr->start, + tokenPtr->size)); + Tcl_DStringFree(&functionName); + + /* + * Assume that we have an attempted variable reference + * unless we've got a function name, as the set of + * potential function names is typically much smaller. + */ + if (hPtr != NULL) { + LogSyntaxError(infoPtr, + "expected parenthesis enclosing function arguments"); + } else { + LogSyntaxError(infoPtr, + "variable references require preceding $"); + } + return TCL_ERROR; } code = GetLexeme(infoPtr); /* skip over '(' */ if (code != TCL_OK) { @@ -1391,7 +1430,9 @@ ParsePrimaryExpr(infoPtr) return code; } } else if (infoPtr->lexeme != CLOSE_PAREN) { - goto syntaxError; + LogSyntaxError(infoPtr, + "missing close parenthesis at end of function call"); + return TCL_ERROR; } } @@ -1399,9 +1440,37 @@ ParsePrimaryExpr(infoPtr) exprTokenPtr->size = (infoPtr->next - exprTokenPtr->start); exprTokenPtr->numComponents = parsePtr->numTokens - firstIndex; break; - - default: - goto syntaxError; + + case COMMA: + LogSyntaxError(infoPtr, + "commas can only separate function arguments"); + return TCL_ERROR; + case END: + LogSyntaxError(infoPtr, "premature end of expression"); + return TCL_ERROR; + case UNKNOWN: + LogSyntaxError(infoPtr, "single equality character not legal in expressions"); + return TCL_ERROR; + case UNKNOWN_CHAR: + LogSyntaxError(infoPtr, "character not legal in expressions"); + return TCL_ERROR; + case QUESTY: + LogSyntaxError(infoPtr, "unexpected ternary 'then' separator"); + return TCL_ERROR; + case COLON: + LogSyntaxError(infoPtr, "unexpected ternary 'else' separator"); + return TCL_ERROR; + case CLOSE_PAREN: + LogSyntaxError(infoPtr, "unexpected close parenthesis"); + return TCL_ERROR; + + default: { + char buf[64]; + + sprintf(buf, "unexpected operator %s", lexemeStrings[lexeme]); + LogSyntaxError(infoPtr, buf); + return TCL_ERROR; + } } /* @@ -1414,10 +1483,6 @@ ParsePrimaryExpr(infoPtr) } parsePtr->term = infoPtr->next; return TCL_OK; - - syntaxError: - LogSyntaxError(infoPtr); - return TCL_ERROR; } /* @@ -1453,11 +1518,9 @@ GetLexeme(infoPtr) ParseInfo *infoPtr; /* Holds state needed to parse the expr, * including the resulting lexeme. */ { - register char *src; /* Points to current source char. */ - char *termPtr; /* Points to char terminating a literal. */ - double doubleValue; /* Value of a scanned double literal. */ + register CONST char *src; /* Points to current source char. */ char c; - int startsWithDigit, offset; + int offset, length, numBytes; Tcl_Parse *parsePtr = infoPtr->parsePtr; Tcl_Interp *interp = parsePtr->interp; Tcl_UniChar ch; @@ -1471,26 +1534,18 @@ GetLexeme(infoPtr) infoPtr->prevEnd = infoPtr->next; /* - * Scan over leading white space at the start of a lexeme. Note that a - * backslash-newline is treated as a space. + * Scan over leading white space at the start of a lexeme. */ src = infoPtr->next; - c = *src; - while (isspace(UCHAR(c)) || (c == '\\')) { /* INTL: ISO space */ - if (c == '\\') { - if (src[1] == '\n') { - src += 2; - } else { - break; /* no longer white space */ - } - } else { - src++; - } - c = *src; - } + numBytes = parsePtr->end - src; + do { + char type; + int scanned = TclParseWhiteSpace(src, numBytes, parsePtr, &type); + src += scanned; numBytes -= scanned; + } while (numBytes && (*src == '\n') && (src++,numBytes--)); parsePtr->term = src; - if (src >= infoPtr->lastChar) { + if (numBytes == 0) { infoPtr->lexeme = END; infoPtr->next = src; return TCL_OK; @@ -1503,59 +1558,48 @@ GetLexeme(infoPtr) * by mistake, which would eventually cause a syntax error. */ + c = *src; if ((c != '+') && (c != '-')) { - startsWithDigit = isdigit(UCHAR(c)); /* INTL: digit */ - if (startsWithDigit && TclLooksLikeInt(src, -1)) { - errno = 0; - (void) strtoul(src, &termPtr, 0); - if (errno == ERANGE) { - if (interp != NULL) { - char *s = "integer value too large to represent"; - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, - (char *) NULL); - } + CONST char *end = infoPtr->lastChar; + if ((length = TclParseInteger(src, (end - src)))) { + /* + * First length bytes look like an integer. Verify by + * attempting the conversion to the largest integer we have. + */ + int code; + Tcl_WideInt wide; + Tcl_Obj *value = Tcl_NewStringObj(src, length); + + Tcl_IncrRefCount(value); + code = Tcl_GetWideIntFromObj(interp, value, &wide); + Tcl_DecrRefCount(value); + if (code == TCL_ERROR) { parsePtr->errorType = TCL_PARSE_BAD_NUMBER; return TCL_ERROR; } - if (termPtr != src) { - /* - * src was the start of a valid integer, but was it - * a bad octal? Stopping at a digit would cause that. - */ - if (isdigit(UCHAR(*termPtr))) { /* INTL: digit. */ - /* - * We only want to report an error for the number, - * but we may have something like "08+1" - */ - if (interp != NULL) { - while (isdigit(UCHAR(*(++termPtr)))) {} /* INTL: digit. */ - Tcl_ResetResult(interp); - offset = termPtr - src; - c = src[offset]; - src[offset] = 0; - Tcl_AppendResult(interp, "\"", src, - "\" is an invalid octal number", - (char *) NULL); - src[offset] = c; - } - parsePtr->errorType = TCL_PARSE_BAD_NUMBER; - return TCL_ERROR; - } + infoPtr->lexeme = LITERAL; + infoPtr->start = src; + infoPtr->size = length; + infoPtr->next = (src + length); + parsePtr->term = infoPtr->next; + return TCL_OK; + } else if ((length = ParseMaxDoubleLength(src, end))) { + /* + * There are length characters that could be a double. + * Let strtod() tells us for sure. Need a writable copy + * so we can set an terminating NULL to keep strtod from + * scanning too far. + */ + char *startPtr, *termPtr; + double doubleValue; + Tcl_DString toParse; - infoPtr->lexeme = LITERAL; - infoPtr->start = src; - infoPtr->size = (termPtr - src); - infoPtr->next = termPtr; - parsePtr->term = termPtr; - return TCL_OK; - } - } else if (startsWithDigit || (c == '.') - || (c == 'n') || (c == 'N')) { errno = 0; - doubleValue = strtod(src, &termPtr); - if (termPtr != src) { + Tcl_DStringInit(&toParse); + startPtr = Tcl_DStringAppend(&toParse, src, length); + doubleValue = strtod(startPtr, &termPtr); + Tcl_DStringFree(&toParse); + if (termPtr != startPtr) { if (errno != 0) { if (interp != NULL) { TclExprFloatError(interp, doubleValue); @@ -1565,14 +1609,19 @@ GetLexeme(infoPtr) } /* - * src was the start of a valid double. + * startPtr was the start of a valid double, copied + * from src. */ infoPtr->lexeme = LITERAL; infoPtr->start = src; - infoPtr->size = (termPtr - src); - infoPtr->next = termPtr; - parsePtr->term = termPtr; + if ((termPtr - startPtr) > length) { + infoPtr->size = length; + } else { + infoPtr->size = (termPtr - startPtr); + } + infoPtr->next = src + infoPtr->size; + parsePtr->term = infoPtr->next; return TCL_OK; } } @@ -1646,72 +1695,69 @@ GetLexeme(infoPtr) return TCL_OK; case '<': - switch (src[1]) { - case '<': - infoPtr->lexeme = LEFT_SHIFT; - infoPtr->size = 2; - infoPtr->next = src+2; - break; - case '=': - infoPtr->lexeme = LEQ; - infoPtr->size = 2; - infoPtr->next = src+2; - break; - default: - infoPtr->lexeme = LESS; - break; + infoPtr->lexeme = LESS; + if ((infoPtr->lastChar - src) > 1) { + switch (src[1]) { + case '<': + infoPtr->lexeme = LEFT_SHIFT; + infoPtr->size = 2; + infoPtr->next = src+2; + break; + case '=': + infoPtr->lexeme = LEQ; + infoPtr->size = 2; + infoPtr->next = src+2; + break; + } } parsePtr->term = infoPtr->next; return TCL_OK; case '>': - switch (src[1]) { - case '>': - infoPtr->lexeme = RIGHT_SHIFT; - infoPtr->size = 2; - infoPtr->next = src+2; - break; - case '=': - infoPtr->lexeme = GEQ; - infoPtr->size = 2; - infoPtr->next = src+2; - break; - default: - infoPtr->lexeme = GREATER; - break; + infoPtr->lexeme = GREATER; + if ((infoPtr->lastChar - src) > 1) { + switch (src[1]) { + case '>': + infoPtr->lexeme = RIGHT_SHIFT; + infoPtr->size = 2; + infoPtr->next = src+2; + break; + case '=': + infoPtr->lexeme = GEQ; + infoPtr->size = 2; + infoPtr->next = src+2; + break; + } } parsePtr->term = infoPtr->next; return TCL_OK; case '=': - if (src[1] == '=') { + infoPtr->lexeme = UNKNOWN; + if ((src[1] == '=') && ((infoPtr->lastChar - src) > 1)) { infoPtr->lexeme = EQUAL; infoPtr->size = 2; infoPtr->next = src+2; - } else { - infoPtr->lexeme = UNKNOWN; } parsePtr->term = infoPtr->next; return TCL_OK; case '!': - if (src[1] == '=') { + infoPtr->lexeme = NOT; + if ((src[1] == '=') && ((infoPtr->lastChar - src) > 1)) { infoPtr->lexeme = NEQ; infoPtr->size = 2; infoPtr->next = src+2; - } else { - infoPtr->lexeme = NOT; } parsePtr->term = infoPtr->next; return TCL_OK; case '&': - if (src[1] == '&') { + infoPtr->lexeme = BIT_AND; + if ((src[1] == '&') && ((infoPtr->lastChar - src) > 1)) { infoPtr->lexeme = AND; infoPtr->size = 2; infoPtr->next = src+2; - } else { - infoPtr->lexeme = BIT_AND; } parsePtr->term = infoPtr->next; return TCL_OK; @@ -1721,12 +1767,11 @@ GetLexeme(infoPtr) return TCL_OK; case '|': - if (src[1] == '|') { + infoPtr->lexeme = BIT_OR; + if ((src[1] == '|') && ((infoPtr->lastChar - src) > 1)) { infoPtr->lexeme = OR; infoPtr->size = 2; infoPtr->next = src+2; - } else { - infoPtr->lexeme = BIT_OR; } parsePtr->term = infoPtr->next; return TCL_OK; @@ -1735,22 +1780,104 @@ GetLexeme(infoPtr) infoPtr->lexeme = BIT_NOT; return TCL_OK; + case 'e': + if ((src[1] == 'q') && ((infoPtr->lastChar - src) > 1)) { + infoPtr->lexeme = STREQ; + infoPtr->size = 2; + infoPtr->next = src+2; + parsePtr->term = infoPtr->next; + return TCL_OK; + } else { + goto checkFuncName; + } + + case 'n': + if ((src[1] == 'e') && ((infoPtr->lastChar - src) > 1)) { + infoPtr->lexeme = STRNEQ; + infoPtr->size = 2; + infoPtr->next = src+2; + parsePtr->term = infoPtr->next; + return TCL_OK; + } else { + goto checkFuncName; + } + default: - offset = Tcl_UtfToUniChar(src, &ch); + checkFuncName: + length = (infoPtr->lastChar - src); + if (Tcl_UtfCharComplete(src, length)) { + offset = Tcl_UtfToUniChar(src, &ch); + } else { + char utfBytes[TCL_UTF_MAX]; + memcpy(utfBytes, src, (size_t) length); + utfBytes[length] = '\0'; + offset = Tcl_UtfToUniChar(utfBytes, &ch); + } c = UCHAR(ch); if (isalpha(UCHAR(c))) { /* INTL: ISO only. */ infoPtr->lexeme = FUNC_NAME; while (isalnum(UCHAR(c)) || (c == '_')) { /* INTL: ISO only. */ - src += offset; - offset = Tcl_UtfToUniChar(src, &ch); + src += offset; length -= offset; + if (Tcl_UtfCharComplete(src, length)) { + offset = Tcl_UtfToUniChar(src, &ch); + } else { + char utfBytes[TCL_UTF_MAX]; + memcpy(utfBytes, src, (size_t) length); + utfBytes[length] = '\0'; + offset = Tcl_UtfToUniChar(utfBytes, &ch); + } c = UCHAR(ch); } infoPtr->size = (src - infoPtr->start); infoPtr->next = src; parsePtr->term = infoPtr->next; + /* + * Check for boolean literals (true, false, yes, no, on, off) + */ + switch (infoPtr->start[0]) { + case 'f': + if (infoPtr->size == 5 && + strncmp("false", infoPtr->start, 5) == 0) { + infoPtr->lexeme = LITERAL; + return TCL_OK; + } + break; + case 'n': + if (infoPtr->size == 2 && + strncmp("no", infoPtr->start, 2) == 0) { + infoPtr->lexeme = LITERAL; + return TCL_OK; + } + break; + case 'o': + if (infoPtr->size == 3 && + strncmp("off", infoPtr->start, 3) == 0) { + infoPtr->lexeme = LITERAL; + return TCL_OK; + } else if (infoPtr->size == 2 && + strncmp("on", infoPtr->start, 2) == 0) { + infoPtr->lexeme = LITERAL; + return TCL_OK; + } + break; + case 't': + if (infoPtr->size == 4 && + strncmp("true", infoPtr->start, 4) == 0) { + infoPtr->lexeme = LITERAL; + return TCL_OK; + } + break; + case 'y': + if (infoPtr->size == 3 && + strncmp("yes", infoPtr->start, 3) == 0) { + infoPtr->lexeme = LITERAL; + return TCL_OK; + } + break; + } return TCL_OK; } - infoPtr->lexeme = UNKNOWN; + infoPtr->lexeme = UNKNOWN_CHAR; return TCL_OK; } } @@ -1758,6 +1885,107 @@ GetLexeme(infoPtr) /* *---------------------------------------------------------------------- * + * TclParseInteger -- + * + * Scans up to numBytes bytes starting at src, and checks whether + * the leading bytes look like an integer's string representation. + * + * Results: + * Returns 0 if the leading bytes do not look like an integer. + * Otherwise, returns the number of bytes examined that look + * like an integer. This may be less than numBytes if the integer + * is only the leading part of the string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclParseInteger(string, numBytes) + register CONST char *string;/* The string to examine. */ + register int numBytes; /* Max number of bytes to scan. */ +{ + register CONST char *p = string; + + /* Take care of introductory "0x" */ + if ((numBytes > 1) && (p[0] == '0') && ((p[1] == 'x') || (p[1] == 'X'))) { + int scanned; + Tcl_UniChar ch; + p+=2; numBytes -= 2; + scanned = TclParseHex(p, numBytes, &ch); + if (scanned) { + return scanned + 2; + } + return 0; + } + while (numBytes && isdigit(UCHAR(*p))) { /* INTL: digit */ + numBytes--; p++; + } + if (numBytes == 0) { + return (p - string); + } + if ((*p != '.') && (*p != 'e') && (*p != 'E')) { + return (p - string); + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * ParseMaxDoubleLength -- + * + * Scans a sequence of bytes checking that the characters could + * be in a string rep of a double. + * + * Results: + * Returns the number of bytes starting with string, runing to, but + * not including end, all of which could be part of a string rep. + * of a double. Only character identity is used, no actual + * parsing is done. + * + * The legal bytes are '0' - '9', 'A' - 'F', 'a' - 'f', + * '.', '+', '-', 'i', 'I', 'n', 'N', 'p', 'P', 'x', and 'X'. + * This covers the values "Inf" and "Nan" as well as the + * decimal and hexadecimal representations recognized by a + * C99-compliant strtod(). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ParseMaxDoubleLength(string, end) + register CONST char *string;/* The string to examine. */ + CONST char *end; /* Point to the first character past the end + * of the string we are examining. */ +{ + CONST char *p = string; + while (p < end) { + switch (*p) { + case '0': case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': case 'A': case 'B': + case 'C': case 'D': case 'E': case 'F': case 'I': case 'N': + case 'P': case 'X': case 'a': case 'b': case 'c': case 'd': + case 'e': case 'f': case 'i': case 'n': case 'p': case 'x': + case '.': case '+': case '-': + p++; + break; + default: + goto done; + } + } + done: + return (p - string); +} + +/* + *---------------------------------------------------------------------- + * * PrependSubExprTokens -- * * This procedure is called after the operands of an subexpression have @@ -1777,10 +2005,10 @@ GetLexeme(infoPtr) static void PrependSubExprTokens(op, opBytes, src, srcBytes, firstIndex, infoPtr) - char *op; /* Points to first byte of the operator + CONST char *op; /* Points to first byte of the operator * in the source script. */ int opBytes; /* Number of bytes in the operator. */ - char *src; /* Points to first byte of the subexpression + CONST char *src; /* Points to first byte of the subexpression * in the source script. */ int srcBytes; /* Number of bytes in subexpression's * source. */ @@ -1830,23 +2058,32 @@ PrependSubExprTokens(op, opBytes, src, srcBytes, firstIndex, infoPtr) * * Side effects: * Sets the interpreter result to an error message describing the - * expression that was being parsed when the error occurred. + * expression that was being parsed when the error occurred, and why + * the parser considers that to be a syntax error at all. * *---------------------------------------------------------------------- */ static void -LogSyntaxError(infoPtr) +LogSyntaxError(infoPtr, extraInfo) ParseInfo *infoPtr; /* Holds the parse state for the * expression being parsed. */ + CONST char *extraInfo; /* String to provide extra information + * about the syntax error. */ { int numBytes = (infoPtr->lastChar - infoPtr->originalExpr); char buffer[100]; - sprintf(buffer, "syntax error in expression \"%.*s\"", - ((numBytes > 60)? 60 : numBytes), infoPtr->originalExpr); + if (numBytes > 60) { + sprintf(buffer, "syntax error in expression \"%.60s...\"", + infoPtr->originalExpr); + } else { + sprintf(buffer, "syntax error in expression \"%.*s\"", + numBytes, infoPtr->originalExpr); + } + Tcl_ResetResult(infoPtr->parsePtr->interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->parsePtr->interp), - buffer, (char *) NULL); + buffer, ": ", extraInfo, (char *) NULL); infoPtr->parsePtr->errorType = TCL_PARSE_SYNTAX; infoPtr->parsePtr->term = infoPtr->start; } diff --git a/tcl/generic/tclPipe.c b/tcl/generic/tclPipe.c index 09bcb486671..e47648fe887 100644 --- a/tcl/generic/tclPipe.c +++ b/tcl/generic/tclPipe.c @@ -39,8 +39,9 @@ TCL_DECLARE_MUTEX(pipeMutex) /* Guard access to detList. */ */ static TclFile FileForRedirect _ANSI_ARGS_((Tcl_Interp *interp, - char *spec, int atOk, char *arg, char *nextArg, - int flags, int *skipPtr, int *closePtr, int *releasePtr)); + CONST char *spec, int atOk, CONST char *arg, + CONST char *nextArg, int flags, int *skipPtr, + int *closePtr, int *releasePtr)); /* *---------------------------------------------------------------------- @@ -67,14 +68,14 @@ static TclFile FileForRedirect(interp, spec, atOK, arg, nextArg, flags, skipPtr, closePtr, releasePtr) Tcl_Interp *interp; /* Intepreter to use for error reporting. */ - char *spec; /* Points to character just after + CONST char *spec; /* Points to character just after * redirection character. */ - char *arg; /* Pointer to entire argument containing + CONST char *arg; /* Pointer to entire argument containing * spec: used for error reporting. */ int atOK; /* Non-zero means that '@' notation can be * used to specify a channel, zero means that * it isn't. */ - char *nextArg; /* Next argument in argc/argv array, if needed + CONST char *nextArg; /* Next argument in argc/argv array, if needed * for file name or channel name. May be * NULL. */ int flags; /* Flags to use for opening file or to @@ -123,7 +124,7 @@ FileForRedirect(interp, spec, atOK, arg, nextArg, flags, skipPtr, closePtr, Tcl_Flush(chan); } } else { - char *name; + CONST char *name; Tcl_DString nameString; if (*spec == '\0') { @@ -278,7 +279,7 @@ TclCleanupChildren(interp, numPids, pidPtr, errorChan) int i, abnormalExit, anyErrorInfo; Tcl_Pid pid; WAIT_STATUS_TYPE waitStatus; - char *msg; + CONST char *msg; abnormalExit = 0; for (i = 0; i < numPids; i++) { @@ -324,7 +325,7 @@ TclCleanupChildren(interp, numPids, pidPtr, errorChan) abnormalExit = 1; } else if (WIFSIGNALED(waitStatus)) { if (interp != (Tcl_Interp *) NULL) { - char *p; + CONST char *p; p = Tcl_SignalMsg((int) (WTERMSIG(waitStatus))); Tcl_SetErrorCode(interp, "CHILDKILLED", msg1, @@ -335,7 +336,7 @@ TclCleanupChildren(interp, numPids, pidPtr, errorChan) } } else if (WIFSTOPPED(waitStatus)) { if (interp != (Tcl_Interp *) NULL) { - char *p; + CONST char *p; p = Tcl_SignalMsg((int) (WSTOPSIG(waitStatus))); Tcl_SetErrorCode(interp, "CHILDSUSP", msg1, @@ -371,7 +372,7 @@ TclCleanupChildren(interp, numPids, pidPtr, errorChan) int count; Tcl_Obj *objPtr; - Tcl_Seek(errorChan, 0L, SEEK_SET); + Tcl_Seek(errorChan, (Tcl_WideInt)0, SEEK_SET); objPtr = Tcl_NewObj(); count = Tcl_ReadChars(errorChan, objPtr, -1, 0); if (count < 0) { @@ -439,7 +440,7 @@ TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr, outPipePtr, errFilePtr) Tcl_Interp *interp; /* Interpreter to use for error reporting. */ int argc; /* Number of entries in argv. */ - char **argv; /* Array of strings describing commands in + CONST char **argv; /* Array of strings describing commands in * pipeline plus I/O redirection with <, * <<, >, etc. Argv[argc] must be NULL. */ Tcl_Pid **pidArrayPtr; /* Word at *pidArrayPtr gets filled in with @@ -476,7 +477,7 @@ TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr, * at *pidPtr right now. */ int cmdCount; /* Count of number of distinct commands * found in argc/argv. */ - char *inputLiteral = NULL; /* If non-null, then this points to a + CONST char *inputLiteral = NULL; /* If non-null, then this points to a * string containing input data (specified * via <<) to be piped to the first process * in the pipeline. */ @@ -498,7 +499,7 @@ TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr, int errorClose = 0; /* If non-zero, then errorFile should be * closed when cleaning up. */ int errorRelease = 0; - char *p; + CONST char *p; int skip, lastBar, lastArg, i, j, atOK, flags, errorToOutput; Tcl_DString execBuffer; TclFile pipeIn; @@ -802,7 +803,7 @@ TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr, for (i = 0; i < argc; i = lastArg + 1) { int result, joinThisError; Tcl_Pid pid; - char *oldName; + CONST char *oldName; /* * Convert the program name into native form. @@ -992,7 +993,7 @@ Tcl_OpenCommandChannel(interp, argc, argv, flags) Tcl_Interp *interp; /* Interpreter for error reporting. Can * NOT be NULL. */ int argc; /* How many arguments. */ - char **argv; /* Array of arguments for command pipe. */ + CONST char **argv; /* Array of arguments for command pipe. */ int flags; /* Or'ed combination of TCL_STDIN, TCL_STDOUT, * TCL_STDERR, and TCL_ENFORCE_MODE. */ { diff --git a/tcl/generic/tclPkg.c b/tcl/generic/tclPkg.c index 1906e8dbafb..1bdfe18991a 100644 --- a/tcl/generic/tclPkg.c +++ b/tcl/generic/tclPkg.c @@ -51,11 +51,12 @@ typedef struct Package { */ static int CheckVersion _ANSI_ARGS_((Tcl_Interp *interp, - char *string)); -static int ComparePkgVersions _ANSI_ARGS_((char *v1, char *v2, + CONST char *string)); +static int ComparePkgVersions _ANSI_ARGS_((CONST char *v1, + CONST char *v2, int *satPtr)); static Package * FindPackage _ANSI_ARGS_((Tcl_Interp *interp, - char *name)); + CONST char *name)); /* *---------------------------------------------------------------------- @@ -84,8 +85,8 @@ int Tcl_PkgProvide(interp, name, version) Tcl_Interp *interp; /* Interpreter in which package is now * available. */ - char *name; /* Name of package. */ - char *version; /* Version string for package. */ + CONST char *name; /* Name of package. */ + CONST char *version; /* Version string for package. */ { return Tcl_PkgProvideEx(interp, name, version, (ClientData) NULL); } @@ -94,8 +95,8 @@ int Tcl_PkgProvideEx(interp, name, version, clientData) Tcl_Interp *interp; /* Interpreter in which package is now * available. */ - char *name; /* Name of package. */ - char *version; /* Version string for package. */ + CONST char *name; /* Name of package. */ + CONST char *version; /* Version string for package. */ ClientData clientData; /* clientdata for this package (normally * used for C callback function table) */ { @@ -148,12 +149,12 @@ Tcl_PkgProvideEx(interp, name, version, clientData) *---------------------------------------------------------------------- */ -char * +CONST char * Tcl_PkgRequire(interp, name, version, exact) Tcl_Interp *interp; /* Interpreter in which package is now * available. */ - char *name; /* Name of desired package. */ - char *version; /* Version string for desired version; + CONST char *name; /* Name of desired package. */ + CONST char *version; /* Version string for desired version; * NULL means use the latest version * available. */ int exact; /* Non-zero means that only the particular @@ -163,12 +164,12 @@ Tcl_PkgRequire(interp, name, version, exact) return Tcl_PkgRequireEx(interp, name, version, exact, (ClientData *) NULL); } -char * +CONST char * Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) Tcl_Interp *interp; /* Interpreter in which package is now * available. */ - char *name; /* Name of desired package. */ - char *version; /* Version string for desired version; + CONST char *name; /* Name of desired package. */ + CONST char *version; /* Version string for desired version; * NULL means use the latest version * available. */ int exact; /* Non-zero means that only the particular @@ -186,7 +187,7 @@ Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) Tcl_DString command; /* - * If an attempt is being made to load this into a standalong executable + * If an attempt is being made to load this into a standalone executable * on a platform where backlinking is not supported then this must be * a shared version of Tcl (Otherwise the load would have failed). * Detect this situation by checking that this library has been correctly @@ -194,7 +195,67 @@ Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) * work. */ - if (!tclEmptyStringRep) { + if (tclEmptyStringRep == NULL) { + + /* + * OK, so what's going on here? + * + * First, what are we doing? We are performing a check on behalf of + * one particular caller, Tcl_InitStubs(). When a package is + * stub-enabled, it is statically linked to libtclstub.a, which + * contains a copy of Tcl_InitStubs(). When a stub-enabled package + * is loaded, its *_Init() function is supposed to call + * Tcl_InitStubs() before calling any other functions in the Tcl + * library. The first Tcl function called by Tcl_InitStubs() through + * the stub table is Tcl_PkgRequireEx(), so this code right here is + * the first code that is part of the original Tcl library in the + * executable that gets executed on behalf of a newly loaded + * stub-enabled package. + * + * One easy error for the developer/builder of a stub-enabled package + * to make is to forget to define USE_TCL_STUBS when compiling the + * package. When that happens, the package will contain symbols + * that are references to the Tcl library, rather than function + * pointers referencing the stub table. On platforms that lack + * backlinking, those unresolved references may cause the loading + * of the package to also load a second copy of the Tcl library, + * leading to all kinds of trouble. We would like to catch that + * error and report a useful message back to the user. That's + * what we're doing. + * + * 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.) + * + * Third, so what do we do about it? This situation indicates + * the package we just loaded wasn't properly compiled to be + * stub-enabled, yet it thinks it is stub-enabled (it called + * Tcl_InitStubs()). We want to report that the package just + * loaded is broken, so we want to place an error message in + * the interpreter result and return NULL to indicate failure + * to Tcl_InitStubs() so that it will also fail. (Further + * explanation why we don't want to Tcl_Panic() is welcome. + * 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. + */ + + tclEmptyStringRep = &tclEmptyString; Tcl_AppendResult(interp, "Cannot load package \"", name, "\" in standalone executable: This package is not ", "compiled with stub support", NULL); @@ -350,12 +411,12 @@ Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) *---------------------------------------------------------------------- */ -char * +CONST char * Tcl_PkgPresent(interp, name, version, exact) Tcl_Interp *interp; /* Interpreter in which package is now * available. */ - char *name; /* Name of desired package. */ - char *version; /* Version string for desired version; + CONST char *name; /* Name of desired package. */ + CONST char *version; /* Version string for desired version; * NULL means use the latest version * available. */ int exact; /* Non-zero means that only the particular @@ -365,12 +426,12 @@ Tcl_PkgPresent(interp, name, version, exact) return Tcl_PkgPresentEx(interp, name, version, exact, (ClientData *) NULL); } -char * +CONST char * Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr) Tcl_Interp *interp; /* Interpreter in which package is now * available. */ - char *name; /* Name of desired package. */ - char *version; /* Version string for desired version; + CONST char *name; /* Name of desired package. */ + CONST char *version; /* Version string for desired version; * NULL means use the latest version * available. */ int exact; /* Non-zero means that only the particular @@ -386,22 +447,6 @@ Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr) Package *pkgPtr; int satisfies, result; - /* - * If an attempt is being made to load this into a standalone executable - * on a platform where backlinking is not supported then this must be - * a shared version of Tcl (Otherwise the load would have failed). - * Detect this situation by checking that this library has been correctly - * initialised. If it has not been then return immediately as nothing will - * work. - */ - - if (!tclEmptyStringRep) { - Tcl_AppendResult(interp, "Cannot load package \"", name, - "\" in standalone executable: This package is not ", - "compiled with stub support", NULL); - return NULL; - } - hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name); if (hPtr) { pkgPtr = (Package *) Tcl_GetHashValue(hPtr); @@ -469,7 +514,7 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - static char *pkgOptions[] = { + static CONST char *pkgOptions[] = { "forget", "ifneeded", "names", "present", "provide", "require", "unknown", "vcompare", "versions", "vsatisfies", (char *) NULL }; @@ -485,7 +530,8 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_HashTable *tablePtr; - char *version, *argv2, *argv3, *argv4; + CONST char *version; + char *argv2, *argv3, *argv4; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); @@ -503,7 +549,7 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) keyString = Tcl_GetString(objv[i]); hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString); if (hPtr == NULL) { - return TCL_OK; + continue; } pkgPtr = (Package *) Tcl_GetHashValue(hPtr); Tcl_DeleteHashEntry(hPtr); @@ -619,7 +665,7 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) if (version == NULL) { return TCL_ERROR; } - Tcl_SetResult(interp, version, TCL_VOLATILE); + Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) ); break; } case PKG_PROVIDE: { @@ -674,7 +720,7 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) if (version == NULL) { return TCL_ERROR; } - Tcl_SetResult(interp, version, TCL_VOLATILE); + Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) ); break; } case PKG_UNKNOWN: { @@ -776,7 +822,7 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) static Package * FindPackage(interp, name) Tcl_Interp *interp; /* Interpreter to use for package lookup. */ - char *name; /* Name of package to fine. */ + CONST char *name; /* Name of package to fine. */ { Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hPtr; @@ -866,11 +912,11 @@ TclFreePackageInfo(iPtr) static int CheckVersion(interp, string) Tcl_Interp *interp; /* Used for error reporting. */ - char *string; /* Supposedly a version number, which is + CONST char *string; /* Supposedly a version number, which is * groups of decimal digits separated * by dots. */ { - char *p = string; + CONST char *p = string; char prevChar; if (!isdigit(UCHAR(*p))) { /* INTL: digit */ @@ -915,7 +961,8 @@ CheckVersion(interp, string) static int ComparePkgVersions(v1, v2, satPtr) - char *v1, *v2; /* Versions strings, of form 2.1.3 (any + CONST char *v1; + CONST char *v2; /* Versions strings, of form 2.1.3 (any * number of version numbers). */ int *satPtr; /* If non-null, the word pointed to is * filled in with a 0/1 value. 1 means diff --git a/tcl/generic/tclPlatDecls.h b/tcl/generic/tclPlatDecls.h index 2aff8ad1b9f..a7e5e174866 100644 --- a/tcl/generic/tclPlatDecls.h +++ b/tcl/generic/tclPlatDecls.h @@ -12,6 +12,22 @@ #ifndef _TCLPLATDECLS #define _TCLPLATDECLS +/* + * Pull in the typedef of TCHAR for windows. + */ +#if defined(__WIN32__) && !defined(_TCHAR_DEFINED) +# include <tchar.h> +# ifndef _TCHAR_DEFINED + /* Borland seems to forget to set this. */ + typedef _TCHAR TCHAR; +# define _TCHAR_DEFINED +# endif +# if defined(_MSC_VER) && defined(__STDC__) + /* MSVC++ misses this. */ + typedef _TCHAR TCHAR; +# endif +#endif + /* !BEGIN!: Do not edit below this line. */ /* @@ -35,12 +51,12 @@ EXTERN char * Tcl_MacConvertTextResource _ANSI_ARGS_(( Handle resource)); /* 2 */ EXTERN int Tcl_MacEvalResource _ANSI_ARGS_((Tcl_Interp * interp, - char * resourceName, int resourceNumber, - char * fileName)); + CONST char * resourceName, + int resourceNumber, CONST char * fileName)); /* 3 */ EXTERN Handle Tcl_MacFindResource _ANSI_ARGS_((Tcl_Interp * interp, - long resourceType, char * resourceName, - int resourceNumber, char * resFileRef, + long resourceType, CONST char * resourceName, + int resourceNumber, CONST char * resFileRef, int * releaseIt)); /* 4 */ EXTERN int Tcl_GetOSTypeFromObj _ANSI_ARGS_(( @@ -58,6 +74,13 @@ EXTERN int strncasecmp _ANSI_ARGS_((CONST char * s1, EXTERN int strcasecmp _ANSI_ARGS_((CONST char * s1, CONST char * s2)); #endif /* MAC_TCL */ +#ifdef MAC_OSX_TCL +/* 0 */ +EXTERN int Tcl_MacOSXOpenBundleResources _ANSI_ARGS_(( + Tcl_Interp * interp, CONST char * bundleName, + int hasResourceFile, int maxPathLen, + char * libraryPath)); +#endif /* MAC_OSX_TCL */ typedef struct TclPlatStubs { int magic; @@ -70,14 +93,17 @@ typedef struct TclPlatStubs { #ifdef MAC_TCL void (*tcl_MacSetEventProc) _ANSI_ARGS_((Tcl_MacConvertEventPtr procPtr)); /* 0 */ char * (*tcl_MacConvertTextResource) _ANSI_ARGS_((Handle resource)); /* 1 */ - int (*tcl_MacEvalResource) _ANSI_ARGS_((Tcl_Interp * interp, char * resourceName, int resourceNumber, char * fileName)); /* 2 */ - Handle (*tcl_MacFindResource) _ANSI_ARGS_((Tcl_Interp * interp, long resourceType, char * resourceName, int resourceNumber, char * resFileRef, int * releaseIt)); /* 3 */ + int (*tcl_MacEvalResource) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * resourceName, int resourceNumber, CONST char * fileName)); /* 2 */ + Handle (*tcl_MacFindResource) _ANSI_ARGS_((Tcl_Interp * interp, long resourceType, CONST char * resourceName, int resourceNumber, CONST char * resFileRef, int * releaseIt)); /* 3 */ int (*tcl_GetOSTypeFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, OSType * osTypePtr)); /* 4 */ void (*tcl_SetOSTypeObj) _ANSI_ARGS_((Tcl_Obj * objPtr, OSType osType)); /* 5 */ Tcl_Obj * (*tcl_NewOSTypeObj) _ANSI_ARGS_((OSType osType)); /* 6 */ int (*strncasecmp) _ANSI_ARGS_((CONST char * s1, CONST char * s2, size_t n)); /* 7 */ int (*strcasecmp) _ANSI_ARGS_((CONST char * s1, CONST char * s2)); /* 8 */ #endif /* MAC_TCL */ +#ifdef MAC_OSX_TCL + int (*tcl_MacOSXOpenBundleResources) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * bundleName, int hasResourceFile, int maxPathLen, char * libraryPath)); /* 0 */ +#endif /* MAC_OSX_TCL */ } TclPlatStubs; #ifdef __cplusplus @@ -142,6 +168,12 @@ extern TclPlatStubs *tclPlatStubsPtr; (tclPlatStubsPtr->strcasecmp) /* 8 */ #endif #endif /* MAC_TCL */ +#ifdef MAC_OSX_TCL +#ifndef Tcl_MacOSXOpenBundleResources +#define Tcl_MacOSXOpenBundleResources \ + (tclPlatStubsPtr->tcl_MacOSXOpenBundleResources) /* 0 */ +#endif +#endif /* MAC_OSX_TCL */ #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/tcl/generic/tclPort.h b/tcl/generic/tclPort.h index 4c719340b0e..3e9ea2ed34c 100644 --- a/tcl/generic/tclPort.h +++ b/tcl/generic/tclPort.h @@ -22,10 +22,22 @@ # include "../win/tclWinPort.h" #else # if defined(MAC_TCL) -# include "tclMacPort.h" -# else -# include "../unix/tclUnixPort.h" -# endif +# include "tclMacPort.h" +# else +# include "../unix/tclUnixPort.h" +# endif #endif +#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(LLONG_MIN) +# 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 +/* Assume that if LLONG_MIN is undefined, then so is LLONG_MAX */ +# define LLONG_MAX (~LLONG_MIN) +#endif + + #endif /* _TCLPORT */ diff --git a/tcl/generic/tclPosixStr.c b/tcl/generic/tclPosixStr.c index 2055f19eb48..54ddcd74fe4 100644 --- a/tcl/generic/tclPosixStr.c +++ b/tcl/generic/tclPosixStr.c @@ -35,7 +35,7 @@ *---------------------------------------------------------------------- */ -char * +CONST char * Tcl_ErrnoId() { switch (errno) { @@ -339,6 +339,9 @@ Tcl_ErrnoId() #if defined(EOPNOTSUPP) && (!defined(ENOTSUP) || (ENOTSUP != EOPNOTSUPP)) case EOPNOTSUPP: return "EOPNOTSUPP"; #endif +#if defined(EOVERFLOW) && ( !defined(EFBIG) || (EOVERFLOW != EFBIG) ) && ( !defined(EINVAL) || (EOVERFLOW != EINVAL) ) + case EOVERFLOW: return "EOVERFLOW"; +#endif #ifdef EPERM case EPERM: return "EPERM"; #endif @@ -480,7 +483,7 @@ Tcl_ErrnoId() *---------------------------------------------------------------------- */ -char * +CONST char * Tcl_ErrnoMsg(err) int err; /* Error number (such as in errno variable). */ { @@ -786,6 +789,9 @@ Tcl_ErrnoMsg(err) #if defined(EOPNOTSUPP) && (!defined(ENOTSUP) || (ENOTSUP != EOPNOTSUPP)) case EOPNOTSUPP: return "operation not supported on socket"; #endif +#if defined(EOVERFLOW) && ( !defined(EFBIG) || (EOVERFLOW != EFBIG) ) && ( !defined(EINVAL) || (EOVERFLOW != EINVAL) ) + case EOVERFLOW: return "file too big"; +#endif #ifdef EPERM case EPERM: return "not owner"; #endif @@ -927,7 +933,7 @@ Tcl_ErrnoMsg(err) *---------------------------------------------------------------------- */ -char * +CONST char * Tcl_SignalId(sig) int sig; /* Number of signal. */ { @@ -1059,7 +1065,7 @@ Tcl_SignalId(sig) *---------------------------------------------------------------------- */ -char * +CONST char * Tcl_SignalMsg(sig) int sig; /* Number of signal. */ { @@ -1172,4 +1178,3 @@ Tcl_SignalMsg(sig) } return "unknown signal"; } - diff --git a/tcl/generic/tclProc.c b/tcl/generic/tclProc.c index f9d19696ebe..cf5438f690d 100644 --- a/tcl/generic/tclProc.c +++ b/tcl/generic/tclProc.c @@ -27,6 +27,8 @@ static int ProcBodySetFromAny _ANSI_ARGS_((Tcl_Interp *interp, static void ProcBodyUpdateString _ANSI_ARGS_((Tcl_Obj *objPtr)); static int ProcessProcResultCode _ANSI_ARGS_((Tcl_Interp *interp, char *procName, int nameLen, int returnCode)); +static int TclCompileNoOp _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); /* * The ProcBodyObjType type @@ -67,7 +69,8 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) { register Interp *iPtr = (Interp *) interp; Proc *procPtr; - char *fullName, *procName; + char *fullName; + CONST char *procName, *procArgs, *procBody; Namespace *nsPtr, *altNsPtr, *cxtNsPtr; Tcl_Command cmd; Tcl_DString ds; @@ -145,6 +148,57 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) procPtr->cmdPtr = (Command *) cmd; + + /* + * Optimize for noop procs: if the argument list is just "args" + * and the body is empty, define a compileProc. + * + * Notes: + * - cannot be done for any argument list without having different + * compiled/not-compiled behaviour in the "wrong argument #" case, + * or making this code much more complicated. In any case, it doesn't + * seem to make a lot of sense to verify the number of arguments we + * are about to ignore ... + * - could be enhanced to handle also non-empty bodies that contain + * only comments; however, parsing the body will slow down the + * compilation of all procs whose argument list is just _args_ + */ + + procArgs = Tcl_GetString(objv[2]); + + while(*procArgs == ' ') { + procArgs++; + } + + if ((procArgs[0] == 'a') && (strncmp(procArgs, "args", 4) == 0)) { + procArgs +=4; + while(*procArgs != '\0') { + if (*procArgs != ' ') { + goto done; + } + procArgs++; + } + + /* + * The argument list is just "args"; check the body + */ + + procBody = Tcl_GetString(objv[3]); + while(*procBody != '\0') { + if (!isspace(UCHAR(*procBody))) { + goto done; + } + procBody++; + } + + /* + * The body is just spaces: link the compileProc + */ + + ((Command *) cmd)->compileProc = TclCompileNoOp; + } + + done: return TCL_OK; } @@ -175,17 +229,17 @@ int TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr) Tcl_Interp *interp; /* interpreter containing proc */ Namespace *nsPtr; /* namespace containing this proc */ - char *procName; /* unqualified name of this proc */ + CONST char *procName; /* unqualified name of this proc */ Tcl_Obj *argsPtr; /* description of arguments */ Tcl_Obj *bodyPtr; /* command body */ Proc **procPtrPtr; /* returns: pointer to proc data */ { Interp *iPtr = (Interp*)interp; - char **argArray = NULL; + CONST char **argArray = NULL; register Proc *procPtr; int i, length, result, numArgs; - char *args, *bytes, *p; + CONST char *args, *bytes, *p; register CompiledLocal *localPtr = NULL; Tcl_Obj *defPtr; int precompiled = 0; @@ -281,7 +335,7 @@ TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr) } for (i = 0; i < numArgs; i++) { int fieldCount, nameLength, valueLength; - char **fieldValues; + CONST char **fieldValues; /* * Now divide the specifier up into name and default. @@ -321,7 +375,7 @@ TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr) p = fieldValues[0]; while (*p != '\0') { if (*p == '(') { - char *q = p; + CONST char *q = p; do { q++; } while (*q != '\0'); @@ -335,6 +389,14 @@ TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr) ckfree((char *) fieldValues); goto procError; } + } else if ((*p == ':') && (*(p+1) == ':')) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "procedure \"", procName, + "\" has formal parameter \"", fieldValues[0], + "\" that is not a simple name", + (char *) NULL); + ckfree((char *) fieldValues); + goto procError; } p++; } @@ -415,6 +477,7 @@ TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr) } strcpy(localPtr->name, fieldValues[0]); } + ckfree((char *) fieldValues); } @@ -481,7 +544,7 @@ procError: int TclGetFrame(interp, string, framePtrPtr) Tcl_Interp *interp; /* Interpreter in which to find frame. */ - char *string; /* String describing frame. */ + CONST char *string; /* String describing frame. */ CallFrame **framePtrPtr; /* Store pointer to frame here (or NULL * if global frame indicated). */ { @@ -653,7 +716,7 @@ Tcl_UplevelObjCmd(dummy, interp, objc, objv) Proc * TclFindProc(iPtr, procName) Interp *iPtr; /* Interpreter in which to look. */ - char *procName; /* Name of desired procedure. */ + CONST char *procName; /* Name of desired procedure. */ { Tcl_Command cmd; Tcl_Command origCmd; @@ -735,7 +798,7 @@ TclProcInterpProc(clientData, interp, argc, argv) * invoked. */ int argc; /* Count of number of arguments to this * procedure. */ - register char **argv; /* Argument values. */ + register CONST char **argv; /* Argument values. */ { register Tcl_Obj *objPtr; register int i; @@ -839,6 +902,7 @@ TclObjInterpProc(clientData, interp, objc, objv) register CompiledLocal *localPtr; char *procName; int nameLen, localCt, numArgs, argCt, i, result; + Tcl_Obj *objResult = Tcl_GetObjResult(interp); /* * This procedure generates an array "compiledLocals" that holds the @@ -943,36 +1007,48 @@ TclObjInterpProc(clientData, interp, objc, objv) Tcl_Obj *listPtr = Tcl_NewListObj(argCt, &(objv[i])); varPtr->value.objPtr = listPtr; Tcl_IncrRefCount(listPtr); /* local var is a reference */ - varPtr->flags &= ~VAR_UNDEFINED; + TclClearVarUndefined(varPtr); argCt = 0; break; /* done processing args */ } else if (argCt > 0) { Tcl_Obj *objPtr = objv[i]; varPtr->value.objPtr = objPtr; - varPtr->flags &= ~VAR_UNDEFINED; + TclClearVarUndefined(varPtr); Tcl_IncrRefCount(objPtr); /* since the local variable now has * another reference to object. */ } else if (localPtr->defValuePtr != NULL) { Tcl_Obj *objPtr = localPtr->defValuePtr; varPtr->value.objPtr = objPtr; - varPtr->flags &= ~VAR_UNDEFINED; + TclClearVarUndefined(varPtr); Tcl_IncrRefCount(objPtr); /* since the local variable now has * another reference to object. */ } else { - Tcl_ResetResult(interp); - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "no value given for parameter \"", localPtr->name, - "\" to \"", Tcl_GetString(objv[0]), "\"", (char *) NULL); - result = TCL_ERROR; - goto procDone; + goto incorrectArgs; } varPtr++; localPtr = localPtr->nextPtr; } if (argCt > 0) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "called \"", Tcl_GetString(objv[0]), - "\" with too many arguments", (char *) NULL); + incorrectArgs: + /* + * Build up equivalent to Tcl_WrongNumArgs message for proc + */ + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(objResult, + "wrong # args: should be \"", procName, (char *) NULL); + localPtr = procPtr->firstLocalPtr; + for (i = 1; i <= numArgs; i++) { + if (localPtr->defValuePtr != NULL) { + Tcl_AppendStringsToObj(objResult, + " ?", localPtr->name, "?", (char *) NULL); + } else { + Tcl_AppendStringsToObj(objResult, + " ", localPtr->name, (char *) NULL); + } + localPtr = localPtr->nextPtr; + } + Tcl_AppendStringsToObj(objResult, "\"", (char *) NULL); + result = TCL_ERROR; goto procDone; } @@ -981,23 +1057,21 @@ TclObjInterpProc(clientData, interp, objc, objv) * Invoke the commands in the procedure's body. */ - if (tclTraceExec >= 1) { #ifdef TCL_COMPILE_DEBUG + if (tclTraceExec >= 1) { fprintf(stdout, "Calling proc "); for (i = 0; i < objc; i++) { TclPrintObject(stdout, objv[i], 15); fprintf(stdout, " "); } fprintf(stdout, "\n"); -#else /* TCL_COMPILE_DEBUG */ - fprintf(stdout, "Calling proc %.*s\n", nameLen, procName); -#endif /*TCL_COMPILE_DEBUG*/ fflush(stdout); } +#endif /*TCL_COMPILE_DEBUG*/ iPtr->returnCode = TCL_OK; procPtr->refCount++; - result = Tcl_EvalObjEx(interp, procPtr->bodyPtr, 0); + result = TclCompEvalObj(interp, procPtr->bodyPtr); procPtr->refCount--; if (procPtr->refCount <= 0) { TclProcCleanupProc(procPtr); @@ -1095,6 +1169,7 @@ TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName) int numChars; char *ellipsis; +#ifdef TCL_COMPILE_DEBUG if (tclTraceCompile >= 1) { /* * Display a line summarizing the top level command we @@ -1110,6 +1185,7 @@ TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName) fprintf(stdout, "Compiling %s \"%.*s%s\"\n", description, numChars, procName, ellipsis); } +#endif /* * Plug the current procPtr into the interpreter and coerce @@ -1207,33 +1283,32 @@ ProcessProcResultCode(interp, procName, nameLen, returnCode) int returnCode; /* The unexpected result code. */ { Interp *iPtr = (Interp *) interp; + char msg[100 + TCL_INTEGER_SPACE]; + char *ellipsis = ""; + if (returnCode == TCL_OK) { + return TCL_OK; + } + if (returnCode > TCL_CONTINUE) { + return returnCode; + } if (returnCode == TCL_RETURN) { - returnCode = TclUpdateReturnInfo(iPtr); - } else if (returnCode == TCL_ERROR) { - char msg[100 + TCL_INTEGER_SPACE]; - char *ellipsis = ""; - int numChars = nameLen; - - if (numChars > 60) { - numChars = 60; - ellipsis = "..."; - } - sprintf(msg, "\n (procedure \"%.*s%s\" line %d)", - numChars, procName, ellipsis, iPtr->errorLine); - Tcl_AddObjErrorInfo(interp, msg, -1); - } else if (returnCode == TCL_BREAK) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "invoked \"break\" outside of a loop", -1); - returnCode = TCL_ERROR; - } else if (returnCode == TCL_CONTINUE) { + return TclUpdateReturnInfo(iPtr); + } + if (returnCode != TCL_ERROR) { Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "invoked \"continue\" outside of a loop", -1); - returnCode = TCL_ERROR; + Tcl_AppendToObj(Tcl_GetObjResult(interp), ((returnCode == TCL_BREAK) + ? "invoked \"break\" outside of a loop" + : "invoked \"continue\" outside of a loop"), -1); } - return returnCode; + if (nameLen > 60) { + nameLen = 60; + ellipsis = "..."; + } + sprintf(msg, "\n (procedure \"%.*s%s\" line %d)", nameLen, procName, + ellipsis, iPtr->errorLine); + Tcl_AddObjErrorInfo(interp, msg, -1); + return TCL_ERROR; } /* @@ -1346,17 +1421,20 @@ TclUpdateReturnInfo(iPtr) * exception is being processed. */ { int code; + char *errorCode; code = iPtr->returnCode; iPtr->returnCode = TCL_OK; if (code == TCL_ERROR) { - Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode", (char *) NULL, - (iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE", + errorCode = ((iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE"); + Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorCode, + NULL, Tcl_NewStringObj(errorCode, -1), TCL_GLOBAL_ONLY); iPtr->flags |= ERROR_CODE_SET; if (iPtr->errorInfo != NULL) { - Tcl_SetVar2((Tcl_Interp *) iPtr, "errorInfo", (char *) NULL, - iPtr->errorInfo, TCL_GLOBAL_ONLY); + Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorInfo, + NULL, Tcl_NewStringObj(iPtr->errorInfo, -1), + TCL_GLOBAL_ONLY); iPtr->flags |= ERR_IN_PROGRESS; } } @@ -1568,3 +1646,53 @@ ProcBodyUpdateString(objPtr) { panic("called ProcBodyUpdateString"); } + + +/* + *---------------------------------------------------------------------- + * + * TclCompileNoOp -- + * + * Procedure called to compile noOp's + * + * Results: + * The return value is TCL_OK, indicating successful compilation. + * + * Side effects: + * Instructions are added to envPtr to execute a noOp at runtime. + * + *---------------------------------------------------------------------- + */ + +static int +TclCompileNoOp(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr; + int i, code; + int savedStackDepth = envPtr->currStackDepth; + + tokenPtr = parsePtr->tokenPtr; + for(i = 1; i < parsePtr->numWords; i++) { + tokenPtr = tokenPtr + tokenPtr->numComponents + 1; + envPtr->currStackDepth = savedStackDepth; + + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + code = TclCompileTokens(interp, tokenPtr+1, + tokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + return code; + } + TclEmitOpcode(INST_POP, envPtr); + } + } + envPtr->currStackDepth = savedStackDepth; + TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr); + return TCL_OK; +} + + + diff --git a/tcl/generic/tclRegexp.c b/tcl/generic/tclRegexp.c index 47254712ced..6fc4d0484c0 100644 --- a/tcl/generic/tclRegexp.c +++ b/tcl/generic/tclRegexp.c @@ -88,7 +88,7 @@ static Tcl_ThreadDataKey dataKey; */ static TclRegexp * CompileRegexp _ANSI_ARGS_((Tcl_Interp *interp, - char *pattern, int length, int flags)); + CONST char *pattern, int length, int flags)); static void DupRegexpInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, Tcl_Obj *copyPtr)); static void FinalizeRegexp _ANSI_ARGS_((ClientData clientData)); @@ -141,7 +141,7 @@ Tcl_RegExp Tcl_RegExpCompile(interp, string) Tcl_Interp *interp; /* For use in error reporting and * to access the interp regexp cache. */ - char *string; /* String for which to produce + CONST char *string; /* String for which to produce * compiled regular expression. */ { return (Tcl_RegExp) CompileRegexp(interp, string, (int) strlen(string), @@ -183,7 +183,7 @@ Tcl_RegExpExec(interp, re, string, start) int flags, result, numChars; TclRegexp *regexp = (TclRegexp *)re; Tcl_DString ds; - Tcl_UniChar *ustr; + CONST Tcl_UniChar *ustr; /* * If the starting point is offset from the beginning of the buffer, @@ -243,9 +243,9 @@ Tcl_RegExpRange(re, index, startPtr, endPtr) int index; /* 0 means give the range of the entire * match, > 0 means give the range of * a matching subrange. */ - char **startPtr; /* Store address of first character in + CONST char **startPtr; /* Store address of first character in * (sub-) range here. */ - char **endPtr; /* Store address of character just after last + CONST char **endPtr; /* Store address of character just after last * in (sub-) range here. */ { TclRegexp *regexpPtr = (TclRegexp *) re; @@ -398,8 +398,8 @@ TclRegExpRangeUniChar(re, index, startPtr, endPtr) int Tcl_RegExpMatch(interp, string, pattern) Tcl_Interp *interp; /* Used for error reporting. May be NULL. */ - char *string; /* String. */ - char *pattern; /* Regular expression to match against + CONST char *string; /* String. */ + CONST char *pattern; /* Regular expression to match against * string. */ { Tcl_RegExp re; @@ -455,8 +455,7 @@ Tcl_RegExpExecObj(interp, re, objPtr, offset, nmatches, flags) regexpPtr->string = NULL; regexpPtr->objPtr = objPtr; - udata = Tcl_GetUnicode(objPtr); - length = Tcl_GetCharLength(objPtr); + udata = Tcl_GetUnicodeFromObj(objPtr, &length); if (offset > length) { offset = length; @@ -697,7 +696,7 @@ TclRegAbout(interp, re) void TclRegError(interp, msg, status) Tcl_Interp *interp; /* Interpreter for error reporting. */ - char *msg; /* Message to prepend to error. */ + CONST char *msg; /* Message to prepend to error. */ int status; /* Status code to report. */ { char buf[100]; /* ample in practice */ @@ -832,12 +831,12 @@ SetRegexpFromAny(interp, objPtr) static TclRegexp * CompileRegexp(interp, string, length, flags) Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - char *string; /* The regexp to compile (UTF-8). */ + CONST char *string; /* The regexp to compile (UTF-8). */ int length; /* The length of the string in bytes. */ int flags; /* Compilation flags. */ { TclRegexp *regexpPtr; - Tcl_UniChar *uniString; + CONST Tcl_UniChar *uniString; int numChars; Tcl_DString stringBuf; int status, i; diff --git a/tcl/generic/tclResolve.c b/tcl/generic/tclResolve.c index 7fea4acffea..c2235475507 100644 --- a/tcl/generic/tclResolve.c +++ b/tcl/generic/tclResolve.c @@ -63,7 +63,7 @@ Tcl_AddInterpResolvers(interp, name, cmdProc, varProc, compiledVarProc) Tcl_Interp *interp; /* Interpreter whose name resolution * rules are being modified. */ - char *name; /* Name of this resolution scheme. */ + CONST char *name; /* Name of this resolution scheme. */ Tcl_ResolveCmdProc *cmdProc; /* New procedure for command * resolution */ Tcl_ResolveVarProc *varProc; /* Procedure for variable resolution @@ -142,7 +142,7 @@ Tcl_GetInterpResolvers(interp, name, resInfoPtr) Tcl_Interp *interp; /* Interpreter whose name resolution * rules are being queried. */ - char *name; /* Look for a scheme with this name. */ + CONST char *name; /* Look for a scheme with this name. */ Tcl_ResolverInfo *resInfoPtr; /* Returns pointers to the procedures, * if found */ { @@ -194,7 +194,7 @@ Tcl_RemoveInterpResolvers(interp, name) Tcl_Interp *interp; /* Interpreter whose name resolution * rules are being modified. */ - char *name; /* Name of the scheme to be removed. */ + CONST char *name; /* Name of the scheme to be removed. */ { Interp *iPtr = (Interp*)interp; ResolverScheme **prevPtrPtr, *resPtr; @@ -291,7 +291,7 @@ BumpCmdRefEpochs(nsPtr) * type: * * typedef int (Tcl_ResolveCmdProc) _ANSI_ARGS_(( - * Tcl_Interp* interp, char* name, Tcl_Namespace *context, + * Tcl_Interp* interp, CONST char* name, Tcl_Namespace *context, * int flags, Tcl_Command *rPtr)); * * Whenever a command is executed or Tcl_FindCommand is invoked @@ -308,7 +308,7 @@ BumpCmdRefEpochs(nsPtr) * time: * * typedef int (Tcl_ResolveCompiledVarProc) _ANSI_ARGS_(( - * Tcl_Interp* interp, char* name, Tcl_Namespace *context, + * Tcl_Interp* interp, CONST char* name, Tcl_Namespace *context, * Tcl_ResolvedVarInfo *rPtr)); * * If this procedure is able to resolve the name, it should return @@ -325,7 +325,7 @@ BumpCmdRefEpochs(nsPtr) * Tcl_FindNamespaceVar.) This procedure has the following type: * * typedef int (Tcl_ResolveVarProc) _ANSI_ARGS_(( - * Tcl_Interp* interp, char* name, Tcl_Namespace *context, + * Tcl_Interp* interp, CONST char* name, Tcl_Namespace *context, * int flags, Tcl_Var *rPtr)); * * This procedure is quite similar to the compile-time version. diff --git a/tcl/generic/tclResult.c b/tcl/generic/tclResult.c index 2b537b73e7a..15e07558b8b 100644 --- a/tcl/generic/tclResult.c +++ b/tcl/generic/tclResult.c @@ -297,7 +297,7 @@ Tcl_SetResult(interp, string, freeProc) *---------------------------------------------------------------------- */ -char * +CONST char * Tcl_GetStringResult(interp) register Tcl_Interp *interp; /* Interpreter whose result to return. */ { diff --git a/tcl/generic/tclScan.c b/tcl/generic/tclScan.c index c5d4784dfe3..7d4e560e59c 100644 --- a/tcl/generic/tclScan.c +++ b/tcl/generic/tclScan.c @@ -12,6 +12,10 @@ */ #include "tclInt.h" +/* + * For strtoll() and strtoull() declarations on some platforms... + */ +#include "tclPort.h" /* * Flag values used by Tcl_ScanObjCmd. @@ -29,6 +33,7 @@ #define SCAN_PTOK 0x100 /* Decimal point is allowed. */ #define SCAN_EXPOK 0x200 /* An exponent is allowed. */ +#define SCAN_LONGER 0x400 /* Asked for a wide value. */ /* * The following structure contains the information associated with @@ -270,6 +275,7 @@ ValidateFormat(interp, format, numVars, totalSubs) int staticAssign[STATIC_LIST_SIZE]; int *nassign = staticAssign; int objIndex, xpgSize, nspace = STATIC_LIST_SIZE; + char buf[TCL_UTF_MAX+1]; /* * Initialize an array that records the number of times a variable @@ -359,10 +365,16 @@ ValidateFormat(interp, format, numVars, totalSubs) } /* - * Ignore size specifier. + * Handle any size specifier. */ - if ((ch == 'l') || (ch == 'L') || (ch == 'h')) { + switch (ch) { + case 'l': + case 'L': +#ifndef TCL_WIDE_INT_IS_LONG + flags |= SCAN_LONGER; +#endif + case 'h': format += Tcl_UtfToUniChar(format, &ch); } @@ -375,24 +387,45 @@ ValidateFormat(interp, format, numVars, totalSubs) */ switch (ch) { + case 'c': + if (flags & SCAN_WIDTH) { + Tcl_SetResult(interp, + "field width may not be specified in %c conversion", + TCL_STATIC); + goto error; + } + /* + * Fall through! + */ case 'n': + case 's': + if (flags & SCAN_LONGER) { + invalidLonger: + buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "'l' modifier may not be specified in %", buf, + " conversion", NULL); + goto error; + } + /* + * Fall through! + */ case 'd': + case 'e': + case 'f': + case 'g': case 'i': case 'o': - case 'x': case 'u': - case 'f': - case 'e': - case 'g': - case 's': - break; - case 'c': - if (flags & SCAN_WIDTH) { - Tcl_SetResult(interp, "field width may not be specified in %c conversion", TCL_STATIC); - goto error; - } - break; + case 'x': + break; + /* + * Bracket terms need special checking + */ case '[': + if (flags & SCAN_LONGER) { + goto invalidLonger; + } if (*format == '\0') { goto badSet; } @@ -539,13 +572,18 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv) { char *format; int numVars, nconversions, totalVars = -1; - int objIndex, offset, i, value, result, code; + int objIndex, offset, i, result, code; + long value; char *string, *end, *baseString; char op = 0; int base = 0; int underflow = 0; size_t width; long (*fn)() = NULL; +#ifndef TCL_WIDE_INT_IS_LONG + Tcl_WideInt (*lfn)() = NULL; + Tcl_WideInt wideValue; +#endif Tcl_UniChar ch, sch; Tcl_Obj **objs = NULL, *objPtr = NULL; int flags; @@ -644,7 +682,7 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv) if (*end == '$') { format = end+1; format += Tcl_UtfToUniChar(format, &ch); - objIndex = value - 1; + objIndex = (int) value - 1; } } @@ -660,10 +698,19 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv) } /* - * Ignore size specifier. + * Handle any size specifier. */ - if ((ch == 'l') || (ch == 'L') || (ch == 'h')) { + switch (ch) { + case 'l': + case 'L': +#ifndef TCL_WIDE_INT_IS_LONG + flags |= SCAN_LONGER; +#endif + /* + * Fall through so we skip to the next character. + */ + case 'h': format += Tcl_UtfToUniChar(format, &ch); } @@ -685,27 +732,42 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv) op = 'i'; base = 10; fn = (long (*)())strtol; +#ifndef TCL_WIDE_INT_IS_LONG + lfn = (Tcl_WideInt (*)())strtoll; +#endif break; case 'i': op = 'i'; base = 0; fn = (long (*)())strtol; +#ifndef TCL_WIDE_INT_IS_LONG + lfn = (Tcl_WideInt (*)())strtoll; +#endif break; case 'o': op = 'i'; base = 8; - fn = (long (*)())strtol; + fn = (long (*)())strtoul; +#ifndef TCL_WIDE_INT_IS_LONG + lfn = (Tcl_WideInt (*)())strtoull; +#endif break; case 'x': op = 'i'; base = 16; - fn = (long (*)())strtol; + fn = (long (*)())strtoul; +#ifndef TCL_WIDE_INT_IS_LONG + lfn = (Tcl_WideInt (*)())strtoull; +#endif break; case 'u': op = 'i'; base = 10; flags |= SCAN_UNSIGNED; fn = (long (*)())strtoul; +#ifndef TCL_WIDE_INT_IS_LONG + lfn = (Tcl_WideInt (*)())strtoull; +#endif break; case 'f': @@ -854,12 +916,19 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv) * a number. If we are unsure of the base, it * indicates that we are in base 8 or base 16 (if it is * followed by an 'x'). + * + * 8.1 - 8.3.4 incorrectly handled 0x... base-16 + * cases for %x by not reading the 0x as the + * auto-prelude for base-16. [Bug #495213] */ case '0': if (base == 0) { base = 8; flags |= SCAN_XOK; } + if (base == 16) { + flags |= SCAN_XOK; + } if (flags & SCAN_NOZERO) { flags &= ~(SCAN_SIGNOK | SCAN_NODIGITS | SCAN_NOZERO); @@ -954,13 +1023,33 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv) if (!(flags & SCAN_SUPPRESS)) { *end = '\0'; - value = (int) (*fn)(buf, NULL, base); - if ((flags & SCAN_UNSIGNED) && (value < 0)) { - sprintf(buf, "%u", value); /* INTL: ISO digit */ - objPtr = Tcl_NewStringObj(buf, -1); +#ifndef TCL_WIDE_INT_IS_LONG + if (flags & SCAN_LONGER) { + wideValue = (Tcl_WideInt) (*lfn)(buf, NULL, base); + if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) { + /* INTL: ISO digit */ + sprintf(buf, "%" TCL_LL_MODIFIER "u", + (Tcl_WideUInt)wideValue); + objPtr = Tcl_NewStringObj(buf, -1); + } else { + objPtr = Tcl_NewWideIntObj(wideValue); + } } else { - objPtr = Tcl_NewIntObj(value); +#endif /* !TCL_WIDE_INT_IS_LONG */ + value = (long) (*fn)(buf, NULL, base); + if ((flags & SCAN_UNSIGNED) && (value < 0)) { + sprintf(buf, "%lu", value); /* INTL: ISO digit */ + objPtr = Tcl_NewStringObj(buf, -1); + } else { + if ((unsigned long) value > UINT_MAX) { + objPtr = Tcl_NewLongObj(value); + } else { + objPtr = Tcl_NewIntObj(value); + } + } +#ifndef TCL_WIDE_INT_IS_LONG } +#endif Tcl_IncrRefCount(objPtr); objs[objIndex++] = objPtr; } @@ -975,6 +1064,7 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv) if ((width == 0) || (width > sizeof(buf) - 1)) { width = sizeof(buf) - 1; } + flags &= ~SCAN_LONGER; flags |= SCAN_SIGNOK | SCAN_NODIGITS | SCAN_PTOK | SCAN_EXPOK; for (end = buf; width > 0; width--) { switch (*string) { @@ -1112,7 +1202,9 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv) } } } - ckfree((char*) objs); + if (objs != NULL) { + ckfree((char*) objs); + } if (code == TCL_OK) { if (underflow && (nconversions == 0)) { if (numVars) { diff --git a/tcl/generic/tclStringObj.c b/tcl/generic/tclStringObj.c index 7c435b508f6..c532e01afcd 100644 --- a/tcl/generic/tclStringObj.c +++ b/tcl/generic/tclStringObj.c @@ -33,8 +33,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id$ - */ + * RCS: @(#) $Id$ */ #include "tclInt.h" @@ -43,15 +42,15 @@ */ static void AppendUnicodeToUnicodeRep _ANSI_ARGS_(( - Tcl_Obj *objPtr, Tcl_UniChar *unicode, + Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode, int appendNumChars)); static void AppendUnicodeToUtfRep _ANSI_ARGS_(( - Tcl_Obj *objPtr, Tcl_UniChar *unicode, + Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode, int numChars)); static void AppendUtfToUnicodeRep _ANSI_ARGS_((Tcl_Obj *objPtr, - char *bytes, int numBytes)); + CONST char *bytes, int numBytes)); static void AppendUtfToUtfRep _ANSI_ARGS_((Tcl_Obj *objPtr, - char *bytes, int numBytes)); + CONST char *bytes, int numBytes)); static void FillUnicodeRep _ANSI_ARGS_((Tcl_Obj *objPtr)); @@ -109,6 +108,44 @@ typedef struct String { #define SET_STRING(objPtr, stringPtr) \ (objPtr)->internalRep.otherValuePtr = (VOID *) (stringPtr) +/* + * TCL STRING GROWTH ALGORITHM + * + * When growing strings (during an append, for example), the following growth + * algorithm is used: + * + * Attempt to allocate 2 * (originalLength + appendLength) + * On failure: + * attempt to allocate originalLength + 2*appendLength + + * TCL_GROWTH_MIN_ALLOC + * + * This algorithm allows very good performance, as it rapidly increases the + * memory allocated for a given string, which minimizes the number of + * reallocations that must be performed. However, using only the doubling + * algorithm can lead to a significant waste of memory. In particular, it + * may fail even when there is sufficient memory available to complete the + * append request (but there is not 2 * totalLength memory available). So when + * the doubling fails (because there is not enough memory available), the + * algorithm requests a smaller amount of memory, which is still enough to + * cover the request, but which hopefully will be less than the total available + * memory. + * + * The addition of TCL_GROWTH_MIN_ALLOC allows for efficient handling + * of very small appends. Without this extra slush factor, a sequence + * of several small appends would cause several memory allocations. + * As long as TCL_GROWTH_MIN_ALLOC is a reasonable size, we can + * avoid that behavior. + * + * The growth algorithm can be tuned by adjusting the following parameters: + * + * TCL_GROWTH_MIN_ALLOC Additional space, in bytes, to allocate when + * the double allocation has failed. + * Default is 1024 (1 kilobyte). + */ +#ifndef TCL_GROWTH_MIN_ALLOC +#define TCL_GROWTH_MIN_ALLOC 1024 +#endif + /* *---------------------------------------------------------------------- @@ -182,9 +219,9 @@ Tcl_NewStringObj(bytes, length) * TCL_MEM_DEBUG is defined. It creates new string objects. It is the * same as the Tcl_NewStringObj procedure above except that it calls * Tcl_DbCkalloc directly with the file name and line number from its - * caller. This simplifies debugging since then the checkmem command - * will report the correct file name and line number when reporting - * objects that haven't been freed. + * 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. * * When TCL_MEM_DEBUG is not defined, this procedure just returns the * result of calling Tcl_NewStringObj. @@ -213,7 +250,7 @@ Tcl_DbNewStringObj(bytes, length, file, line) * when initializing the new object. If * negative, use bytes up to the first * NULL byte. */ - char *file; /* The name of the source file calling this + 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. */ @@ -238,7 +275,7 @@ Tcl_DbNewStringObj(bytes, length, file, line) * when initializing the new object. If * negative, use bytes up to the first * NULL byte. */ - char *file; /* The name of the source file calling this + 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. */ @@ -250,10 +287,10 @@ Tcl_DbNewStringObj(bytes, length, file, line) /* *--------------------------------------------------------------------------- * - * TclNewUnicodeObj -- + * Tcl_NewUnicodeObj -- * * This procedure is creates a new String object and initializes - * it from the given Utf String. If the Utf String is the same size + * it from the given Unicode String. If the Utf String is the same size * as the Unicode string, don't duplicate the data. * * Results: @@ -269,7 +306,7 @@ Tcl_DbNewStringObj(bytes, length, file, line) Tcl_Obj * Tcl_NewUnicodeObj(unicode, numChars) - Tcl_UniChar *unicode; /* The unicode string used to initialize + CONST Tcl_UniChar *unicode; /* The unicode string used to initialize * the new object. */ int numChars; /* Number of characters in the unicode * string. */ @@ -483,6 +520,63 @@ Tcl_GetUnicode(objPtr) /* *---------------------------------------------------------------------- * + * Tcl_GetUnicodeFromObj -- + * + * 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 String object does not have a Unicode rep, then + * one is create from the UTF string format. + * + * Results: + * Returns a pointer to the object's internal Unicode string. + * + * Side effects: + * Converts the object to have the String internal rep. + * + *---------------------------------------------------------------------- + */ + +Tcl_UniChar * +Tcl_GetUnicodeFromObj(objPtr, lengthPtr) + 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; + + SetStringFromAny(NULL, objPtr); + stringPtr = GET_STRING(objPtr); + + if ((stringPtr->numChars == -1) || (stringPtr->uallocated == 0)) { + + /* + * We haven't yet calculated the length, or all of the characters + * in the Utf string are 1 byte chars (so we didn't store the + * unicode str). Since this function must return a unicode string, + * and one has not yet been stored, force the Unicode to be + * calculated and stored now. + */ + + FillUnicodeRep(objPtr); + + /* + * We need to fetch the pointer again because we have just + * reallocated the structure to make room for the Unicode data. + */ + + stringPtr = GET_STRING(objPtr); + } + + if (lengthPtr != NULL) { + *lengthPtr = stringPtr->numChars; + } + return stringPtr->unicode; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_GetRange -- * * Create a Tcl Object that contains the chars between first and last @@ -499,10 +593,9 @@ Tcl_GetUnicode(objPtr) *---------------------------------------------------------------------- */ -Tcl_Obj* +Tcl_Obj * Tcl_GetRange(objPtr, first, last) - - Tcl_Obj *objPtr; /* The Tcl object to find the range of. */ + 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. */ { @@ -580,7 +673,7 @@ Tcl_GetRange(objPtr, first, last) void Tcl_SetStringObj(objPtr, bytes, length) register Tcl_Obj *objPtr; /* Object whose internal rep to init. */ - char *bytes; /* Points to the first of the length bytes + CONST char *bytes; /* Points to the first of the length bytes * used to initialize the object. */ register int length; /* The number of bytes to copy from "bytes" * when initializing the object. If @@ -668,12 +761,97 @@ Tcl_SetObjLength(objPtr, length) * Not enough space in current string. Reallocate the string * space and free the old string. */ + if (objPtr->bytes != tclEmptyStringRep) { + new = (char *) ckrealloc((char *)objPtr->bytes, + (unsigned)(length+1)); + } else { + new = (char *) ckalloc((unsigned) (length+1)); + if (objPtr->bytes != NULL && objPtr->length != 0) { + memcpy((VOID *) new, (VOID *) objPtr->bytes, + (size_t) objPtr->length); + Tcl_InvalidateStringRep(objPtr); + } + } + objPtr->bytes = new; + stringPtr->allocated = length; + } + + objPtr->length = length; + if ((objPtr->bytes != NULL) && (objPtr->bytes != tclEmptyStringRep)) { + objPtr->bytes[length] = 0; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AttemptSetObjLength -- + * + * This procedure changes the length of the string representation + * of an object. It uses the attempt* (non-panic'ing) memory allocators. + * + * Results: + * 1 if the requested memory was allocated, 0 otherwise. + * + * Side effects: + * If the size of objPtr's string representation is greater than + * length, then it is reduced to length and a new terminating null + * byte is stored in the strength. If the length of the string + * representation is greater than length, the storage space is + * reallocated to the given length; a null byte is stored at the + * end, but other bytes past the end of the original string + * representation are undefined. The object's internal + * representation is changed to "expendable string". + * + *---------------------------------------------------------------------- + */ - new = (char *) ckalloc((unsigned) (length+1)); - if (objPtr->bytes != NULL) { - memcpy((VOID *) new, (VOID *) objPtr->bytes, - (size_t) objPtr->length); - Tcl_InvalidateStringRep(objPtr); +int +Tcl_AttemptSetObjLength(objPtr, length) + register Tcl_Obj *objPtr; /* Pointer to object. This object must + * not currently be shared. */ + register int length; /* Number of bytes desired for string + * representation of object, not including + * terminating null byte. */ +{ + char *new; + String *stringPtr; + + if (Tcl_IsShared(objPtr)) { + panic("Tcl_AttemptSetObjLength called with shared object"); + } + SetStringFromAny(NULL, objPtr); + + /* + * Invalidate the unicode data. + */ + + stringPtr = GET_STRING(objPtr); + stringPtr->numChars = -1; + stringPtr->uallocated = 0; + + if (length > (int) stringPtr->allocated) { + + /* + * Not enough space in current string. Reallocate the string + * space and free the old string. + */ + if (objPtr->bytes != tclEmptyStringRep) { + new = (char *) attemptckrealloc((char *)objPtr->bytes, + (unsigned)(length+1)); + if (new == NULL) { + return 0; + } + } else { + new = (char *) attemptckalloc((unsigned) (length+1)); + if (new == NULL) { + return 0; + } + if (objPtr->bytes != NULL && objPtr->length != 0) { + memcpy((VOID *) new, (VOID *) objPtr->bytes, + (size_t) objPtr->length); + Tcl_InvalidateStringRep(objPtr); + } } objPtr->bytes = new; stringPtr->allocated = length; @@ -683,6 +861,7 @@ Tcl_SetObjLength(objPtr, length) if ((objPtr->bytes != NULL) && (objPtr->bytes != tclEmptyStringRep)) { objPtr->bytes[length] = 0; } + return 1; } /* @@ -704,7 +883,7 @@ Tcl_SetObjLength(objPtr, length) void Tcl_SetUnicodeObj(objPtr, unicode, numChars) Tcl_Obj *objPtr; /* The object to set the string of. */ - Tcl_UniChar *unicode; /* The unicode string used to initialize + CONST Tcl_UniChar *unicode; /* The unicode string used to initialize * the object. */ int numChars; /* Number of characters in the unicode * string. */ @@ -766,7 +945,7 @@ Tcl_SetUnicodeObj(objPtr, unicode, numChars) void Tcl_AppendToObj(objPtr, bytes, length) register Tcl_Obj *objPtr; /* Points to the object to append to. */ - char *bytes; /* Points to the bytes to append to the + CONST char *bytes; /* Points to the bytes to append to the * object. */ register int length; /* The number of bytes to append from * "bytes". If < 0, then append all bytes @@ -823,7 +1002,7 @@ Tcl_AppendToObj(objPtr, bytes, length) void Tcl_AppendUnicodeToObj(objPtr, unicode, length) register Tcl_Obj *objPtr; /* Points to the object to append to. */ - Tcl_UniChar *unicode; /* The unicode string to append to the + CONST Tcl_UniChar *unicode; /* The unicode string to append to the * object. */ int length; /* Number of chars in "unicode". */ { @@ -838,15 +1017,7 @@ Tcl_AppendUnicodeToObj(objPtr, unicode, length) } SetStringFromAny(NULL, objPtr); - - /* - * TEMPORARY!!! This is terribly inefficient, but it works, and Don - * needs for me to check this stuff in ASAP. -Melissa - */ - -/* UpdateStringOfString(objPtr); */ -/* AppendUnicodeToUtfRep(objPtr, unicode, length); */ -/* return; */ + stringPtr = GET_STRING(objPtr); /* * If objPtr has a valid Unicode rep, then append the "unicode" @@ -854,7 +1025,6 @@ Tcl_AppendUnicodeToObj(objPtr, unicode, length) * "unicode" to objPtr's string rep. */ - stringPtr = GET_STRING(objPtr); if (stringPtr->uallocated > 0) { AppendUnicodeToUnicodeRep(objPtr, unicode, length); } else { @@ -970,13 +1140,12 @@ Tcl_AppendObjToObj(objPtr, appendObjPtr) static void AppendUnicodeToUnicodeRep(objPtr, unicode, appendNumChars) - Tcl_Obj *objPtr; /* Points to the object to append to. */ - Tcl_UniChar *unicode; /* String to append. */ - int appendNumChars; /* Number of chars of "unicode" to append. */ + Tcl_Obj *objPtr; /* Points to the object to append to. */ + CONST Tcl_UniChar *unicode; /* String to append. */ + int appendNumChars; /* Number of chars of "unicode" to append. */ { - String *stringPtr; - int numChars; - size_t newSize; + String *stringPtr, *tmpString; + size_t numChars; if (appendNumChars < 0) { appendNumChars = 0; @@ -990,21 +1159,28 @@ AppendUnicodeToUnicodeRep(objPtr, unicode, appendNumChars) SetStringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); - + /* * If not enough space has been allocated for the unicode rep, - * reallocate the internal rep object with double the amount of - * space needed, so the unicode string can grow without being - * reallocated. + * reallocate the internal rep object with additional space. First try to + * double the required allocation; if that fails, try a more modest + * increase. See the "TCL STRING GROWTH ALGORITHM" comment at the top of + * this file for an explanation of this growth algorithm. */ numChars = stringPtr->numChars + appendNumChars; - newSize = (numChars + 1) * sizeof(Tcl_UniChar); - if (newSize > stringPtr->uallocated) { - stringPtr->uallocated = newSize * 2; - stringPtr = (String *) ckrealloc((char*)stringPtr, + if (numChars >= stringPtr->uallocated) { + stringPtr->uallocated = 2 * numChars; + tmpString = (String *) attemptckrealloc((char *)stringPtr, STRING_SIZE(stringPtr->uallocated)); + if (tmpString == NULL) { + stringPtr->uallocated = + numChars + appendNumChars + TCL_GROWTH_MIN_ALLOC; + tmpString = (String *) ckrealloc((char *)stringPtr, + STRING_SIZE(stringPtr->uallocated)); + } + stringPtr = tmpString; SET_STRING(objPtr, stringPtr); } @@ -1018,7 +1194,6 @@ AppendUnicodeToUnicodeRep(objPtr, unicode, appendNumChars) stringPtr->unicode[numChars] = 0; stringPtr->numChars = numChars; - SET_STRING(objPtr, stringPtr); Tcl_InvalidateStringRep(objPtr); } @@ -1041,12 +1216,12 @@ AppendUnicodeToUnicodeRep(objPtr, unicode, appendNumChars) static void AppendUnicodeToUtfRep(objPtr, unicode, numChars) - Tcl_Obj *objPtr; /* Points to the object to append to. */ - Tcl_UniChar *unicode; /* String to convert to UTF. */ - int numChars; /* Number of chars of "unicode" to convert. */ + Tcl_Obj *objPtr; /* Points to the object to append to. */ + CONST Tcl_UniChar *unicode; /* String to convert to UTF. */ + int numChars; /* Number of chars of "unicode" to convert. */ { Tcl_DString dsPtr; - char *bytes; + CONST char *bytes; if (numChars < 0) { numChars = 0; @@ -1059,7 +1234,7 @@ AppendUnicodeToUtfRep(objPtr, unicode, numChars) } Tcl_DStringInit(&dsPtr); - bytes = (char *)Tcl_UniCharToUtfDString(unicode, numChars, &dsPtr); + bytes = Tcl_UniCharToUtfDString(unicode, numChars, &dsPtr); AppendUtfToUtfRep(objPtr, bytes, Tcl_DStringLength(&dsPtr)); Tcl_DStringFree(&dsPtr); } @@ -1085,7 +1260,7 @@ AppendUnicodeToUtfRep(objPtr, unicode, numChars) static void AppendUtfToUnicodeRep(objPtr, bytes, numBytes) Tcl_Obj *objPtr; /* Points to the object to append to. */ - char *bytes; /* String to convert to Unicode. */ + CONST char *bytes; /* String to convert to Unicode. */ int numBytes; /* Number of bytes of "bytes" to convert. */ { Tcl_DString dsPtr; @@ -1126,7 +1301,7 @@ AppendUtfToUnicodeRep(objPtr, bytes, numBytes) static void AppendUtfToUtfRep(objPtr, bytes, numBytes) Tcl_Obj *objPtr; /* Points to the object to append to. */ - char *bytes; /* String to append. */ + CONST char *bytes; /* String to append. */ int numBytes; /* Number of bytes of "bytes" to append. */ { String *stringPtr; @@ -1151,13 +1326,17 @@ AppendUtfToUtfRep(objPtr, bytes, numBytes) if (newLength > (int) stringPtr->allocated) { /* - * There isn't currently enough space in the string - * representation so allocate additional space. Overallocate the - * space by doubling it so that we won't have to do as much - * reallocation in the future. + * There isn't currently enough space in the string representation + * so allocate additional space. First, try to double the length + * required. If that fails, try a more modest allocation. See the + * "TCL STRING GROWTH ALGORITHM" comment at the top of this file for an + * explanation of this growth algorithm. */ - Tcl_SetObjLength(objPtr, 2*newLength); + if (Tcl_AttemptSetObjLength(objPtr, 2 * newLength) == 0) { + Tcl_SetObjLength(objPtr, + newLength + numBytes + TCL_GROWTH_MIN_ALLOC); + } } else { /* @@ -1199,7 +1378,7 @@ Tcl_AppendStringsToObjVA (objPtr, argList) { #define STATIC_LIST_SIZE 16 String *stringPtr; - int newLength, oldLength; + int newLength, oldLength, attemptLength; register char *string, *dst; char *static_list[STATIC_LIST_SIZE]; char **args = static_list; @@ -1220,7 +1399,8 @@ Tcl_AppendStringsToObjVA (objPtr, argList) */ nargs = 0; - newLength = oldLength = objPtr->length; + newLength = 0; + oldLength = objPtr->length; while (1) { string = va_arg(argList, char *); if (string == NULL) { @@ -1244,23 +1424,35 @@ Tcl_AppendStringsToObjVA (objPtr, argList) newLength += strlen(string); args[nargs++] = string; } - if (newLength == oldLength) { + if (newLength == 0) { goto done; } stringPtr = GET_STRING(objPtr); - if (newLength > (int) stringPtr->allocated) { + if (oldLength + newLength > (int) stringPtr->allocated) { /* * There isn't currently enough space in the string - * representation so allocate additional space. If the current + * representation, so allocate additional space. If the current * string representation isn't empty (i.e. it looks like we're - * doing a series of appends) then overallocate the space so - * that we won't have to do as much reallocation in the future. + * doing a series of appends) then try to allocate extra space to + * accomodate future growth: first try to double the required memory; + * if that fails, try a more modest allocation. See the "TCL STRING + * GROWTH ALGORITHM" comment at the top of this file for an explanation + * of this growth algorithm. Otherwise, if the current string + * representation is empty, exactly enough memory is allocated. */ - Tcl_SetObjLength(objPtr, - (objPtr->length == 0) ? newLength : 2*newLength); + if (oldLength == 0) { + Tcl_SetObjLength(objPtr, newLength); + } else { + attemptLength = 2 * (oldLength + newLength); + if (Tcl_AttemptSetObjLength(objPtr, attemptLength) == 0) { + attemptLength = oldLength + (2 * newLength) + + TCL_GROWTH_MIN_ALLOC; + Tcl_SetObjLength(objPtr, attemptLength); + } + } } /* @@ -1291,7 +1483,7 @@ Tcl_AppendStringsToObjVA (objPtr, argList) if (dst != NULL) { *dst = 0; } - objPtr->length = newLength; + objPtr->length = oldLength + newLength; done: /* @@ -1486,10 +1678,8 @@ DupStringInternalRep(srcPtr, copyPtr) static int SetStringFromAny(interp, objPtr) Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr; /* The object to convert. */ + register Tcl_Obj *objPtr; /* The object to convert. */ { - String *stringPtr; - /* * The Unicode object is opitmized for the case where each UTF char * in a string is only one byte. In this case, we store the value of @@ -1497,6 +1687,7 @@ SetStringFromAny(interp, objPtr) */ if (objPtr->typePtr != &tclStringType) { + String *stringPtr; if (objPtr->typePtr != NULL) { if (objPtr->bytes == NULL) { diff --git a/tcl/generic/tclStubInit.c b/tcl/generic/tclStubInit.c index fec95ec45f4..ae18983f7a7 100644 --- a/tcl/generic/tclStubInit.c +++ b/tcl/generic/tclStubInit.c @@ -31,6 +31,10 @@ #undef Tcl_NewStringObj #undef Tcl_DumpActiveMemory #undef Tcl_ValidateAllMemory +#if TCL_PRESERVE_BINARY_COMPATABILITY +# undef Tcl_FindHashEntry +# undef Tcl_CreateHashEntry +#endif /* * WARNING: The contents of this file is automatically generated by the @@ -43,7 +47,7 @@ TclIntStubs tclIntStubs = { TCL_STUB_MAGIC, NULL, - TclAccess, /* 0 */ + NULL, /* 0 */ TclAccessDeleteProc, /* 1 */ TclAccessInsertProc, /* 2 */ TclAllocateFreeObjects, /* 3 */ @@ -76,11 +80,11 @@ TclIntStubs tclIntStubs = { TclDumpMemoryInfo, /* 14 */ NULL, /* 15 */ TclExprFloatError, /* 16 */ - TclFileAttrsCmd, /* 17 */ - TclFileCopyCmd, /* 18 */ - TclFileDeleteCmd, /* 19 */ - TclFileMakeDirsCmd, /* 20 */ - TclFileRenameCmd, /* 21 */ + NULL, /* 17 */ + NULL, /* 18 */ + NULL, /* 19 */ + NULL, /* 20 */ + NULL, /* 21 */ TclFindElement, /* 22 */ TclFindProc, /* 23 */ TclFormatInt, /* 24 */ @@ -88,13 +92,13 @@ TclIntStubs tclIntStubs = { NULL, /* 26 */ TclGetDate, /* 27 */ TclpGetDefaultStdChannel, /* 28 */ - TclGetElementOfIndexedArray, /* 29 */ + NULL, /* 29 */ NULL, /* 30 */ TclGetExtension, /* 31 */ TclGetFrame, /* 32 */ TclGetInterpProc, /* 33 */ TclGetIntForIndex, /* 34 */ - TclGetIndexedScalar, /* 35 */ + NULL, /* 35 */ TclGetLong, /* 36 */ TclGetLoadedPackages, /* 37 */ TclGetNamespaceForQualName, /* 38 */ @@ -106,8 +110,8 @@ TclIntStubs tclIntStubs = { TclGuessPackageName, /* 44 */ TclHideUnsafeCommands, /* 45 */ TclInExit, /* 46 */ - TclIncrElementOfIndexedArray, /* 47 */ - TclIncrIndexedScalar, /* 48 */ + NULL, /* 47 */ + NULL, /* 48 */ TclIncrVar2, /* 49 */ TclInitCompiledLocals, /* 50 */ TclInterpInit, /* 51 */ @@ -118,7 +122,7 @@ TclIntStubs tclIntStubs = { NULL, /* 56 */ NULL, /* 57 */ TclLookupVar, /* 58 */ - TclpMatchFiles, /* 59 */ + NULL, /* 59 */ TclNeedSpace, /* 60 */ TclNewProcBodyObj, /* 61 */ TclObjCommandComplete, /* 62 */ @@ -127,22 +131,22 @@ TclIntStubs tclIntStubs = { TclObjInvokeGlobal, /* 65 */ TclOpenFileChannelDeleteProc, /* 66 */ TclOpenFileChannelInsertProc, /* 67 */ - TclpAccess, /* 68 */ + NULL, /* 68 */ TclpAlloc, /* 69 */ - TclpCopyFile, /* 70 */ - TclpCopyDirectory, /* 71 */ - TclpCreateDirectory, /* 72 */ - TclpDeleteFile, /* 73 */ + NULL, /* 70 */ + NULL, /* 71 */ + NULL, /* 72 */ + NULL, /* 73 */ TclpFree, /* 74 */ TclpGetClicks, /* 75 */ TclpGetSeconds, /* 76 */ TclpGetTime, /* 77 */ TclpGetTimeZone, /* 78 */ - TclpListVolumes, /* 79 */ - TclpOpenFileChannel, /* 80 */ + NULL, /* 79 */ + NULL, /* 80 */ TclpRealloc, /* 81 */ - TclpRemoveDirectory, /* 82 */ - TclpRenameFile, /* 83 */ + NULL, /* 82 */ + NULL, /* 83 */ NULL, /* 84 */ NULL, /* 85 */ NULL, /* 86 */ @@ -154,12 +158,12 @@ TclIntStubs tclIntStubs = { TclProcCompileProc, /* 92 */ TclProcDeleteProc, /* 93 */ TclProcInterpProc, /* 94 */ - TclpStat, /* 95 */ + NULL, /* 95 */ TclRenameCommand, /* 96 */ TclResetShadowedCmdRefs, /* 97 */ TclServiceIdle, /* 98 */ - TclSetElementOfIndexedArray, /* 99 */ - TclSetIndexedScalar, /* 100 */ + NULL, /* 99 */ + NULL, /* 100 */ #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ TclSetPreInitScript, /* 101 */ #endif /* UNIX */ @@ -180,7 +184,7 @@ TclIntStubs tclIntStubs = { #ifdef MAC_TCL NULL, /* 104 */ #endif /* MAC_TCL */ - TclStat, /* 105 */ + NULL, /* 105 */ TclStatDeleteProc, /* 106 */ TclStatInsertProc, /* 107 */ TclTeardownNamespace, /* 108 */ @@ -212,9 +216,9 @@ TclIntStubs tclIntStubs = { TclpStrftime, /* 134 */ TclpCheckStackSpace, /* 135 */ NULL, /* 136 */ - TclpChdir, /* 137 */ + NULL, /* 137 */ TclGetEnv, /* 138 */ - TclpLoadFile, /* 139 */ + NULL, /* 139 */ TclLooksLikeInt, /* 140 */ TclpGetCwd, /* 141 */ TclSetByteCodeFromAny, /* 142 */ @@ -235,9 +239,18 @@ TclIntStubs tclIntStubs = { TclVarTraceExists, /* 157 */ TclSetStartupScriptFileName, /* 158 */ TclGetStartupScriptFileName, /* 159 */ - TclpMatchFilesTypes, /* 160 */ + NULL, /* 160 */ TclChannelTransform, /* 161 */ TclChannelEventScriptInvoker, /* 162 */ + TclGetInstructionTable, /* 163 */ + TclExpandCodeArray, /* 164 */ + TclpSetInitialEncodings, /* 165 */ + TclListObjSetElement, /* 166 */ + TclSetStartupScriptPath, /* 167 */ + TclGetStartupScriptPath, /* 168 */ + TclpUtfNcmp2, /* 169 */ + TclCheckInterpTraces, /* 170 */ + TclCheckExecutionTraces, /* 171 */ }; TclIntPlatStubs tclIntPlatStubs = { @@ -254,6 +267,10 @@ TclIntPlatStubs tclIntPlatStubs = { TclpOpenFile, /* 7 */ TclUnixWaitForFile, /* 8 */ TclpCreateTempFile, /* 9 */ + TclpReaddir, /* 10 */ + TclpLocaltime, /* 11 */ + TclpGmtime, /* 12 */ + TclpInetNtoa, /* 13 */ #endif /* UNIX */ #ifdef __WIN32__ TclWinConvertError, /* 0 */ @@ -277,12 +294,13 @@ TclIntPlatStubs tclIntPlatStubs = { TclpMakeFile, /* 18 */ TclpOpenFile, /* 19 */ TclWinAddProcess, /* 20 */ - TclpAsyncMark, /* 21 */ + NULL, /* 21 */ TclpCreateTempFile, /* 22 */ TclpGetTZName, /* 23 */ TclWinNoBackslash, /* 24 */ TclWinGetPlatform, /* 25 */ TclWinSetInterfaces, /* 26 */ + TclWinFlushDirtyChannels, /* 27 */ #endif /* __WIN32__ */ #ifdef MAC_TCL TclpSysAlloc, /* 0 */ @@ -292,10 +310,10 @@ TclIntPlatStubs tclIntPlatStubs = { FSpGetDefaultDir, /* 4 */ FSpSetDefaultDir, /* 5 */ FSpFindFolder, /* 6 */ - GetGlobalMouse, /* 7 */ - FSpGetDirectoryID, /* 8 */ - FSpOpenResFileCompat, /* 9 */ - FSpCreateResFileCompat, /* 10 */ + GetGlobalMouseTcl, /* 7 */ + FSpGetDirectoryIDTcl, /* 8 */ + FSpOpenResFileCompatTcl, /* 9 */ + FSpCreateResFileCompatTcl, /* 10 */ FSpLocationFromPath, /* 11 */ FSpPathFromLocation, /* 12 */ TclMacExitHandler, /* 13 */ @@ -309,8 +327,9 @@ TclIntPlatStubs tclIntPlatStubs = { TclMacUnRegisterResourceFork, /* 21 */ TclMacCreateEnv, /* 22 */ TclMacFOpenHack, /* 23 */ - NULL, /* 24 */ + TclpGetTZName, /* 24 */ TclMacChmod, /* 25 */ + FSpLLocationFromPath, /* 26 */ #endif /* MAC_TCL */ }; @@ -332,6 +351,9 @@ TclPlatStubs tclPlatStubs = { strncasecmp, /* 7 */ strcasecmp, /* 8 */ #endif /* MAC_TCL */ +#ifdef MAC_OSX_TCL + Tcl_MacOSXOpenBundleResources, /* 0 */ +#endif /* MAC_OSX_TCL */ }; static TclStubHooks tclStubHooks = { @@ -611,7 +633,7 @@ TclStubs tclStubs = { Tcl_ResetResult, /* 217 */ Tcl_ScanElement, /* 218 */ Tcl_ScanCountedElement, /* 219 */ - Tcl_Seek, /* 220 */ + Tcl_SeekOld, /* 220 */ Tcl_ServiceAll, /* 221 */ Tcl_ServiceEvent, /* 222 */ Tcl_SetAssocData, /* 223 */ @@ -637,7 +659,7 @@ TclStubs tclStubs = { Tcl_SplitPath, /* 243 */ Tcl_StaticPackage, /* 244 */ Tcl_StringMatch, /* 245 */ - Tcl_Tell, /* 246 */ + Tcl_TellOld, /* 246 */ Tcl_TraceVar, /* 247 */ Tcl_TraceVar2, /* 248 */ Tcl_TranslateFileName, /* 249 */ @@ -669,21 +691,13 @@ TclStubs tclStubs = { Tcl_SetErrorCodeVA, /* 275 */ Tcl_VarEvalVA, /* 276 */ Tcl_WaitPid, /* 277 */ -#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ - Tcl_PanicVA, /* 278 */ -#endif /* UNIX */ -#ifdef __WIN32__ Tcl_PanicVA, /* 278 */ -#endif /* __WIN32__ */ -#ifdef MAC_TCL - NULL, /* 278 */ -#endif /* MAC_TCL */ Tcl_GetVersion, /* 279 */ Tcl_InitMemory, /* 280 */ Tcl_StackChannel, /* 281 */ Tcl_UnstackChannel, /* 282 */ Tcl_GetStackedChannel, /* 283 */ - NULL, /* 284 */ + Tcl_SetMainLoop, /* 284 */ NULL, /* 285 */ Tcl_AppendObjToObj, /* 286 */ Tcl_CreateEncoding, /* 287 */ @@ -811,7 +825,88 @@ TclStubs tclStubs = { Tcl_ChannelGetHandleProc, /* 409 */ Tcl_ChannelFlushProc, /* 410 */ Tcl_ChannelHandlerProc, /* 411 */ + Tcl_JoinThread, /* 412 */ + Tcl_IsChannelShared, /* 413 */ + Tcl_IsChannelRegistered, /* 414 */ + Tcl_CutChannel, /* 415 */ + Tcl_SpliceChannel, /* 416 */ + Tcl_ClearChannelHandlers, /* 417 */ + Tcl_IsChannelExisting, /* 418 */ + Tcl_UniCharNcasecmp, /* 419 */ + Tcl_UniCharCaseMatch, /* 420 */ + Tcl_FindHashEntry, /* 421 */ + Tcl_CreateHashEntry, /* 422 */ + Tcl_InitCustomHashTable, /* 423 */ + Tcl_InitObjHashTable, /* 424 */ + Tcl_CommandTraceInfo, /* 425 */ + Tcl_TraceCommand, /* 426 */ + Tcl_UntraceCommand, /* 427 */ + Tcl_AttemptAlloc, /* 428 */ + Tcl_AttemptDbCkalloc, /* 429 */ + Tcl_AttemptRealloc, /* 430 */ + Tcl_AttemptDbCkrealloc, /* 431 */ + Tcl_AttemptSetObjLength, /* 432 */ + Tcl_GetChannelThread, /* 433 */ + Tcl_GetUnicodeFromObj, /* 434 */ + Tcl_GetMathFuncInfo, /* 435 */ + Tcl_ListMathFuncs, /* 436 */ + Tcl_SubstObj, /* 437 */ + Tcl_DetachChannel, /* 438 */ + Tcl_IsStandardChannel, /* 439 */ + Tcl_FSCopyFile, /* 440 */ + Tcl_FSCopyDirectory, /* 441 */ + Tcl_FSCreateDirectory, /* 442 */ + Tcl_FSDeleteFile, /* 443 */ + Tcl_FSLoadFile, /* 444 */ + Tcl_FSMatchInDirectory, /* 445 */ + Tcl_FSLink, /* 446 */ + Tcl_FSRemoveDirectory, /* 447 */ + Tcl_FSRenameFile, /* 448 */ + Tcl_FSLstat, /* 449 */ + Tcl_FSUtime, /* 450 */ + Tcl_FSFileAttrsGet, /* 451 */ + Tcl_FSFileAttrsSet, /* 452 */ + Tcl_FSFileAttrStrings, /* 453 */ + Tcl_FSStat, /* 454 */ + Tcl_FSAccess, /* 455 */ + Tcl_FSOpenFileChannel, /* 456 */ + Tcl_FSGetCwd, /* 457 */ + Tcl_FSChdir, /* 458 */ + Tcl_FSConvertToPathType, /* 459 */ + Tcl_FSJoinPath, /* 460 */ + Tcl_FSSplitPath, /* 461 */ + Tcl_FSEqualPaths, /* 462 */ + Tcl_FSGetNormalizedPath, /* 463 */ + Tcl_FSJoinToPath, /* 464 */ + Tcl_FSGetInternalRep, /* 465 */ + Tcl_FSGetTranslatedPath, /* 466 */ + Tcl_FSEvalFile, /* 467 */ + Tcl_FSNewNativePath, /* 468 */ + Tcl_FSGetNativePath, /* 469 */ + Tcl_FSFileSystemInfo, /* 470 */ + Tcl_FSPathSeparator, /* 471 */ + Tcl_FSListVolumes, /* 472 */ + Tcl_FSRegister, /* 473 */ + Tcl_FSUnregister, /* 474 */ + Tcl_FSData, /* 475 */ + Tcl_FSGetTranslatedStringPath, /* 476 */ + Tcl_FSGetFileSystemForPath, /* 477 */ + Tcl_FSGetPathType, /* 478 */ + Tcl_OutputBuffered, /* 479 */ + Tcl_FSMountsChanged, /* 480 */ + Tcl_EvalTokensStandard, /* 481 */ + Tcl_GetTime, /* 482 */ + Tcl_CreateObjTrace, /* 483 */ + Tcl_GetCommandInfoFromToken, /* 484 */ + Tcl_SetCommandInfoFromToken, /* 485 */ + Tcl_DbNewWideIntObj, /* 486 */ + Tcl_GetWideIntFromObj, /* 487 */ + Tcl_NewWideIntObj, /* 488 */ + Tcl_SetWideIntObj, /* 489 */ + Tcl_AllocStatBuf, /* 490 */ + Tcl_Seek, /* 491 */ + Tcl_Tell, /* 492 */ + Tcl_ChannelWideSeekProc, /* 493 */ }; /* !END!: Do not edit above this line. */ - diff --git a/tcl/generic/tclStubLib.c b/tcl/generic/tclStubLib.c index 048fdd4d85f..b00211d2e77 100644 --- a/tcl/generic/tclStubLib.c +++ b/tcl/generic/tclStubLib.c @@ -80,13 +80,13 @@ HasStubSupport (interp) #undef Tcl_InitStubs #endif -char * +CONST char * Tcl_InitStubs (interp, version, exact) Tcl_Interp *interp; - char *version; + CONST char *version; int exact; { - char *actualVersion; + CONST char *actualVersion; TclStubs *tmp; if (!tclStubsPtr) { diff --git a/tcl/generic/tclTest.c b/tcl/generic/tclTest.c index 99f80d68bf1..20071d3d008 100644 --- a/tcl/generic/tclTest.c +++ b/tcl/generic/tclTest.c @@ -17,14 +17,25 @@ */ #define TCL_TEST - #include "tclInt.h" #include "tclPort.h" + +/* + * Required for Testregexp*Cmd + */ #include "tclRegexp.h" -#include "tclIO.h" + +/* + * Required for TestlocaleCmd + */ #include <locale.h> /* + * Required for the TestChannelCmd and TestChannelEventCmd + */ +#include "tclIO.h" + +/* * Declare external functions used in Windows tests. */ @@ -95,6 +106,12 @@ typedef struct TclEncoding { static int freeCount; /* + * Boolean flag used by the "testsetmainloop" and "testexitmainloop" + * commands. + */ +static int exitMainLoop = 0; + +/* * Forward declarations for procedures defined later in this file: */ @@ -106,9 +123,9 @@ static void CleanupTestSetassocdataTests _ANSI_ARGS_(( static void CmdDelProc1 _ANSI_ARGS_((ClientData clientData)); static void CmdDelProc2 _ANSI_ARGS_((ClientData clientData)); static int CmdProc1 _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); + Tcl_Interp *interp, int argc, CONST char **argv)); static int CmdProc2 _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); + Tcl_Interp *interp, int argc, CONST char **argv)); static void CmdTraceDeleteProc _ANSI_ARGS_(( ClientData clientData, Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *cmdProc, @@ -120,14 +137,14 @@ static void CmdTraceProc _ANSI_ARGS_((ClientData clientData, int argc, char **argv)); static int CreatedCommandProc _ANSI_ARGS_(( ClientData clientData, Tcl_Interp *interp, - int argc, char **argv)); + int argc, CONST char **argv)); static int CreatedCommandProc2 _ANSI_ARGS_(( ClientData clientData, Tcl_Interp *interp, - int argc, char **argv)); + int argc, CONST char **argv)); static void DelCallbackProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp)); static int DelCmdProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); + Tcl_Interp *interp, int argc, CONST char **argv)); static void DelDeleteProc _ANSI_ARGS_((ClientData clientData)); static void EncodingFreeProc _ANSI_ARGS_((ClientData clientData)); static int EncodingToUtfProc _ANSI_ARGS_((ClientData clientData, @@ -143,18 +160,29 @@ static int EncodingFromUtfProc _ANSI_ARGS_((ClientData clientData, static void ExitProcEven _ANSI_ARGS_((ClientData clientData)); static void ExitProcOdd _ANSI_ARGS_((ClientData clientData)); static int GetTimesCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); + Tcl_Interp *interp, int argc, CONST char **argv)); +static void MainLoop _ANSI_ARGS_((void)); static int NoopCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); + Tcl_Interp *interp, int argc, CONST char **argv)); static int NoopObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +static int ObjTraceProc _ANSI_ARGS_(( ClientData clientData, + Tcl_Interp* interp, + int level, + CONST char* command, + Tcl_Command commandToken, + int objc, + Tcl_Obj *CONST objv[] )); +static void ObjTraceDeleteProc _ANSI_ARGS_(( ClientData )); static void PrintParse _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Parse *parsePtr)); + Tcl_Parse *parsePtr)); static void SpecialFree _ANSI_ARGS_((char *blockPtr)); static int StaticInitProc _ANSI_ARGS_((Tcl_Interp *interp)); static int TestaccessprocCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); + Tcl_Interp *interp, int argc, CONST char **argv)); +static int PretendTclpAccess _ANSI_ARGS_((CONST char *path, + int mode)); static int TestAccessProc1 _ANSI_ARGS_((CONST char *path, int mode)); static int TestAccessProc2 _ANSI_ARGS_((CONST char *path, @@ -162,25 +190,25 @@ static int TestAccessProc2 _ANSI_ARGS_((CONST char *path, static int TestAccessProc3 _ANSI_ARGS_((CONST char *path, int mode)); static int TestasyncCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); + Tcl_Interp *interp, int argc, CONST char **argv)); static int TestcmdinfoCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); + Tcl_Interp *interp, int argc, CONST char **argv)); static int TestcmdtokenCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); + Tcl_Interp *interp, int argc, CONST char **argv)); static int TestcmdtraceCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); + Tcl_Interp *interp, int argc, CONST char **argv)); static int TestchmodCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); + Tcl_Interp *interp, int argc, CONST char **argv)); static int TestcreatecommandCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); + Tcl_Interp *interp, int argc, CONST char **argv)); static int TestdcallCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); + Tcl_Interp *interp, int argc, CONST char **argv)); static int TestdelCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); + Tcl_Interp *interp, int argc, CONST char **argv)); static int TestdelassocdataCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); + Tcl_Interp *interp, int argc, CONST char **argv)); static int TestdstringCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); + Tcl_Interp *interp, int argc, CONST char **argv)); static int TestencodingObjCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); @@ -191,29 +219,31 @@ static int TestevalobjvObjCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TestexithandlerCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); + Tcl_Interp *interp, int argc, CONST char **argv)); static int TestexprlongCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); + Tcl_Interp *interp, int argc, CONST char **argv)); static int TestexprparserObjCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TestexprstringCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); + Tcl_Interp *interp, int argc, CONST char **argv)); static int TestfileCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +static int TestfilelinkCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TestfeventCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); + Tcl_Interp *interp, int argc, CONST char **argv)); static int TestgetassocdataCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); + Tcl_Interp *interp, int argc, CONST char **argv)); static int TestgetplatformCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); + Tcl_Interp *interp, int argc, CONST char **argv)); static int TestgetvarfullnameCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TestinterpdeleteCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); + Tcl_Interp *interp, int argc, CONST char **argv)); static int TestlinkCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); + Tcl_Interp *interp, int argc, CONST char **argv)); static int TestlocaleCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); @@ -223,14 +253,26 @@ static int TestMathFunc _ANSI_ARGS_((ClientData clientData, static int TestMathFunc2 _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr)); -static Tcl_Channel TestOpenFileChannelProc1 _ANSI_ARGS_((Tcl_Interp *interp, - char *filename, char *modeString, int permissions)); -static Tcl_Channel TestOpenFileChannelProc2 _ANSI_ARGS_((Tcl_Interp *interp, - char *filename, char *modeString, int permissions)); -static Tcl_Channel TestOpenFileChannelProc3 _ANSI_ARGS_((Tcl_Interp *interp, - char *filename, char *modeString, int permissions)); +static int TestmainthreadCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, CONST char **argv)); +static int TestsetmainloopCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, CONST char **argv)); +static int TestexitmainloopCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, CONST char **argv)); +static Tcl_Channel PretendTclpOpenFileChannel _ANSI_ARGS_(( + Tcl_Interp *interp, CONST char *fileName, + CONST char *modeString, int permissions)); +static Tcl_Channel TestOpenFileChannelProc1 _ANSI_ARGS_(( + Tcl_Interp *interp, CONST char *fileName, + CONST char *modeString, int permissions)); +static Tcl_Channel TestOpenFileChannelProc2 _ANSI_ARGS_(( + Tcl_Interp *interp, CONST char *fileName, + CONST char *modeString, int permissions)); +static Tcl_Channel TestOpenFileChannelProc3 _ANSI_ARGS_(( + Tcl_Interp *interp, CONST char *fileName, + CONST char *modeString, int permissions)); static int TestpanicCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); + Tcl_Interp *interp, int argc, CONST char **argv)); static int TestparserObjCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); @@ -250,21 +292,21 @@ static int TestsaveresultCmd _ANSI_ARGS_((ClientData dummy, Tcl_Obj *CONST objv[])); static void TestsaveresultFree _ANSI_ARGS_((char *blockPtr)); static int TestsetassocdataCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); + Tcl_Interp *interp, int argc, CONST char **argv)); static int TestsetCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); + Tcl_Interp *interp, int argc, CONST char **argv)); static int TestsetobjerrorcodeCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -static int TestopenfilechannelprocCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); +static int TestopenfilechannelprocCmd _ANSI_ARGS_(( + ClientData dummy, Tcl_Interp *interp, int argc, + CONST char **argv)); static int TestsetplatformCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); -static int TestsetrecursionlimitCmd _ANSI_ARGS_(( - ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[])); + Tcl_Interp *interp, int argc, CONST char **argv)); static int TeststaticpkgCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); + Tcl_Interp *interp, int argc, CONST char **argv)); +static int PretendTclpStat _ANSI_ARGS_((CONST char *path, + struct stat *buf)); static int TestStatProc1 _ANSI_ARGS_((CONST char *path, struct stat *buf)); static int TestStatProc2 _ANSI_ARGS_((CONST char *path, @@ -272,16 +314,111 @@ static int TestStatProc2 _ANSI_ARGS_((CONST char *path, static int TestStatProc3 _ANSI_ARGS_((CONST char *path, struct stat *buf)); static int TeststatprocCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); + Tcl_Interp *interp, int argc, CONST char **argv)); static int TesttranslatefilenameCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); + Tcl_Interp *interp, int argc, CONST char **argv)); static int TestupvarCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); -static int TestChannelCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); -static int TestChannelEventCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); + Tcl_Interp *interp, int argc, CONST char **argv)); +static int TestWrongNumArgsObjCmd _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[])); +static int TestGetIndexFromObjStructObjCmd _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[])); +static int TestChannelCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, CONST char **argv)); +static int TestChannelEventCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, CONST char **argv)); +/* Filesystem testing */ + +static int TestFilesystemObjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); + +static void TestReport _ANSI_ARGS_((CONST char* cmd, Tcl_Obj* arg1, Tcl_Obj* arg2)); + +static Tcl_Obj *TestReportGetNativePath(Tcl_Obj* pathObjPtr); + +static int TestReportStat _ANSI_ARGS_ ((Tcl_Obj *path, + Tcl_StatBuf *buf)); +static int TestReportAccess _ANSI_ARGS_ ((Tcl_Obj *path, + int mode)); +static Tcl_Channel TestReportOpenFileChannel _ANSI_ARGS_ (( + Tcl_Interp *interp, Tcl_Obj *fileName, + int mode, int permissions)); +static int TestReportMatchInDirectory _ANSI_ARGS_ (( + Tcl_Interp *interp, Tcl_Obj *resultPtr, + Tcl_Obj *dirPtr, CONST char *pattern, + Tcl_GlobTypeData *types)); +static int TestReportChdir _ANSI_ARGS_ ((Tcl_Obj *dirName)); +static int TestReportLstat _ANSI_ARGS_ ((Tcl_Obj *path, + Tcl_StatBuf *buf)); +static int TestReportCopyFile _ANSI_ARGS_ ((Tcl_Obj *src, + Tcl_Obj *dst)); +static int TestReportDeleteFile _ANSI_ARGS_ ((Tcl_Obj *path)); +static int TestReportRenameFile _ANSI_ARGS_ ((Tcl_Obj *src, + Tcl_Obj *dst)); +static int TestReportCreateDirectory _ANSI_ARGS_ ((Tcl_Obj *path)); +static int TestReportCopyDirectory _ANSI_ARGS_ ((Tcl_Obj *src, + Tcl_Obj *dst, Tcl_Obj **errorPtr)); +static int TestReportRemoveDirectory _ANSI_ARGS_ ((Tcl_Obj *path, + int recursive, Tcl_Obj **errorPtr)); +static int TestReportLoadFile _ANSI_ARGS_ ((Tcl_Interp *interp, + Tcl_Obj *fileName, + Tcl_LoadHandle *handlePtr, + Tcl_FSUnloadFileProc **unloadProcPtr)); +static Tcl_Obj * TestReportLink _ANSI_ARGS_ ((Tcl_Obj *path, + Tcl_Obj *to, int linkType)); +static CONST char** TestReportFileAttrStrings _ANSI_ARGS_ (( + Tcl_Obj *fileName, Tcl_Obj **objPtrRef)); +static int TestReportFileAttrsGet _ANSI_ARGS_ ((Tcl_Interp *interp, + int index, Tcl_Obj *fileName, Tcl_Obj **objPtrRef)); +static int TestReportFileAttrsSet _ANSI_ARGS_ ((Tcl_Interp *interp, + int index, Tcl_Obj *fileName, Tcl_Obj *objPtr)); +static int TestReportUtime _ANSI_ARGS_ ((Tcl_Obj *fileName, + struct utimbuf *tval)); +static int TestReportNormalizePath _ANSI_ARGS_ (( + Tcl_Interp *interp, Tcl_Obj *pathPtr, + int nextCheckpoint)); +static int TestReportInFilesystem _ANSI_ARGS_ ((Tcl_Obj *pathPtr, ClientData *clientDataPtr)); +static void TestReportFreeInternalRep _ANSI_ARGS_ ((ClientData clientData)); +static ClientData TestReportDupInternalRep _ANSI_ARGS_ ((ClientData clientData)); + +static Tcl_Filesystem testReportingFilesystem = { + "reporting", + sizeof(Tcl_Filesystem), + TCL_FILESYSTEM_VERSION_1, + &TestReportInFilesystem, /* path in */ + &TestReportDupInternalRep, + &TestReportFreeInternalRep, + NULL, /* native to norm */ + NULL, /* convert to native */ + &TestReportNormalizePath, + NULL, /* path type */ + NULL, /* separator */ + &TestReportStat, + &TestReportAccess, + &TestReportOpenFileChannel, + &TestReportMatchInDirectory, + &TestReportUtime, + &TestReportLink, + NULL /* list volumes */, + &TestReportFileAttrStrings, + &TestReportFileAttrsGet, + &TestReportFileAttrsSet, + &TestReportCreateDirectory, + &TestReportRemoveDirectory, + &TestReportDeleteFile, + &TestReportCopyFile, + &TestReportRenameFile, + &TestReportCopyDirectory, + &TestReportLstat, + &TestReportLoadFile, + NULL /* cwd */, + &TestReportChdir +}; + /* * External (platform specific) initialization routine, these declarations * explicitly don't use EXTERN since this code does not get compiled @@ -315,7 +452,15 @@ Tcltest_Init(interp) Tcl_Interp *interp; /* Interpreter for application. */ { Tcl_ValueType t3ArgTypes[2]; - + + Tcl_Obj *listPtr; + Tcl_Obj **objv; + int objc, index; + static CONST char *specialOptions[] = { + "-appinitprocerror", "-appinitprocdeleteinterp", + "-appinitprocclosestderr", "-appinitprocsetrcfile", (char *) NULL + }; + if (Tcl_PkgProvide(interp, "Tcltest", TCL_VERSION) == TCL_ERROR) { return TCL_ERROR; } @@ -330,6 +475,13 @@ Tcltest_Init(interp) (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testgetindexfromobjstruct", + TestGetIndexFromObjStructObjCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testaccessproc", TestaccessprocCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testasync", TestasyncCmd, (ClientData) 0, @@ -373,7 +525,9 @@ Tcltest_Init(interp) (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testfevent", TestfeventCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateCommand(interp, "testfile", TestfileCmd, + Tcl_CreateObjCommand(interp, "testfilelink", TestfilelinkCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testfile", TestfileCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testgetassocdata", TestgetassocdataCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); @@ -414,9 +568,6 @@ Tcltest_Init(interp) (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateObjCommand(interp, "testsetrecursionlimit", - TestsetrecursionlimitCmd, - (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testtranslatefilename", @@ -430,6 +581,12 @@ Tcltest_Init(interp) (ClientData) 345); Tcl_CreateCommand(interp, "teststatproc", TeststatprocCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testmainthread", TestmainthreadCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testsetmainloop", TestsetmainloopCmd, + (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testexitmainloop", TestexitmainloopCmd, + (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); t3ArgTypes[0] = TCL_EITHER; t3ArgTypes[1] = TCL_EITHER; Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2, @@ -442,6 +599,42 @@ Tcltest_Init(interp) #endif /* + * Check for special options used in ../tests/main.test + */ + + listPtr = Tcl_GetVar2Ex(interp, "argv", NULL, TCL_GLOBAL_ONLY); + if (listPtr != NULL) { + if (Tcl_ListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { + return TCL_ERROR; + } + if (objc && (Tcl_GetIndexFromObj(NULL, objv[0], specialOptions, NULL, + TCL_EXACT, &index) == TCL_OK)) { + switch (index) { + case 0: { + return TCL_ERROR; + } + case 1: { + Tcl_DeleteInterp(interp); + return TCL_ERROR; + } + case 2: { + int mode; + Tcl_UnregisterChannel(interp, + Tcl_GetChannel(interp, "stderr", &mode)); + return TCL_ERROR; + } + case 3: { + if (objc-1) { + Tcl_SetVar2Ex(interp, "tcl_rcFileName", NULL, + objv[1], TCL_GLOBAL_ONLY); + } + return TCL_ERROR; + } + } + } + } + + /* * And finally add any platform specific test commands. */ @@ -471,7 +664,7 @@ TestasyncCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + CONST char **argv; /* Argument strings. */ { TestAsyncHandler *asyncPtr, *prevPtr; int id, code; @@ -545,7 +738,7 @@ TestasyncCmd(dummy, interp, argc, argv) break; } } - Tcl_SetResult(interp, argv[3], TCL_VOLATILE); + Tcl_SetResult(interp, (char *)argv[3], TCL_VOLATILE); return code; } else { Tcl_AppendResult(interp, "bad option \"", argv[1], @@ -564,17 +757,25 @@ AsyncHandlerProc(clientData, interp, code) int code; /* Current return code from command. */ { TestAsyncHandler *asyncPtr = (TestAsyncHandler *) clientData; - char *listArgv[4]; - char string[TCL_INTEGER_SPACE], *cmd; + CONST char *listArgv[4], *cmd; + char string[TCL_INTEGER_SPACE]; TclFormatInt(string, code); listArgv[0] = asyncPtr->command; - listArgv[1] = Tcl_GetStringResult(interp); + listArgv[1] = Tcl_GetString(Tcl_GetObjResult(interp)); listArgv[2] = string; listArgv[3] = NULL; cmd = Tcl_Merge(3, listArgv); - code = Tcl_Eval(interp, cmd); - ckfree(cmd); + if (interp != NULL) { + code = Tcl_Eval(interp, cmd); + } else { + /* + * this should not happen, but by definition of how async + * handlers are invoked, it's possible. Better error + * checking is needed here. + */ + } + ckfree((char *)cmd); return code; } @@ -602,7 +803,7 @@ TestcmdinfoCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + CONST char **argv; /* Argument strings. */ { Tcl_CmdInfo info; @@ -675,7 +876,7 @@ CmdProc1(clientData, interp, argc, argv) ClientData clientData; /* String to return. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + CONST char **argv; /* Argument strings. */ { Tcl_AppendResult(interp, "CmdProc1 ", (char *) clientData, (char *) NULL); @@ -688,7 +889,7 @@ CmdProc2(clientData, interp, argc, argv) ClientData clientData; /* String to return. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + CONST char **argv; /* Argument strings. */ { Tcl_AppendResult(interp, "CmdProc2 ", (char *) clientData, (char *) NULL); @@ -737,10 +938,10 @@ TestcmdtokenCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + CONST char **argv; /* Argument strings. */ { Tcl_Command token; - long int l; + int *l; char buf[30]; if (argc != 3) { @@ -751,12 +952,12 @@ TestcmdtokenCmd(dummy, interp, argc, argv) if (strcmp(argv[1], "create") == 0) { token = Tcl_CreateCommand(interp, argv[2], CmdProc1, (ClientData) "original", (Tcl_CmdDeleteProc *) NULL); - sprintf(buf, "%lx", (long int) token); + sprintf(buf, "%p", (VOID *)token); Tcl_SetResult(interp, buf, TCL_VOLATILE); } else if (strcmp(argv[1], "name") == 0) { Tcl_Obj *objPtr; - - if (sscanf(argv[2], "%lx", &l) != 1) { + + if (sscanf(argv[2], "%p", &l) != 1) { Tcl_AppendResult(interp, "bad command token \"", argv[2], "\"", (char *) NULL); return TCL_ERROR; @@ -764,7 +965,7 @@ TestcmdtokenCmd(dummy, interp, argc, argv) objPtr = Tcl_NewObj(); Tcl_GetCommandFullName(interp, (Tcl_Command) l, objPtr); - + Tcl_AppendElement(interp, Tcl_GetCommandName(interp, (Tcl_Command) l)); Tcl_AppendElement(interp, Tcl_GetString(objPtr)); @@ -801,7 +1002,7 @@ TestcmdtraceCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + CONST char **argv; /* Argument strings. */ { Tcl_DString buffer; int result; @@ -834,9 +1035,30 @@ TestcmdtraceCmd(dummy, interp, argc, argv) cmdTrace = Tcl_CreateTrace(interp, 50000, (Tcl_CmdTraceProc *) CmdTraceDeleteProc, (ClientData) NULL); Tcl_Eval(interp, argv[2]); + } else if ( strcmp(argv[1], "resulttest" ) == 0 ) { + /* Create an object-based trace, then eval a script. This is used + * to test return codes other than TCL_OK from the trace engine. + */ + static int deleteCalled; + deleteCalled = 0; + cmdTrace = Tcl_CreateObjTrace( interp, 50000, + TCL_ALLOW_INLINE_COMPILATION, + ObjTraceProc, + (ClientData) &deleteCalled, + ObjTraceDeleteProc ); + result = Tcl_Eval( interp, argv[ 2 ] ); + Tcl_DeleteTrace( interp, cmdTrace ); + if ( !deleteCalled ) { + Tcl_SetResult( interp, "Delete wasn't called", TCL_STATIC ); + return TCL_ERROR; + } else { + return result; + } + } else { Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be tracetest or deletetest", (char *) NULL); + "\": must be tracetest, deletetest or resulttest", + (char *) NULL); return TCL_ERROR; } return TCL_OK; @@ -893,6 +1115,41 @@ CmdTraceDeleteProc(clientData, interp, level, command, cmdProc, Tcl_DeleteTrace(interp, cmdTrace); } +static int +ObjTraceProc( clientData, interp, level, command, token, objc, objv ) + ClientData clientData; /* unused */ + 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 */ +{ + CONST char* word = Tcl_GetString( objv[ 0 ] ); + if ( !strcmp( word, "Error" ) ) { + Tcl_SetObjResult( interp, Tcl_NewStringObj( command, -1 ) ); + return TCL_ERROR; + } else if ( !strcmp( word, "Break" ) ) { + return TCL_BREAK; + } else if ( !strcmp( word, "Continue" ) ) { + return TCL_CONTINUE; + } else if ( !strcmp( word, "Return" ) ) { + return TCL_RETURN; + } else if ( !strcmp( word, "OtherStatus" ) ) { + return 6; + } else { + return TCL_OK; + } +} + +static void +ObjTraceDeleteProc( clientData ) + ClientData clientData; +{ + int * intPtr = (int *) clientData; + *intPtr = 1; /* Record that the trace was deleted */ +} + /* *---------------------------------------------------------------------- * @@ -919,7 +1176,7 @@ TestcreatecommandCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + CONST char **argv; /* Argument strings. */ { if (argc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], @@ -952,7 +1209,7 @@ CreatedCommandProc(clientData, interp, argc, argv) ClientData clientData; /* String to return. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + CONST char **argv; /* Argument strings. */ { Tcl_CmdInfo info; int found; @@ -974,7 +1231,7 @@ CreatedCommandProc2(clientData, interp, argc, argv) ClientData clientData; /* String to return. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + CONST char **argv; /* Argument strings. */ { Tcl_CmdInfo info; int found; @@ -1013,7 +1270,7 @@ TestdcallCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + CONST char **argv; /* Argument strings. */ { int i, id; @@ -1079,7 +1336,7 @@ TestdelCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + CONST char **argv; /* Argument strings. */ { DelCmd *dPtr; Tcl_Interp *slave; @@ -1109,7 +1366,7 @@ DelCmdProc(clientData, interp, argc, argv) ClientData clientData; /* String result to return. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + CONST char **argv; /* Argument strings. */ { DelCmd *dPtr = (DelCmd *) clientData; @@ -1154,7 +1411,7 @@ TestdelassocdataCmd(clientData, interp, argc, argv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + CONST char **argv; /* Argument strings. */ { if (argc != 2) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], @@ -1188,7 +1445,7 @@ TestdstringCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + CONST char **argv; /* Argument strings. */ { int count; @@ -1323,7 +1580,7 @@ TestencodingObjCmd(dummy, interp, objc, objv) int index, length; char *string; TclEncoding *encodingPtr; - static char *optionStrings[] = { + static CONST char *optionStrings[] = { "create", "delete", "path", NULL }; @@ -1595,7 +1852,7 @@ TestexithandlerCmd(clientData, interp, argc, argv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + CONST char **argv; /* Argument strings. */ { int value; @@ -1663,7 +1920,7 @@ TestexprlongCmd(clientData, interp, argc, argv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + CONST char **argv; /* Argument strings. */ { long exprResult; char buf[4 + TCL_INTEGER_SPACE]; @@ -1700,7 +1957,7 @@ TestexprstringCmd(clientData, interp, argc, argv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + CONST char **argv; /* Argument strings. */ { if (argc != 2) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], @@ -1713,6 +1970,74 @@ TestexprstringCmd(clientData, interp, argc, argv) /* *---------------------------------------------------------------------- * + * TestfilelinkCmd -- + * + * This procedure implements the "testfilelink" command. It is used + * to test the effects of creating and manipulating filesystem links + * in Tcl. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May create a link on disk. + * + *---------------------------------------------------------------------- + */ + +static int +TestfilelinkCmd(clientData, interp, objc, objv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* The argument objects. */ +{ + Tcl_Obj *contents; + + if (objc < 2 || objc > 3) { + Tcl_WrongNumArgs(interp, 1, objv, "source ?target?"); + return TCL_ERROR; + } + + if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) { + return TCL_ERROR; + } + + if (objc == 3) { + /* Create link from source to target */ + contents = Tcl_FSLink(objv[1], objv[2], + TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK); + if (contents == NULL) { + Tcl_AppendResult(interp, "could not create link from \"", + Tcl_GetString(objv[1]), "\" to \"", + Tcl_GetString(objv[2]), "\": ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + } else { + /* Read link */ + contents = Tcl_FSLink(objv[1], NULL, 0); + if (contents == NULL) { + Tcl_AppendResult(interp, "could not read link \"", + Tcl_GetString(objv[1]), "\": ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + } + Tcl_SetObjResult(interp, contents); + if (objc == 2) { + /* + * If we are creating a link, this will actually just + * be objv[3], and we don't own it + */ + Tcl_DecrRefCount(contents); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TestgetassocdataCmd -- * * This procedure implements the "testgetassocdata" command. It is @@ -1732,7 +2057,7 @@ TestgetassocdataCmd(clientData, interp, argc, argv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + CONST char **argv; /* Argument strings. */ { char *res; @@ -1770,9 +2095,9 @@ TestgetplatformCmd(clientData, interp, argc, argv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + CONST char **argv; /* Argument strings. */ { - static char *platformStrings[] = { "unix", "mac", "windows" }; + static CONST char *platformStrings[] = { "unix", "mac", "windows" }; TclPlatformType *platform; #ifdef __WIN32__ @@ -1815,7 +2140,7 @@ TestinterpdeleteCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + CONST char **argv; /* Argument strings. */ { Tcl_Interp *slaveToDelete; @@ -1824,11 +2149,6 @@ TestinterpdeleteCmd(dummy, interp, argc, argv) " path\"", (char *) NULL); return TCL_ERROR; } - if (argv[1][0] == '\0') { - Tcl_AppendResult(interp, "cannot delete current interpreter", - (char *) NULL); - return TCL_ERROR; - } slaveToDelete = Tcl_GetSlave(interp, argv[1]); if (slaveToDelete == (Tcl_Interp *) NULL) { return TCL_ERROR; @@ -1861,27 +2181,36 @@ TestlinkCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + CONST char **argv; /* Argument strings. */ { static int intVar = 43; static int boolVar = 4; static double realVar = 1.23; + static Tcl_WideInt wideVar = Tcl_LongAsWide(79); static char *stringVar = NULL; static int created = 0; - char buffer[TCL_DOUBLE_SPACE]; + char buffer[2*TCL_DOUBLE_SPACE]; int writable, flag; + Tcl_Obj *tmp; if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " option ?arg arg arg?\"", (char *) NULL); + " option ?arg arg arg arg arg?\"", (char *) NULL); return TCL_ERROR; } if (strcmp(argv[1], "create") == 0) { + if (argc != 7) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " ", argv[1], + " intRO realRO boolRO stringRO wideRO\"", (char *) NULL); + return TCL_ERROR; + } if (created) { Tcl_UnlinkVar(interp, "int"); Tcl_UnlinkVar(interp, "real"); Tcl_UnlinkVar(interp, "bool"); Tcl_UnlinkVar(interp, "string"); + Tcl_UnlinkVar(interp, "wide"); } created = 1; if (Tcl_GetBoolean(interp, argv[2], &writable) != TCL_OK) { @@ -1916,11 +2245,20 @@ TestlinkCmd(dummy, interp, argc, argv) 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, + TCL_LINK_WIDE_INT | flag) != TCL_OK) { + return TCL_ERROR; + } } else if (strcmp(argv[1], "delete") == 0) { Tcl_UnlinkVar(interp, "int"); Tcl_UnlinkVar(interp, "real"); Tcl_UnlinkVar(interp, "bool"); Tcl_UnlinkVar(interp, "string"); + Tcl_UnlinkVar(interp, "wide"); created = 0; } else if (strcmp(argv[1], "get") == 0) { TclFormatInt(buffer, intVar); @@ -1930,11 +2268,18 @@ TestlinkCmd(dummy, interp, argc, argv) TclFormatInt(buffer, boolVar); Tcl_AppendElement(interp, buffer); Tcl_AppendElement(interp, (stringVar == NULL) ? "-" : stringVar); + /* + * Wide ints only have an object-based interface. + */ + tmp = Tcl_NewWideIntObj(wideVar); + Tcl_AppendElement(interp, Tcl_GetString(tmp)); + Tcl_DecrRefCount(tmp); } else if (strcmp(argv[1], "set") == 0) { - if (argc != 6) { + if (argc != 7) { Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " ", argv[1], - "intValue realValue boolValue stringValue\"", (char *) NULL); + argv[0], " ", argv[1], + " intValue realValue boolValue stringValue wideValue\"", + (char *) NULL); return TCL_ERROR; } if (argv[2][0] != 0) { @@ -1963,11 +2308,20 @@ TestlinkCmd(dummy, interp, argc, argv) strcpy(stringVar, argv[5]); } } + if (argv[6][0] != 0) { + tmp = Tcl_NewStringObj(argv[6], -1); + if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) { + Tcl_DecrRefCount(tmp); + return TCL_ERROR; + } + Tcl_DecrRefCount(tmp); + } } else if (strcmp(argv[1], "update") == 0) { - if (argc != 6) { + if (argc != 7) { Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " ", argv[1], - "intValue realValue boolValue stringValue\"", (char *) NULL); + argv[0], " ", argv[1], + "intValue realValue boolValue stringValue wideValue\"", + (char *) NULL); return TCL_ERROR; } if (argv[2][0] != 0) { @@ -2000,6 +2354,15 @@ TestlinkCmd(dummy, interp, argc, argv) } Tcl_UpdateLinkedVar(interp, "string"); } + if (argv[6][0] != 0) { + tmp = Tcl_NewStringObj(argv[6], -1); + if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) { + Tcl_DecrRefCount(tmp); + return TCL_ERROR; + } + Tcl_DecrRefCount(tmp); + Tcl_UpdateLinkedVar(interp, "wide"); + } } else { Tcl_AppendResult(interp, "bad option \"", argv[1], "\": should be create, delete, get, set, or update", @@ -2036,7 +2399,7 @@ TestlocaleCmd(clientData, interp, objc, objv) int index; char *locale; - static char *optionStrings[] = { + static CONST char *optionStrings[] = { "ctype", "numeric", "time", "collate", "monetary", "all", NULL }; @@ -2148,8 +2511,16 @@ TestMathFunc2(clientData, interp, args, resultPtr) resultPtr->type = TCL_DOUBLE; resultPtr->doubleValue = ((d0 > d1)? d0 : d1); +#ifndef TCL_WIDE_INT_IS_LONG + } 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); +#endif } else { - Tcl_SetResult(interp, "T2: wrong type for arg 2", TCL_STATIC); + Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC); result = TCL_ERROR; } } else if (args[0].type == TCL_DOUBLE) { @@ -2165,12 +2536,44 @@ TestMathFunc2(clientData, interp, args, resultPtr) resultPtr->type = TCL_DOUBLE; resultPtr->doubleValue = ((d0 > d1)? d0 : d1); +#ifndef TCL_WIDE_INT_IS_LONG + } 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); +#endif + } else { + Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC); + result = TCL_ERROR; + } +#ifndef TCL_WIDE_INT_IS_LONG + } 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; + + resultPtr->type = TCL_DOUBLE; + resultPtr->doubleValue = ((d0 > d1)? d0 : d1); + } else if (args[1].type == TCL_WIDE_INT) { + Tcl_WideInt w1 = args[1].wideValue; + + resultPtr->type = TCL_WIDE_INT; + resultPtr->wideValue = ((w0 > w1)? w0 : w1); } else { - Tcl_SetResult(interp, "T2: wrong type for arg 2", TCL_STATIC); + Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC); result = TCL_ERROR; } +#endif } else { - Tcl_SetResult(interp, "T2: wrong type for arg 1", TCL_STATIC); + Tcl_SetResult(interp, "T3: wrong type for arg 1", TCL_STATIC); result = TCL_ERROR; } return result; @@ -2422,7 +2825,8 @@ TestparsevarObjCmd(clientData, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* The argument objects. */ { - char *name, *value, *termPtr; + CONST char *value; + CONST char *name, *termPtr; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "varName"); @@ -2521,7 +2925,7 @@ TestparsevarnameObjCmd(clientData, interp, objc, objv) */ /* ARGSUSED */ -int +static int TestregexpObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ @@ -2534,7 +2938,7 @@ TestregexpObjCmd(dummy, interp, objc, objv) char *string; Tcl_Obj *objPtr; Tcl_RegExpInfo info; - static char *options[] = { + static CONST char *options[] = { "-indices", "-nocase", "-about", "-expanded", "-line", "-linestop", "-lineanchor", "-xflags", @@ -2648,7 +3052,8 @@ TestregexpObjCmd(dummy, interp, objc, objv) Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); if (objc > 2 && (cflags®_EXPECT) && indices) { - char *varName, *value; + char *varName; + CONST char *value; int start, end; char info[TCL_INTEGER_SPACE * 2]; @@ -2858,7 +3263,7 @@ TestsetassocdataCmd(clientData, interp, argc, argv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + CONST char **argv; /* Argument strings. */ { char *buf; char *oldData; @@ -2911,7 +3316,7 @@ TestsetplatformCmd(clientData, interp, argc, argv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + CONST char **argv; /* Argument strings. */ { size_t length; TclPlatformType *platform; @@ -2946,47 +3351,6 @@ TestsetplatformCmd(clientData, interp, argc, argv) /* *---------------------------------------------------------------------- * - * TestsetrecursionlimitCmd -- - * - * This procedure implements the "testsetrecursionlimit" command. It is - * used to change the interp recursion limit (to test the effects - * of Tcl_SetRecursionLimit). - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Sets the interp's recursion limit. - * - *---------------------------------------------------------------------- - */ - -static int -TestsetrecursionlimitCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* The argument objects. */ -{ - int value; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "integer"); - return TCL_ERROR; - } - if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) { - return TCL_ERROR; - } - value = Tcl_SetRecursionLimit(interp, value); - Tcl_SetIntObj(Tcl_GetObjResult(interp), value); - return TCL_OK; -} - - - -/* - *---------------------------------------------------------------------- - * * TeststaticpkgCmd -- * * This procedure implements the "teststaticpkg" command. @@ -3007,7 +3371,7 @@ TeststaticpkgCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + CONST char **argv; /* Argument strings. */ { int safe, loaded; @@ -3058,10 +3422,10 @@ TesttranslatefilenameCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + CONST char **argv; /* Argument strings. */ { Tcl_DString buffer; - char *result; + CONST char *result; if (argc != 2) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", @@ -3100,7 +3464,7 @@ TestupvarCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + CONST char **argv; /* Argument strings. */ { int flags = 0; @@ -3192,7 +3556,7 @@ TestfeventCmd(clientData, interp, argc, argv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + CONST char **argv; /* Argument strings. */ { static Tcl_Interp *interp2 = NULL; int code; @@ -3224,7 +3588,7 @@ TestfeventCmd(clientData, interp, argc, argv) Tcl_DeleteInterp(interp2); } interp2 = Tcl_CreateInterp(); - return TCL_OK; + return Tcl_Init(interp2); } else if (strcmp(argv[1], "delete") == 0) { if (interp2 != NULL) { Tcl_DeleteInterp(interp2); @@ -3264,9 +3628,9 @@ TestpanicCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + CONST char **argv; /* Argument strings. */ { - char *argString; + CONST char *argString; /* * Put the arguments into a var args structure @@ -3275,7 +3639,7 @@ TestpanicCmd(dummy, interp, argc, argv) argString = Tcl_Merge(argc-1, argv+1); panic(argString); - ckfree(argString); + ckfree((char *)argString); return TCL_OK; } @@ -3304,7 +3668,7 @@ TestchmodCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + CONST char **argv; /* Argument strings. */ { int i, mode; char *rest; @@ -3323,13 +3687,14 @@ TestchmodCmd(dummy, interp, argc, argv) for (i = 2; i < argc; i++) { Tcl_DString buffer; + CONST char *translated; - argv[i] = Tcl_TranslateFileName(interp, argv[i], &buffer); - if (argv[i] == NULL) { + translated = Tcl_TranslateFileName(interp, argv[i], &buffer); + if (translated == NULL) { return TCL_ERROR; } - if (chmod(argv[i], (unsigned) mode) != 0) { - Tcl_AppendResult(interp, argv[i], ": ", Tcl_PosixError(interp), + if (chmod(translated, (unsigned) mode) != 0) { + Tcl_AppendResult(interp, translated, ": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } @@ -3342,11 +3707,12 @@ static int TestfileCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int argc; /* Number of arguments. */ + Tcl_Obj *CONST argv[]; /* The argument objects. */ { int force, i, j, result; - Tcl_DString error, name[2]; + Tcl_Obj *error = NULL; + char *subcmd; if (argc < 3) { return TCL_ERROR; @@ -3354,54 +3720,51 @@ TestfileCmd(dummy, interp, argc, argv) force = 0; i = 2; - if (strcmp(argv[2], "-force") == 0) { + if (strcmp(Tcl_GetString(argv[2]), "-force") == 0) { force = 1; i = 3; } - Tcl_DStringInit(&name[0]); - Tcl_DStringInit(&name[1]); - Tcl_DStringInit(&error); - if (argc - i > 2) { return TCL_ERROR; } for (j = i; j < argc; j++) { - argv[j] = Tcl_TranslateFileName(interp, argv[j], &name[j - i]); - if (argv[j] == NULL) { + if (Tcl_FSGetTranslatedPath(interp, argv[j]) == NULL) { return TCL_ERROR; } } - if (strcmp(argv[1], "mv") == 0) { - result = TclpRenameFile(argv[i], argv[i + 1]); - } else if (strcmp(argv[1], "cp") == 0) { - result = TclpCopyFile(argv[i], argv[i + 1]); - } else if (strcmp(argv[1], "rm") == 0) { - result = TclpDeleteFile(argv[i]); - } else if (strcmp(argv[1], "mkdir") == 0) { - result = TclpCreateDirectory(argv[i]); - } else if (strcmp(argv[1], "cpdir") == 0) { - result = TclpCopyDirectory(argv[i], argv[i + 1], &error); - } else if (strcmp(argv[1], "rmdir") == 0) { - result = TclpRemoveDirectory(argv[i], force, &error); + subcmd = Tcl_GetString(argv[1]); + + if (strcmp(subcmd, "mv") == 0) { + result = TclpObjRenameFile(argv[i], argv[i + 1]); + } else if (strcmp(subcmd, "cp") == 0) { + result = TclpObjCopyFile(argv[i], argv[i + 1]); + } else if (strcmp(subcmd, "rm") == 0) { + result = TclpObjDeleteFile(argv[i]); + } else if (strcmp(subcmd, "mkdir") == 0) { + result = TclpObjCreateDirectory(argv[i]); + } else if (strcmp(subcmd, "cpdir") == 0) { + result = TclpObjCopyDirectory(argv[i], argv[i + 1], &error); + } else if (strcmp(subcmd, "rmdir") == 0) { + result = TclpObjRemoveDirectory(argv[i], force, &error); } else { result = TCL_ERROR; goto end; } if (result != TCL_OK) { - if (Tcl_DStringValue(&error)[0] != '\0') { - Tcl_AppendResult(interp, Tcl_DStringValue(&error), " ", NULL); + if (error != NULL) { + if (Tcl_GetString(error)[0] != '\0') { + Tcl_AppendResult(interp, Tcl_GetString(error), " ", NULL); + } + Tcl_DecrRefCount(error); } Tcl_AppendResult(interp, Tcl_ErrnoId(), (char *) NULL); } end: - Tcl_DStringFree(&error); - Tcl_DStringFree(&name[0]); - Tcl_DStringFree(&name[1]); return result; } @@ -3508,7 +3871,7 @@ GetTimesCmd(unused, interp, argc, argv) ClientData unused; /* Unused. */ Tcl_Interp *interp; /* The current interpreter. */ int argc; /* The number of arguments. */ - char **argv; /* The argument strings. */ + CONST char **argv; /* The argument strings. */ { Interp *iPtr = (Interp *) interp; int i, n; @@ -3516,59 +3879,59 @@ GetTimesCmd(unused, interp, argc, argv) Tcl_Time start, stop; Tcl_Obj *objPtr; Tcl_Obj **objv; - char *s; + CONST char *s; char newString[TCL_INTEGER_SPACE]; /* alloc & free 100000 times */ fprintf(stderr, "alloc & free 100000 6 word items\n"); - TclpGetTime(&start); + Tcl_GetTime(&start); for (i = 0; i < 100000; i++) { objPtr = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj)); ckfree((char *) objPtr); } - TclpGetTime(&stop); + Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); fprintf(stderr, " %.3f usec per alloc+free\n", timePer/100000); /* alloc 5000 times */ fprintf(stderr, "alloc 5000 6 word items\n"); objv = (Tcl_Obj **) ckalloc(5000 * sizeof(Tcl_Obj *)); - TclpGetTime(&start); + Tcl_GetTime(&start); for (i = 0; i < 5000; i++) { objv[i] = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj)); } - TclpGetTime(&stop); + Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); fprintf(stderr, " %.3f usec per alloc\n", timePer/5000); /* free 5000 times */ fprintf(stderr, "free 5000 6 word items\n"); - TclpGetTime(&start); + Tcl_GetTime(&start); for (i = 0; i < 5000; i++) { ckfree((char *) objv[i]); } - TclpGetTime(&stop); + Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); fprintf(stderr, " %.3f usec per free\n", timePer/5000); /* Tcl_NewObj 5000 times */ fprintf(stderr, "Tcl_NewObj 5000 times\n"); - TclpGetTime(&start); + Tcl_GetTime(&start); for (i = 0; i < 5000; i++) { objv[i] = Tcl_NewObj(); } - TclpGetTime(&stop); + Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); fprintf(stderr, " %.3f usec per Tcl_NewObj\n", timePer/5000); /* Tcl_DecrRefCount 5000 times */ fprintf(stderr, "Tcl_DecrRefCount 5000 times\n"); - TclpGetTime(&start); + Tcl_GetTime(&start); for (i = 0; i < 5000; i++) { objPtr = objv[i]; Tcl_DecrRefCount(objPtr); } - TclpGetTime(&stop); + Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); fprintf(stderr, " %.3f usec per Tcl_DecrRefCount\n", timePer/5000); ckfree((char *) objv); @@ -3576,24 +3939,24 @@ GetTimesCmd(unused, interp, argc, argv) /* TclGetString 100000 times */ fprintf(stderr, "TclGetStringFromObj of \"12345\" 100000 times\n"); objPtr = Tcl_NewStringObj("12345", -1); - TclpGetTime(&start); + Tcl_GetTime(&start); for (i = 0; i < 100000; i++) { (void) TclGetString(objPtr); } - TclpGetTime(&stop); + Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); fprintf(stderr, " %.3f usec per TclGetStringFromObj of \"12345\"\n", timePer/100000); /* Tcl_GetIntFromObj 100000 times */ fprintf(stderr, "Tcl_GetIntFromObj of \"12345\" 100000 times\n"); - TclpGetTime(&start); + Tcl_GetTime(&start); for (i = 0; i < 100000; i++) { if (Tcl_GetIntFromObj(interp, objPtr, &n) != TCL_OK) { return TCL_ERROR; } } - TclpGetTime(&stop); + Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); fprintf(stderr, " %.3f usec per Tcl_GetIntFromObj of \"12345\"\n", timePer/100000); @@ -3601,63 +3964,63 @@ GetTimesCmd(unused, interp, argc, argv) /* Tcl_GetInt 100000 times */ fprintf(stderr, "Tcl_GetInt of \"12345\" 100000 times\n"); - TclpGetTime(&start); + Tcl_GetTime(&start); for (i = 0; i < 100000; i++) { if (Tcl_GetInt(interp, "12345", &n) != TCL_OK) { return TCL_ERROR; } } - TclpGetTime(&stop); + Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); fprintf(stderr, " %.3f usec per Tcl_GetInt of \"12345\"\n", timePer/100000); /* sprintf 100000 times */ fprintf(stderr, "sprintf of 12345 100000 times\n"); - TclpGetTime(&start); + Tcl_GetTime(&start); for (i = 0; i < 100000; i++) { sprintf(newString, "%d", 12345); } - TclpGetTime(&stop); + Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); fprintf(stderr, " %.3f usec per sprintf of 12345\n", timePer/100000); /* hashtable lookup 100000 times */ fprintf(stderr, "hashtable lookup of \"gettimes\" 100000 times\n"); - TclpGetTime(&start); + Tcl_GetTime(&start); for (i = 0; i < 100000; i++) { (void) Tcl_FindHashEntry(&iPtr->globalNsPtr->cmdTable, "gettimes"); } - TclpGetTime(&stop); + Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); fprintf(stderr, " %.3f usec per hashtable lookup of \"gettimes\"\n", timePer/100000); /* Tcl_SetVar 100000 times */ fprintf(stderr, "Tcl_SetVar of \"12345\" 100000 times\n"); - TclpGetTime(&start); + Tcl_GetTime(&start); for (i = 0; i < 100000; i++) { s = Tcl_SetVar(interp, "a", "12345", TCL_LEAVE_ERR_MSG); if (s == NULL) { return TCL_ERROR; } } - TclpGetTime(&stop); + Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); fprintf(stderr, " %.3f usec per Tcl_SetVar of a to \"12345\"\n", timePer/100000); /* Tcl_GetVar 100000 times */ fprintf(stderr, "Tcl_GetVar of a==\"12345\" 100000 times\n"); - TclpGetTime(&start); + Tcl_GetTime(&start); for (i = 0; i < 100000; i++) { s = Tcl_GetVar(interp, "a", TCL_LEAVE_ERR_MSG); if (s == NULL) { return TCL_ERROR; } } - TclpGetTime(&stop); + Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); fprintf(stderr, " %.3f usec per Tcl_GetVar of a==\"12345\"\n", timePer/100000); @@ -3688,7 +4051,7 @@ NoopCmd(unused, interp, argc, argv) ClientData unused; /* Unused. */ Tcl_Interp *interp; /* The current interpreter. */ int argc; /* The number of arguments. */ - char **argv; /* The argument strings. */ + CONST char **argv; /* The argument strings. */ { return TCL_OK; } @@ -3743,10 +4106,10 @@ TestsetCmd(data, interp, argc, argv) ClientData data; /* Additional flags for Get/SetVar2. */ register Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + CONST char **argv; /* Argument strings. */ { int flags = (int) data; - char *value; + CONST char *value; if (argc == 2) { Tcl_SetResult(interp, "before get", TCL_STATIC); @@ -3800,7 +4163,7 @@ TestsaveresultCmd(dummy, interp, objc, objv) int discard, result, index; Tcl_SavedResult state; Tcl_Obj *objPtr; - static char *optionStrings[] = { + static CONST char *optionStrings[] = { "append", "dynamic", "free", "object", "small", NULL }; enum options { @@ -3925,7 +4288,7 @@ TeststatprocCmd (dummy, interp, argc, argv) ClientData dummy; /* Not used. */ register Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + CONST char **argv; /* Argument strings. */ { TclStatProc_ *proc; int retVal; @@ -3937,7 +4300,7 @@ TeststatprocCmd (dummy, interp, argc, argv) } if (strcmp(argv[2], "TclpStat") == 0) { - proc = TclpStat; + proc = PretendTclpStat; } else if (strcmp(argv[2], "TestStatProc1") == 0) { proc = TestStatProc1; } else if (strcmp(argv[2], "TestStatProc2") == 0) { @@ -3953,7 +4316,7 @@ TeststatprocCmd (dummy, interp, argc, argv) } if (strcmp(argv[1], "insert") == 0) { - if (proc == TclpStat) { + if (proc == PretendTclpStat) { Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ", "must be ", "TestStatProc1, TestStatProc2, or TestStatProc3", @@ -3977,16 +4340,94 @@ TeststatprocCmd (dummy, interp, argc, argv) return retVal; } +static int PretendTclpStat(path, buf) + CONST char *path; + struct stat *buf; +{ + int ret; + Tcl_Obj *pathPtr = Tcl_NewStringObj(path, -1); +#ifdef TCL_WIDE_INT_IS_LONG + Tcl_IncrRefCount(pathPtr); + ret = TclpObjStat(pathPtr, buf); + Tcl_DecrRefCount(pathPtr); + return ret; +#else /* TCL_WIDE_INT_IS_LONG */ + Tcl_StatBuf realBuf; + Tcl_IncrRefCount(pathPtr); + ret = TclpObjStat(pathPtr, &realBuf); + Tcl_DecrRefCount(pathPtr); + if (ret != -1) { +# define OUT_OF_RANGE(x) \ + (((Tcl_WideInt)(x)) < Tcl_LongAsWide(LONG_MIN) || \ + ((Tcl_WideInt)(x)) > Tcl_LongAsWide(LONG_MAX)) +# define OUT_OF_URANGE(x) \ + (((Tcl_WideUInt)(x)) > (Tcl_WideUInt)ULONG_MAX) + + /* + * Perform the result-buffer overflow check manually. + * + * Note that ino_t/ino64_t is unsigned... + */ + + if (OUT_OF_URANGE(realBuf.st_ino) || OUT_OF_RANGE(realBuf.st_size) +# ifdef HAVE_ST_BLOCKS + || OUT_OF_RANGE(realBuf.st_blocks) +# endif + ) { +# ifdef EOVERFLOW + errno = EOVERFLOW; +# else +# ifdef EFBIG + errno = EFBIG; +# else +# error "what error should be returned for a value out of range?" +# endif +# endif + return -1; + } + +# undef OUT_OF_RANGE +# undef OUT_OF_URANGE + + /* + * Copy across all supported fields, with possible type + * coercions on those fields that change between the normal + * and lf64 versions of the stat structure (on Solaris at + * least.) This is slow when the structure sizes coincide, + * but that's what you get for mixing interfaces... + */ + + buf->st_mode = realBuf.st_mode; + buf->st_ino = (ino_t) realBuf.st_ino; + buf->st_dev = realBuf.st_dev; + buf->st_rdev = realBuf.st_rdev; + buf->st_nlink = realBuf.st_nlink; + buf->st_uid = realBuf.st_uid; + buf->st_gid = realBuf.st_gid; + buf->st_size = (off_t) realBuf.st_size; + buf->st_atime = realBuf.st_atime; + buf->st_mtime = realBuf.st_mtime; + buf->st_ctime = realBuf.st_ctime; +# ifdef HAVE_ST_BLOCKS + buf->st_blksize = realBuf.st_blksize; + buf->st_blocks = (blkcnt_t) realBuf.st_blocks; +# endif + } + return ret; +#endif /* TCL_WIDE_INT_IS_LONG */ +} + /* Be careful in the compares in these tests, since the Macintosh puts a * leading : in the beginning of non-absolute paths before passing them * into the file command procedures. */ - + static int TestStatProc1(path, buf) CONST char *path; struct stat *buf; { + memset(buf, 0, sizeof(struct stat)); buf->st_size = 1234; return ((strstr(path, "testStat1%.fil") == NULL) ? -1 : 0); } @@ -3997,6 +4438,7 @@ TestStatProc2(path, buf) CONST char *path; struct stat *buf; { + memset(buf, 0, sizeof(struct stat)); buf->st_size = 2345; return ((strstr(path, "testStat2%.fil") == NULL) ? -1 : 0); } @@ -4007,6 +4449,7 @@ TestStatProc3(path, buf) CONST char *path; struct stat *buf; { + memset(buf, 0, sizeof(struct stat)); buf->st_size = 3456; return ((strstr(path, "testStat3%.fil") == NULL) ? -1 : 0); } @@ -4014,6 +4457,123 @@ TestStatProc3(path, buf) /* *---------------------------------------------------------------------- * + * TestmainthreadCmd -- + * + * Implements the "testmainthread" cmd that is used to test the + * 'Tcl_GetCurrentThread' API. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestmainthreadCmd (dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + register Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + CONST char **argv; /* Argument strings. */ +{ + if (argc == 1) { + Tcl_Obj *idObj = Tcl_NewLongObj((long)Tcl_GetCurrentThread()); + Tcl_SetObjResult(interp, idObj); + return TCL_OK; + } else { + Tcl_SetResult(interp, "wrong # args", TCL_STATIC); + return TCL_ERROR; + } +} + +/* + *---------------------------------------------------------------------- + * + * MainLoop -- + * + * A main loop set by TestsetmainloopCmd below. + * + * Results: + * None. + * + * Side effects: + * Event handlers could do anything. + * + *---------------------------------------------------------------------- + */ + +static void +MainLoop(void) +{ + while (!exitMainLoop) { + Tcl_DoOneEvent(0); + } + fprintf(stdout,"Exit MainLoop\n"); + fflush(stdout); +} + +/* + *---------------------------------------------------------------------- + * + * TestsetmainloopCmd -- + * + * Implements the "testsetmainloop" cmd that is used to test the + * 'Tcl_SetMainLoop' API. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestsetmainloopCmd (dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + register Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + CONST char **argv; /* Argument strings. */ +{ + exitMainLoop = 0; + Tcl_SetMainLoop(MainLoop); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestexitmainloopCmd -- + * + * Implements the "testexitmainloop" cmd that is used to test the + * 'Tcl_SetMainLoop' API. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestexitmainloopCmd (dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + register Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + CONST char **argv; /* Argument strings. */ +{ + exitMainLoop = 1; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TestaccessprocCmd -- * * Implements the "testTclAccessProc" cmd that is used to test the @@ -4033,7 +4593,7 @@ TestaccessprocCmd (dummy, interp, argc, argv) ClientData dummy; /* Not used. */ register Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + CONST char **argv; /* Argument strings. */ { TclAccessProc_ *proc; int retVal; @@ -4045,7 +4605,7 @@ TestaccessprocCmd (dummy, interp, argc, argv) } if (strcmp(argv[2], "TclpAccess") == 0) { - proc = TclpAccess; + proc = PretendTclpAccess; } else if (strcmp(argv[2], "TestAccessProc1") == 0) { proc = TestAccessProc1; } else if (strcmp(argv[2], "TestAccessProc2") == 0) { @@ -4061,7 +4621,7 @@ TestaccessprocCmd (dummy, interp, argc, argv) } if (strcmp(argv[1], "insert") == 0) { - if (proc == TclpAccess) { + if (proc == PretendTclpAccess) { Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ", "must be ", "TestAccessProc1, TestAccessProc2, or TestAccessProc3", @@ -4085,6 +4645,17 @@ TestaccessprocCmd (dummy, interp, argc, argv) return retVal; } +static int PretendTclpAccess(path, mode) + CONST char *path; + int mode; +{ + int ret; + Tcl_Obj *pathPtr = Tcl_NewStringObj(path, -1); + Tcl_IncrRefCount(pathPtr); + ret = TclpObjAccess(pathPtr, mode); + Tcl_DecrRefCount(pathPtr); + return ret; +} static int TestAccessProc1(path, mode) @@ -4134,7 +4705,7 @@ TestopenfilechannelprocCmd (dummy, interp, argc, argv) ClientData dummy; /* Not used. */ register Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + CONST char **argv; /* Argument strings. */ { TclOpenFileChannelProc_ *proc; int retVal; @@ -4146,7 +4717,7 @@ TestopenfilechannelprocCmd (dummy, interp, argc, argv) } if (strcmp(argv[2], "TclpOpenFileChannel") == 0) { - proc = TclpOpenFileChannel; + proc = PretendTclpOpenFileChannel; } else if (strcmp(argv[2], "TestOpenFileChannelProc1") == 0) { proc = TestOpenFileChannelProc1; } else if (strcmp(argv[2], "TestOpenFileChannelProc2") == 0) { @@ -4163,7 +4734,7 @@ TestopenfilechannelprocCmd (dummy, interp, argc, argv) } if (strcmp(argv[1], "insert") == 0) { - if (proc == TclpOpenFileChannel) { + if (proc == PretendTclpOpenFileChannel) { Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ", "must be ", "TestOpenFileChannelProc1, TestOpenFileChannelProc2, or ", @@ -4188,22 +4759,68 @@ TestopenfilechannelprocCmd (dummy, interp, argc, argv) return retVal; } +static Tcl_Channel +PretendTclpOpenFileChannel(interp, fileName, modeString, permissions) + Tcl_Interp *interp; /* Interpreter for error reporting; + * can be NULL. */ + CONST char *fileName; /* Name of file to open. */ + CONST char *modeString; /* A list of POSIX open modes or + * a string such as "rw". */ + int permissions; /* If the open involves creating a + * file, with what modes to create + * it? */ +{ + Tcl_Channel ret; + int mode, seekFlag; + Tcl_Obj *pathPtr; + mode = TclGetOpenMode(interp, modeString, &seekFlag); + if (mode == -1) { + return NULL; + } + pathPtr = Tcl_NewStringObj(fileName, -1); + Tcl_IncrRefCount(pathPtr); + ret = TclpOpenFileChannel(interp, pathPtr, mode, permissions); + Tcl_DecrRefCount(pathPtr); + if (ret != NULL) { + if (seekFlag) { + if (Tcl_Seek(ret, (Tcl_WideInt)0, SEEK_END) < (Tcl_WideInt)0) { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, + "could not seek to end of file while opening \"", + fileName, "\": ", + Tcl_PosixError(interp), (char *) NULL); + } + Tcl_Close(NULL, ret); + return NULL; + } + } + } + return ret; +} static Tcl_Channel TestOpenFileChannelProc1(interp, fileName, modeString, permissions) Tcl_Interp *interp; /* Interpreter for error reporting; * can be NULL. */ - char *fileName; /* Name of file to open. */ - char *modeString; /* A list of POSIX open modes or + CONST char *fileName; /* Name of file to open. */ + CONST char *modeString; /* A list of POSIX open modes or * a string such as "rw". */ int permissions; /* If the open involves creating a * file, with what modes to create * it? */ { - if (!strcmp("testOpenFileChannel1%.fil", fileName)) { - return (TclpOpenFileChannel(interp, "__testOpenFileChannel1%__.fil", + CONST char *expectname="testOpenFileChannel1%.fil"; + Tcl_DString ds; + + Tcl_DStringInit(&ds); + Tcl_JoinPath(1, &expectname, &ds); + + if (!strcmp(Tcl_DStringValue(&ds), fileName)) { + Tcl_DStringFree(&ds); + return (PretendTclpOpenFileChannel(interp, "__testOpenFileChannel1%__.fil", modeString, permissions)); } else { + Tcl_DStringFree(&ds); return (NULL); } } @@ -4213,17 +4830,25 @@ static Tcl_Channel TestOpenFileChannelProc2(interp, fileName, modeString, permissions) Tcl_Interp *interp; /* Interpreter for error reporting; * can be NULL. */ - char *fileName; /* Name of file to open. */ - char *modeString; /* A list of POSIX open modes or + CONST char *fileName; /* Name of file to open. */ + CONST char *modeString; /* A list of POSIX open modes or * a string such as "rw". */ int permissions; /* If the open involves creating a * file, with what modes to create * it? */ { - if (!strcmp("testOpenFileChannel2%.fil", fileName)) { - return (TclpOpenFileChannel(interp, "__testOpenFileChannel2%__.fil", + CONST char *expectname="testOpenFileChannel2%.fil"; + Tcl_DString ds; + + Tcl_DStringInit(&ds); + Tcl_JoinPath(1, &expectname, &ds); + + if (!strcmp(Tcl_DStringValue(&ds), fileName)) { + Tcl_DStringFree(&ds); + return (PretendTclpOpenFileChannel(interp, "__testOpenFileChannel2%__.fil", modeString, permissions)); } else { + Tcl_DStringFree(&ds); return (NULL); } } @@ -4233,17 +4858,25 @@ static Tcl_Channel TestOpenFileChannelProc3(interp, fileName, modeString, permissions) Tcl_Interp *interp; /* Interpreter for error reporting; * can be NULL. */ - char *fileName; /* Name of file to open. */ - char *modeString; /* A list of POSIX open modes or + CONST char *fileName; /* Name of file to open. */ + CONST char *modeString; /* A list of POSIX open modes or * a string such as "rw". */ int permissions; /* If the open involves creating a * file, with what modes to create * it? */ { - if (!strcmp("testOpenFileChannel3%.fil", fileName)) { - return (TclpOpenFileChannel(interp, "__testOpenFileChannel3%__.fil", + CONST char *expectname="testOpenFileChannel3%.fil"; + Tcl_DString ds; + + Tcl_DStringInit(&ds); + Tcl_JoinPath(1, &expectname, &ds); + + if (!strcmp(Tcl_DStringValue(&ds), fileName)) { + Tcl_DStringFree(&ds); + return (PretendTclpOpenFileChannel(interp, "__testOpenFileChannel3%__.fil", modeString, permissions)); } else { + Tcl_DStringFree(&ds); return (NULL); } } @@ -4266,14 +4899,14 @@ TestOpenFileChannelProc3(interp, fileName, modeString, permissions) */ /* ARGSUSED */ -int +static int TestChannelCmd(clientData, interp, argc, argv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Interpreter for result. */ int argc; /* Count of additional args. */ - char **argv; /* Additional arg strings. */ + CONST char **argv; /* Additional arg strings. */ { - char *cmdName; /* Sub command. */ + CONST char *cmdName; /* Sub command. */ Tcl_HashTable *hTblPtr; /* Hash table of channels. */ Tcl_HashSearch hSearch; /* Search variable. */ Tcl_HashEntry *hPtr; /* Search variable. */ @@ -4311,6 +4944,27 @@ TestChannelCmd(clientData, interp, argc, argv) chan = NULL; } + if ((cmdName[0] == 'c') && (strncmp(cmdName, "cut", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " cut channelName\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_CutChannel(chan); + return TCL_OK; + } + + if ((cmdName[0] == 'c') && + (strncmp(cmdName, "clearchannelhandlers", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " clearchannelhandlers channelName\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_ClearChannelHandlers(chan); + return TCL_OK; + } + if ((cmdName[0] == 'i') && (strncmp(cmdName, "info", len) == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], @@ -4318,7 +4972,7 @@ TestChannelCmd(clientData, interp, argc, argv) return TCL_ERROR; } Tcl_AppendElement(interp, argv[2]); - Tcl_AppendElement(interp, chanPtr->typePtr->typeName); + Tcl_AppendElement(interp, Tcl_ChannelName(chanPtr->typePtr)); if (statePtr->flags & TCL_READABLE) { Tcl_AppendElement(interp, "read"); } else { @@ -4407,7 +5061,7 @@ TestChannelCmd(clientData, interp, argc, argv) TclFormatInt(buf, IOQueued); Tcl_AppendElement(interp, buf); - TclFormatInt(buf, Tcl_Tell((Tcl_Channel) chanPtr)); + TclFormatInt(buf, (int)Tcl_Tell((Tcl_Channel) chanPtr)); Tcl_AppendElement(interp, buf); TclFormatInt(buf, statePtr->refCount); @@ -4434,6 +5088,28 @@ TestChannelCmd(clientData, interp, argc, argv) return TCL_OK; } + if ((cmdName[0] == 'i') && (strncmp(cmdName, "isshared", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", (char *) NULL); + return TCL_ERROR; + } + + TclFormatInt(buf, Tcl_IsChannelShared(chan)); + Tcl_AppendResult(interp, buf, (char *) NULL); + return TCL_OK; + } + + if ((cmdName[0] == 'i') && (strncmp(cmdName, "isstandard", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", (char *) NULL); + return TCL_ERROR; + } + + TclFormatInt(buf, Tcl_IsStandardChannel(chan)); + Tcl_AppendResult(interp, buf, (char *) NULL); + return TCL_OK; + } + if ((cmdName[0] == 'm') && (strncmp(cmdName, "mode", len) == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "channel name required", @@ -4454,6 +5130,18 @@ TestChannelCmd(clientData, interp, argc, argv) return TCL_OK; } + if ((cmdName[0] == 'm') && (strncmp(cmdName, "mthread", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", + (char *) NULL); + return TCL_ERROR; + } + + TclFormatInt(buf, (long) Tcl_GetChannelThread(chan)); + Tcl_AppendResult(interp, buf, (char *) NULL); + return TCL_OK; + } + if ((cmdName[0] == 'n') && (strncmp(cmdName, "name", len) == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "channel name required", @@ -4543,13 +5231,23 @@ TestChannelCmd(clientData, interp, argc, argv) return TCL_OK; } + if ((cmdName[0] == 's') && (strncmp(cmdName, "splice", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", (char *) NULL); + return TCL_ERROR; + } + + Tcl_SpliceChannel(chan); + return TCL_OK; + } + if ((cmdName[0] == 't') && (strncmp(cmdName, "type", len) == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "channel name required", (char *) NULL); return TCL_ERROR; } - Tcl_AppendResult(interp, chanPtr->typePtr->typeName, + Tcl_AppendResult(interp, Tcl_ChannelName(chanPtr->typePtr), (char *) NULL); return TCL_OK; } @@ -4605,7 +5303,8 @@ TestChannelCmd(clientData, interp, argc, argv) } Tcl_AppendResult(interp, "bad option \"", cmdName, "\": should be ", - "info, open, readable, writable, transform, unstack", + "cut, clearchannelhandlers, info, isshared, mode, open, " + "readable, splice, writable, transform, unstack", (char *) NULL); return TCL_ERROR; } @@ -4628,18 +5327,18 @@ TestChannelCmd(clientData, interp, argc, argv) */ /* ARGSUSED */ -int +static int TestChannelEventCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + CONST char **argv; /* Argument strings. */ { Tcl_Obj *resultListPtr; Channel *chanPtr; ChannelState *statePtr; /* state info for channel */ EventScriptRecord *esPtr, *prevEsPtr, *nextEsPtr; - char *cmd; + CONST char *cmd; int index, i, mask, len; if ((argc < 3) || (argc > 5)) { @@ -4823,4 +5522,440 @@ TestChannelEventCmd(dummy, interp, argc, argv) "add, delete, list, set, or removeall", (char *) NULL); return TCL_ERROR; } + +/* + *---------------------------------------------------------------------- + * + * TestWrongNumArgsObjCmd -- + * + * Test the Tcl_WrongNumArgs function. + * + * Results: + * Standard Tcl result. + * + * Side effects: + * Sets interpreter result. + * + *---------------------------------------------------------------------- + */ + +static int +TestWrongNumArgsObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + int i, length; + 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; + } + + if (Tcl_GetIntFromObj(interp, objv[1], &i) != TCL_OK) { + return TCL_ERROR; + } + + msg = Tcl_GetStringFromObj(objv[2], &length); + if (length == 0) { + msg = NULL; + } + + if (i > objc - 3) { + /* + * Asked for more arguments than were given. + */ + Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC); + return TCL_ERROR; + } + + Tcl_WrongNumArgs(interp, i, &(objv[3]), msg); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestGetIndexFromObjStructObjCmd -- + * + * Test the Tcl_GetIndexFromObjStruct function. + * + * Results: + * Standard Tcl result. + * + * Side effects: + * Sets interpreter result. + * + *---------------------------------------------------------------------- + */ + +static int +TestGetIndexFromObjStructObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + char *ary[] = { + "a", "b", "c", "d", "e", "f", (char *)NULL,(char *)NULL + }; + int idx,target; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "argument targetvalue"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObjStruct(interp, objv[1], ary, 2*sizeof(char *), + "dummy", 0, &idx) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetIntFromObj(interp, objv[2], &target) != TCL_OK) { + return TCL_ERROR; + } + if (idx != target) { + char buffer[64]; + sprintf(buffer, "%d", idx); + Tcl_AppendResult(interp, "index value comparison failed: got ", + buffer, NULL); + sprintf(buffer, "%d", target); + Tcl_AppendResult(interp, " when ", buffer, " expected", NULL); + return TCL_ERROR; + } + Tcl_WrongNumArgs(interp, 3, objv, NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestFilesystemObjCmd -- + * + * This procedure implements the "testfilesystem" command. It is + * used to test Tcl_FSRegister, Tcl_FSUnregister, and can be used + * to test that the pluggable filesystem works. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Inserts or removes a filesystem from Tcl's stack. + * + *---------------------------------------------------------------------- + */ + +static int +TestFilesystemObjCmd(dummy, interp, objc, objv) + ClientData dummy; + Tcl_Interp *interp; + int objc; + Tcl_Obj *CONST objv[]; +{ + int res, boolVal; + char *msg; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "boolean"); + return TCL_ERROR; + } + if (Tcl_GetBooleanFromObj(interp, objv[1], &boolVal) != TCL_OK) { + return TCL_ERROR; + } + if (boolVal) { + res = Tcl_FSRegister((ClientData)interp, &testReportingFilesystem); + msg = (res == TCL_OK) ? "registered" : "failed"; + } else { + res = Tcl_FSUnregister(&testReportingFilesystem); + msg = (res == TCL_OK) ? "unregistered" : "failed"; + } + Tcl_SetResult(interp, msg, TCL_VOLATILE); + return res; +} + +static int +TestReportInFilesystem(Tcl_Obj *pathPtr, ClientData *clientDataPtr) +{ + static Tcl_Obj* lastPathPtr = NULL; + + if (pathPtr == lastPathPtr) { + /* Reject all files second time around */ + return -1; + } else { + Tcl_Obj * newPathPtr; + /* Try to claim all files first time around */ + + newPathPtr = Tcl_DuplicateObj(pathPtr); + lastPathPtr = newPathPtr; + Tcl_IncrRefCount(newPathPtr); + if (Tcl_FSGetFileSystemForPath(newPathPtr) == NULL) { + /* Nothing claimed it. Therefore we don't either */ + Tcl_DecrRefCount(newPathPtr); + lastPathPtr = NULL; + return -1; + } else { + lastPathPtr = NULL; + *clientDataPtr = (ClientData) newPathPtr; + return TCL_OK; + } + } +} + +/* + * Simple helper function to extract the native vfs representation of a + * path object, or NULL if no such representation exists. + */ +static Tcl_Obj* +TestReportGetNativePath(Tcl_Obj* pathObjPtr) { + return (Tcl_Obj*) Tcl_FSGetInternalRep(pathObjPtr, &testReportingFilesystem); +} + +static void +TestReportFreeInternalRep(ClientData clientData) { + Tcl_Obj *nativeRep = (Tcl_Obj*)clientData; + if (nativeRep != NULL) { + /* Free the path */ + Tcl_DecrRefCount(nativeRep); + } +} + +static ClientData +TestReportDupInternalRep(ClientData clientData) { + Tcl_Obj *original = (Tcl_Obj*)clientData; + Tcl_IncrRefCount(original); + return clientData; +} +static void +TestReport(cmd, path, arg2) + CONST char* cmd; + Tcl_Obj* path; + Tcl_Obj* arg2; +{ + Tcl_Interp* interp = (Tcl_Interp*) Tcl_FSData(&testReportingFilesystem); + if (interp == NULL) { + /* This is bad, but not much we can do about it */ + } else { + /* + * No idea why I decided to program this up using the + * old string-based API, but there you go. We should + * convert it to objects. + */ + Tcl_SavedResult savedResult; + Tcl_DString ds; + Tcl_DStringInit(&ds); + Tcl_DStringAppend(&ds, "lappend filesystemReport ",-1); + Tcl_DStringStartSublist(&ds); + Tcl_DStringAppendElement(&ds, cmd); + if (path != NULL) { + Tcl_DStringAppendElement(&ds, Tcl_GetString(path)); + } + if (arg2 != NULL) { + Tcl_DStringAppendElement(&ds, Tcl_GetString(arg2)); + } + Tcl_DStringEndSublist(&ds); + Tcl_SaveResult(interp, &savedResult); + Tcl_Eval(interp, Tcl_DStringValue(&ds)); + Tcl_DStringFree(&ds); + Tcl_RestoreResult(interp, &savedResult); + } +} + +static int +TestReportStat(path, buf) + Tcl_Obj *path; /* Path of file to stat (in current CP). */ + Tcl_StatBuf *buf; /* Filled with results of stat call. */ +{ + TestReport("stat",path, NULL); + return Tcl_FSStat(TestReportGetNativePath(path),buf); +} +static int +TestReportLstat(path, buf) + Tcl_Obj *path; /* Path of file to stat (in current CP). */ + Tcl_StatBuf *buf; /* Filled with results of stat call. */ +{ + TestReport("lstat",path, NULL); + return Tcl_FSLstat(TestReportGetNativePath(path),buf); +} +static int +TestReportAccess(path, mode) + Tcl_Obj *path; /* Path of file to access (in current CP). */ + int mode; /* Permission setting. */ +{ + TestReport("access",path,NULL); + return Tcl_FSAccess(TestReportGetNativePath(path),mode); +} +static Tcl_Channel +TestReportOpenFileChannel(interp, fileName, mode, permissions) + Tcl_Interp *interp; /* Interpreter for error reporting; + * can be NULL. */ + Tcl_Obj *fileName; /* Name of file to open. */ + int mode; /* POSIX open mode. */ + int permissions; /* If the open involves creating a + * file, with what modes to create + * it? */ +{ + TestReport("open",fileName, NULL); + return TclpOpenFileChannel(interp, TestReportGetNativePath(fileName), + mode, permissions); +} + +static int +TestReportMatchInDirectory(interp, resultPtr, dirPtr, pattern, types) + Tcl_Interp *interp; /* Interpreter to receive results. */ + Tcl_Obj *resultPtr; /* Directory separators to pass to TclDoGlob. */ + Tcl_Obj *dirPtr; /* 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. */ +{ + TestReport("matchindirectory",dirPtr, NULL); + return Tcl_FSMatchInDirectory(interp, resultPtr, + TestReportGetNativePath(dirPtr), pattern, + types); +} +static int +TestReportChdir(dirName) + Tcl_Obj *dirName; +{ + TestReport("chdir",dirName,NULL); + return Tcl_FSChdir(TestReportGetNativePath(dirName)); +} +static int +TestReportLoadFile(interp, fileName, + handlePtr, unloadProcPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Obj *fileName; /* Name of the file containing the desired + * code. */ + Tcl_LoadHandle *handlePtr; /* Filled with token for dynamically loaded + * file which will be passed back to + * (*unloadProcPtr)() to unload the file. */ + Tcl_FSUnloadFileProc **unloadProcPtr; + /* Filled with address of Tcl_FSUnloadFileProc + * function which should be used for + * this file. */ +{ + TestReport("loadfile",fileName,NULL); + return Tcl_FSLoadFile(interp, TestReportGetNativePath(fileName), NULL, NULL, + NULL, NULL, handlePtr, unloadProcPtr); +} +static Tcl_Obj * +TestReportLink(path, to, linkType) + Tcl_Obj *path; /* Path of file to readlink or link */ + Tcl_Obj *to; /* Path of file to link to, or NULL */ + int linkType; +{ + TestReport("link",path,to); + return Tcl_FSLink(TestReportGetNativePath(path), to, linkType); +} +static int +TestReportRenameFile(src, dst) + Tcl_Obj *src; /* Pathname of file or dir to be renamed + * (UTF-8). */ + Tcl_Obj *dst; /* New pathname of file or directory + * (UTF-8). */ +{ + TestReport("renamefile",src,dst); + return Tcl_FSRenameFile(TestReportGetNativePath(src), + TestReportGetNativePath(dst)); +} +static int +TestReportCopyFile(src, dst) + Tcl_Obj *src; /* Pathname of file to be copied (UTF-8). */ + Tcl_Obj *dst; /* Pathname of file to copy to (UTF-8). */ +{ + TestReport("copyfile",src,dst); + return Tcl_FSCopyFile(TestReportGetNativePath(src), + TestReportGetNativePath(dst)); +} +static int +TestReportDeleteFile(path) + Tcl_Obj *path; /* Pathname of file to be removed (UTF-8). */ +{ + TestReport("deletefile",path,NULL); + return Tcl_FSDeleteFile(TestReportGetNativePath(path)); +} +static int +TestReportCreateDirectory(path) + Tcl_Obj *path; /* Pathname of directory to create (UTF-8). */ +{ + TestReport("createdirectory",path,NULL); + return Tcl_FSCreateDirectory(TestReportGetNativePath(path)); +} +static int +TestReportCopyDirectory(src, dst, errorPtr) + Tcl_Obj *src; /* Pathname of directory to be copied + * (UTF-8). */ + Tcl_Obj *dst; /* Pathname of target directory (UTF-8). */ + Tcl_Obj **errorPtr; /* If non-NULL, to be filled with UTF-8 name + * of file causing error. */ +{ + TestReport("copydirectory",src,dst); + return Tcl_FSCopyDirectory(TestReportGetNativePath(src), + TestReportGetNativePath(dst), errorPtr); +} +static int +TestReportRemoveDirectory(path, recursive, errorPtr) + Tcl_Obj *path; /* 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, to be filled with UTF-8 name + * of file causing error. */ +{ + TestReport("removedirectory",path,NULL); + return Tcl_FSRemoveDirectory(TestReportGetNativePath(path), recursive, + errorPtr); +} +static CONST char** +TestReportFileAttrStrings(fileName, objPtrRef) + Tcl_Obj* fileName; + Tcl_Obj** objPtrRef; +{ + TestReport("fileattributestrings",fileName,NULL); + return Tcl_FSFileAttrStrings(TestReportGetNativePath(fileName), objPtrRef); +} +static int +TestReportFileAttrsGet(interp, index, fileName, objPtrRef) + Tcl_Interp *interp; /* The interpreter for error reporting. */ + int index; /* index of the attribute command. */ + Tcl_Obj *fileName; /* filename we are operating on. */ + Tcl_Obj **objPtrRef; /* for output. */ +{ + TestReport("fileattributesget",fileName,NULL); + return Tcl_FSFileAttrsGet(interp, index, + TestReportGetNativePath(fileName), objPtrRef); +} +static int +TestReportFileAttrsSet(interp, index, fileName, objPtr) + Tcl_Interp *interp; /* The interpreter for error reporting. */ + int index; /* index of the attribute command. */ + Tcl_Obj *fileName; /* filename we are operating on. */ + Tcl_Obj *objPtr; /* for input. */ +{ + TestReport("fileattributesset",fileName,objPtr); + return Tcl_FSFileAttrsSet(interp, index, + TestReportGetNativePath(fileName), objPtr); +} +static int +TestReportUtime (fileName, tval) + Tcl_Obj* fileName; + struct utimbuf *tval; +{ + TestReport("utime",fileName,NULL); + return Tcl_FSUtime(TestReportGetNativePath(fileName), tval); +} +static int +TestReportNormalizePath(interp, pathPtr, nextCheckpoint) + Tcl_Interp *interp; + Tcl_Obj *pathPtr; + int nextCheckpoint; +{ + TestReport("normalizepath",pathPtr,NULL); + return nextCheckpoint; +} diff --git a/tcl/generic/tclTestObj.c b/tcl/generic/tclTestObj.c index 3f583ff9af3..1724730c4ee 100644 --- a/tcl/generic/tclTestObj.c +++ b/tcl/generic/tclTestObj.c @@ -404,8 +404,17 @@ TestindexobjCmd(clientData, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { int allowAbbrev, index, index2, setError, i, result; - char **argv; - static char *tablePtr[] = {"a", "b", "check", (char *) NULL}; + CONST char **argv; + static CONST char *tablePtr[] = {"a", "b", "check", (char *) 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; if ((objc == 3) && (strcmp(Tcl_GetString(objv[1]), "check") == 0)) { @@ -415,12 +424,14 @@ TestindexobjCmd(clientData, interp, objc, objv) * returned on subsequent lookups. */ - Tcl_GetIndexFromObj((Tcl_Interp *) NULL, objv[1], tablePtr, - "token", 0, &index); if (Tcl_GetIntFromObj(interp, objv[2], &index2) != TCL_OK) { return TCL_ERROR; } - objv[1]->internalRep.twoPtrValue.ptr2 = (VOID *) index2; + + Tcl_GetIndexFromObj((Tcl_Interp *) NULL, objv[1], tablePtr, + "token", 0, &index); + indexRep = (struct IndexRep *) objv[1]->internalRep.otherValuePtr; + indexRep->index = index2; result = Tcl_GetIndexFromObj((Tcl_Interp *) NULL, objv[1], tablePtr, "token", 0, &index); if (result == TCL_OK) { @@ -441,7 +452,7 @@ TestindexobjCmd(clientData, interp, objc, objv) return TCL_ERROR; } - argv = (char **) ckalloc((unsigned) ((objc-3) * sizeof(char *))); + argv = (CONST char **) ckalloc((unsigned) ((objc-3) * sizeof(char *))); for (i = 4; i < objc; i++) { argv[i-4] = Tcl_GetString(objv[i]); } @@ -454,9 +465,13 @@ TestindexobjCmd(clientData, interp, objc, objv) * the index object, clear out the object's cached state. */ - if ((objv[3]->typePtr == Tcl_GetObjType("index")) - && (objv[3]->internalRep.twoPtrValue.ptr1 == (VOID *) argv)) { - objv[3]->typePtr = NULL; + if ( objv[3]->typePtr != NULL + && !strcmp( "index", objv[3]->typePtr->name ) ) { + indexRep = (struct IndexRep *) objv[3]->internalRep.otherValuePtr; + if (indexRep->tablePtr == (VOID *) argv) { + objv[3]->typePtr->freeIntRepProc(objv[3]); + objv[3]->typePtr = NULL; + } } result = Tcl_GetIndexFromObj((setError? interp : NULL), objv[3], @@ -773,6 +788,19 @@ TestobjCmd(clientData, interp, objc, objv) varPtr[i] = NULL; } } + } else if ( strcmp ( subCmd, "invalidateStringRep" ) == 0 ) { + if ( objc != 3 ) { + goto wrongNumArgs; + } + index = Tcl_GetString( objv[2] ); + if ( GetVariableIndex( interp, index, &varIndex ) != TCL_OK ) { + return TCL_ERROR; + } + if (CheckIfVarUnset(interp, varIndex)) { + return TCL_ERROR; + } + Tcl_InvalidateStringRep( varPtr[varIndex] ); + Tcl_SetObjResult( interp, varPtr[varIndex] ); } else if (strcmp(subCmd, "newobj") == 0) { if (objc != 3) { goto wrongNumArgs; @@ -881,7 +909,7 @@ TeststringobjCmd(clientData, interp, objc, objv) #define MAX_STRINGS 11 char *index, *string, *strings[MAX_STRINGS+1]; TestString *strPtr; - static char *options[] = { + static CONST char *options[] = { "append", "appendstrings", "get", "get2", "length", "length2", "set", "set2", "setlength", "ualloc", (char *) NULL }; diff --git a/tcl/generic/tclThread.c b/tcl/generic/tclThread.c index f7c3a39b786..bd7c569716a 100644 --- a/tcl/generic/tclThread.c +++ b/tcl/generic/tclThread.c @@ -577,4 +577,3 @@ Tcl_MutexUnlock(mutexPtr) { } #endif - diff --git a/tcl/generic/tclThreadAlloc.c b/tcl/generic/tclThreadAlloc.c new file mode 100644 index 00000000000..54dbfde588f --- /dev/null +++ b/tcl/generic/tclThreadAlloc.c @@ -0,0 +1,955 @@ +/* + * tclThreadAlloc.c -- + * + * This is a very fast storage allocator for used with threads (designed + * avoid lock contention). The basic strategy is to allocate memory in + * 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. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id$ */ + +#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) + +#include "tclInt.h" + +#ifdef WIN32 +#include "tclWinInt.h" +#else +extern Tcl_Mutex *TclpNewAllocMutex(void); +extern void *TclpGetAllocCache(void); +extern void TclpSetAllocCache(void *); +#endif + +/* + * If range checking is enabled, an additional byte will be allocated + * to store the magic number at the end of the requested memory. + */ + +#ifndef RCHECK +#ifdef NDEBUG +#define RCHECK 0 +#else +#define RCHECK 1 +#endif +#endif + +/* + * The following define the number of Tcl_Obj's to allocate/move + * at a time and the high water mark to prune a per-thread cache. + * On a 32 bit system, sizeof(Tcl_Obj) = 24 so 800 * 24 = ~16k. + * + */ + +#define NOBJALLOC 800 +#define NOBJHIGH 1200 + +/* + * The following defines the number of buckets in the bucket + * cache and those block sizes from (1<<4) to (1<<(3+NBUCKETS)) + */ + +#define NBUCKETS 11 +#define MAXALLOC 16284 + +/* + * The following union stores accounting information for + * each block including two small magic numbers and + * a bucket number when in use or a next pointer when + * free. The original requested size (not including + * the Block overhead) is also maintained. + */ + +typedef struct Block { + union { + struct Block *next; /* Next in free list. */ + struct { + unsigned char magic1; /* First magic number. */ + unsigned char bucket; /* Bucket block allocated from. */ + unsigned char unused; /* Padding. */ + unsigned char magic2; /* Second magic number. */ + } b_s; + } b_u; + size_t b_reqsize; /* Requested allocation size. */ +} Block; +#define b_next b_u.next +#define b_bucket b_u.b_s.bucket +#define b_magic1 b_u.b_s.magic1 +#define b_magic2 b_u.b_s.magic2 +#define MAGIC 0xef + +/* + * The following structure defines a bucket of blocks with + * various accounting and statistics information. + */ + +typedef struct Bucket { + Block *firstPtr; + int nfree; + int nget; + int nput; + int nwait; + int nlock; + int nrequest; +} Bucket; + +/* + * The following structure defines a cache of buckets and objs. + */ + +typedef struct Cache { + struct Cache *nextPtr; + Tcl_ThreadId owner; + Tcl_Obj *firstObjPtr; + int nobjs; + int nsysalloc; + Bucket buckets[NBUCKETS]; +} Cache; + +/* + * The following array specifies various per-bucket + * limits and locks. The values are statically initialized + * to avoid calculating them repeatedly. + */ + +struct binfo { + size_t blocksize; /* Bucket blocksize. */ + int maxblocks; /* Max blocks before move to share. */ + int nmove; /* Num blocks to move to share. */ + Tcl_Mutex *lockPtr; /* Share bucket lock. */ +} binfo[NBUCKETS] = { + { 16, 1024, 512, NULL}, + { 32, 512, 256, NULL}, + { 64, 256, 128, NULL}, + { 128, 128, 64, NULL}, + { 256, 64, 32, NULL}, + { 512, 32, 16, NULL}, + { 1024, 16, 8, NULL}, + { 2048, 8, 4, NULL}, + { 4096, 4, 2, NULL}, + { 8192, 2, 1, NULL}, + {16284, 1, 1, NULL}, +}; + +/* + * Static functions defined in this file. + */ + +static void LockBucket(Cache *cachePtr, int bucket); +static void UnlockBucket(Cache *cachePtr, int bucket); +static void PutBlocks(Cache *cachePtr, int bucket, int nmove); +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 nmove); + +/* + * Local variables defined in this file and initialized at + * startup. + */ + +static Tcl_Mutex *listLockPtr; +static Tcl_Mutex *objLockPtr; +static Cache sharedCache; +static Cache *sharedPtr = &sharedCache; +static Cache *firstCachePtr = &sharedCache; + + +/* + *---------------------------------------------------------------------- + * + * GetCache --- + * + * Gets per-thread memory cache, allocating it if necessary. + * + * Results: + * Pointer to cache. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Cache * +GetCache(void) +{ + Cache *cachePtr; + + /* + * Check for first-time initialization. + */ + + if (listLockPtr == NULL) { + Tcl_Mutex *initLockPtr; + int i; + + initLockPtr = Tcl_GetAllocMutex(); + Tcl_MutexLock(initLockPtr); + if (listLockPtr == NULL) { + listLockPtr = TclpNewAllocMutex(); + objLockPtr = TclpNewAllocMutex(); + for (i = 0; i < NBUCKETS; ++i) { + binfo[i].lockPtr = TclpNewAllocMutex(); + } + } + Tcl_MutexUnlock(initLockPtr); + } + + /* + * Get this thread's cache, allocating if necessary. + */ + + cachePtr = TclpGetAllocCache(); + if (cachePtr == NULL) { + cachePtr = calloc(1, sizeof(Cache)); + if (cachePtr == NULL) { + panic("alloc: could not allocate new cache"); + } + Tcl_MutexLock(listLockPtr); + cachePtr->nextPtr = firstCachePtr; + firstCachePtr = cachePtr; + Tcl_MutexUnlock(listLockPtr); + cachePtr->owner = Tcl_GetCurrentThread(); + TclpSetAllocCache(cachePtr); + } + return cachePtr; +} + + +/* + *---------------------------------------------------------------------- + * + * TclFreeAllocCache -- + * + * Flush and delete a cache, removing from list of caches. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclFreeAllocCache(void *arg) +{ + Cache *cachePtr = arg; + Cache **nextPtrPtr; + register int bucket; + + /* + * Flush blocks. + */ + + for (bucket = 0; bucket < NBUCKETS; ++bucket) { + if (cachePtr->buckets[bucket].nfree > 0) { + PutBlocks(cachePtr, bucket, cachePtr->buckets[bucket].nfree); + } + } + + /* + * Flush objs. + */ + + if (cachePtr->nobjs > 0) { + Tcl_MutexLock(objLockPtr); + MoveObjs(cachePtr, sharedPtr, cachePtr->nobjs); + Tcl_MutexUnlock(objLockPtr); + } + + /* + * Remove from pool list. + */ + + Tcl_MutexLock(listLockPtr); + nextPtrPtr = &firstCachePtr; + while (*nextPtrPtr != cachePtr) { + nextPtrPtr = &(*nextPtrPtr)->nextPtr; + } + *nextPtrPtr = cachePtr->nextPtr; + cachePtr->nextPtr = NULL; + Tcl_MutexUnlock(listLockPtr); +#ifdef WIN32 + TlsFree((DWORD) cachePtr); +#else + free(cachePtr); +#endif +} + + +/* + *---------------------------------------------------------------------- + * + * TclpAlloc -- + * + * Allocate memory. + * + * Results: + * Pointer to memory just beyond Block pointer. + * + * Side effects: + * May allocate more blocks for a bucket. + * + *---------------------------------------------------------------------- + */ + +char * +TclpAlloc(unsigned int reqsize) +{ + Cache *cachePtr = TclpGetAllocCache(); + Block *blockPtr; + register int bucket; + size_t size; + + if (cachePtr == NULL) { + cachePtr = GetCache(); + } + + /* + * Increment the requested size to include room for + * the Block structure. Call malloc() directly if the + * required amount is greater than the largest block, + * otherwise pop the smallest block large enough, + * allocating more blocks if necessary. + */ + + blockPtr = NULL; + size = reqsize + sizeof(Block); +#if RCHECK + ++size; +#endif + if (size > MAXALLOC) { + bucket = NBUCKETS; + blockPtr = malloc(size); + if (blockPtr != NULL) { + cachePtr->nsysalloc += reqsize; + } + } else { + bucket = 0; + while (binfo[bucket].blocksize < size) { + ++bucket; + } + if (cachePtr->buckets[bucket].nfree || GetBlocks(cachePtr, bucket)) { + blockPtr = cachePtr->buckets[bucket].firstPtr; + cachePtr->buckets[bucket].firstPtr = blockPtr->b_next; + --cachePtr->buckets[bucket].nfree; + ++cachePtr->buckets[bucket].nget; + cachePtr->buckets[bucket].nrequest += reqsize; + } + } + if (blockPtr == NULL) { + return NULL; + } + return Block2Ptr(blockPtr, bucket, reqsize); +} + + +/* + *---------------------------------------------------------------------- + * + * TclpFree -- + * + * Return blocks to the thread block cache. + * + * Results: + * None. + * + * Side effects: + * May move blocks to shared cache. + * + *---------------------------------------------------------------------- + */ + +void +TclpFree(char *ptr) +{ + if (ptr != NULL) { + Cache *cachePtr = TclpGetAllocCache(); + Block *blockPtr; + int bucket; + + if (cachePtr == NULL) { + cachePtr = GetCache(); + } + + /* + * Get the block back from the user pointer and + * call system free directly for large blocks. + * Otherwise, push the block back on the bucket and + * move blocks to the shared cache if there are now + * too many free. + */ + + blockPtr = Ptr2Block(ptr); + bucket = blockPtr->b_bucket; + if (bucket == NBUCKETS) { + cachePtr->nsysalloc -= blockPtr->b_reqsize; + free(blockPtr); + } else { + cachePtr->buckets[bucket].nrequest -= blockPtr->b_reqsize; + blockPtr->b_next = cachePtr->buckets[bucket].firstPtr; + cachePtr->buckets[bucket].firstPtr = blockPtr; + ++cachePtr->buckets[bucket].nfree; + ++cachePtr->buckets[bucket].nput; + if (cachePtr != sharedPtr && + cachePtr->buckets[bucket].nfree > binfo[bucket].maxblocks) { + PutBlocks(cachePtr, bucket, binfo[bucket].nmove); + } + } + } +} + + +/* + *---------------------------------------------------------------------- + * + * TclpRealloc -- + * + * Re-allocate memory to a larger or smaller size. + * + * Results: + * Pointer to memory just beyond Block pointer. + * + * Side effects: + * Previous memory, if any, may be freed. + * + *---------------------------------------------------------------------- + */ + +char * +TclpRealloc(char *ptr, unsigned int reqsize) +{ + Cache *cachePtr = TclpGetAllocCache(); + Block *blockPtr; + void *new; + size_t size, min; + int bucket; + + if (ptr == NULL) { + return TclpAlloc(reqsize); + } + + if (cachePtr == NULL) { + cachePtr = GetCache(); + } + + /* + * If the block is not a system block and fits in place, + * simply return the existing pointer. Otherwise, if the block + * is a system block and the new size would also require a system + * block, call realloc() directly. + */ + + blockPtr = Ptr2Block(ptr); + size = reqsize + sizeof(Block); +#if RCHECK + ++size; +#endif + bucket = blockPtr->b_bucket; + if (bucket != NBUCKETS) { + if (bucket > 0) { + min = binfo[bucket-1].blocksize; + } else { + min = 0; + } + if (size > min && size <= binfo[bucket].blocksize) { + cachePtr->buckets[bucket].nrequest -= blockPtr->b_reqsize; + cachePtr->buckets[bucket].nrequest += reqsize; + return Block2Ptr(blockPtr, bucket, reqsize); + } + } else if (size > MAXALLOC) { + cachePtr->nsysalloc -= blockPtr->b_reqsize; + cachePtr->nsysalloc += reqsize; + blockPtr = realloc(blockPtr, size); + if (blockPtr == NULL) { + return NULL; + } + return Block2Ptr(blockPtr, NBUCKETS, reqsize); + } + + /* + * Finally, perform an expensive malloc/copy/free. + */ + + new = TclpAlloc(reqsize); + if (new != NULL) { + if (reqsize > blockPtr->b_reqsize) { + reqsize = blockPtr->b_reqsize; + } + memcpy(new, ptr, reqsize); + TclpFree(ptr); + } + return new; +} + + +/* + *---------------------------------------------------------------------- + * + * TclThreadAllocObj -- + * + * Allocate a Tcl_Obj from the per-thread cache. + * + * Results: + * Pointer to uninitialized Tcl_Obj. + * + * Side effects: + * May move Tcl_Obj's from shared cached or allocate new Tcl_Obj's + * if list is empty. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclThreadAllocObj(void) +{ + register Cache *cachePtr = TclpGetAllocCache(); + register int nmove; + register Tcl_Obj *objPtr; + Tcl_Obj *newObjsPtr; + + if (cachePtr == NULL) { + cachePtr = GetCache(); + } + + /* + * Get this thread's obj list structure and move + * or allocate new objs if necessary. + */ + + if (cachePtr->nobjs == 0) { + Tcl_MutexLock(objLockPtr); + nmove = sharedPtr->nobjs; + if (nmove > 0) { + if (nmove > NOBJALLOC) { + nmove = NOBJALLOC; + } + MoveObjs(sharedPtr, cachePtr, nmove); + } + Tcl_MutexUnlock(objLockPtr); + if (cachePtr->nobjs == 0) { + cachePtr->nobjs = nmove = NOBJALLOC; + newObjsPtr = malloc(sizeof(Tcl_Obj) * nmove); + if (newObjsPtr == NULL) { + panic("alloc: could not allocate %d new objects", nmove); + } + while (--nmove >= 0) { + objPtr = &newObjsPtr[nmove]; + objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr; + cachePtr->firstObjPtr = objPtr; + } + } + } + + /* + * Pop the first object. + */ + + objPtr = cachePtr->firstObjPtr; + cachePtr->firstObjPtr = objPtr->internalRep.otherValuePtr; + --cachePtr->nobjs; + return objPtr; +} + + +/* + *---------------------------------------------------------------------- + * + * TclThreadFreeObj -- + * + * Return a free Tcl_Obj to the per-thread cache. + * + * Results: + * None. + * + * Side effects: + * May move free Tcl_Obj's to shared list upon hitting high + * water mark. + * + *---------------------------------------------------------------------- + */ + +void +TclThreadFreeObj(Tcl_Obj *objPtr) +{ + Cache *cachePtr = TclpGetAllocCache(); + + if (cachePtr == NULL) { + cachePtr = GetCache(); + } + + /* + * Get this thread's list and push on the free Tcl_Obj. + */ + + objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr; + cachePtr->firstObjPtr = objPtr; + ++cachePtr->nobjs; + + /* + * If the number of free objects has exceeded the high + * water mark, move some blocks to the shared list. + */ + + if (cachePtr->nobjs > NOBJHIGH) { + Tcl_MutexLock(objLockPtr); + MoveObjs(cachePtr, sharedPtr, NOBJALLOC); + Tcl_MutexUnlock(objLockPtr); + } +} + + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetMemoryInfo -- + * + * Return a list-of-lists of memory stats. + * + * Results: + * None. + * + * Side effects: + * List appended to given dstring. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_GetMemoryInfo(Tcl_DString *dsPtr) +{ + Cache *cachePtr; + char buf[200]; + int n; + + Tcl_MutexLock(listLockPtr); + cachePtr = firstCachePtr; + while (cachePtr != NULL) { + Tcl_DStringStartSublist(dsPtr); + if (cachePtr == sharedPtr) { + Tcl_DStringAppendElement(dsPtr, "shared"); + } else { + sprintf(buf, "thread%d", (int) cachePtr->owner); + Tcl_DStringAppendElement(dsPtr, buf); + } + for (n = 0; n < NBUCKETS; ++n) { + sprintf(buf, "%d %d %d %d %d %d %d", + (int) binfo[n].blocksize, + cachePtr->buckets[n].nfree, + cachePtr->buckets[n].nget, + cachePtr->buckets[n].nput, + cachePtr->buckets[n].nrequest, + cachePtr->buckets[n].nlock, + cachePtr->buckets[n].nwait); + Tcl_DStringAppendElement(dsPtr, buf); + } + Tcl_DStringEndSublist(dsPtr); + cachePtr = cachePtr->nextPtr; + } + Tcl_MutexUnlock(listLockPtr); +} + + +/* + *---------------------------------------------------------------------- + * + * MoveObjs -- + * + * Move Tcl_Obj's between caches. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +MoveObjs(Cache *fromPtr, Cache *toPtr, int nmove) +{ + register Tcl_Obj *objPtr = fromPtr->firstObjPtr; + Tcl_Obj *fromFirstObjPtr = objPtr; + + toPtr->nobjs += nmove; + fromPtr->nobjs -= nmove; + + /* + * Find the last object to be moved; set the next one + * (the first one not to be moved) as the first object + * in the 'from' cache. + */ + + while (--nmove) { + objPtr = objPtr->internalRep.otherValuePtr; + } + fromPtr->firstObjPtr = objPtr->internalRep.otherValuePtr; + + /* + * Move all objects as a block - they are already linked to + * each other, we just have to update the first and last. + */ + + objPtr->internalRep.otherValuePtr = toPtr->firstObjPtr; + toPtr->firstObjPtr = fromFirstObjPtr; +} + + +/* + *---------------------------------------------------------------------- + * + * Block2Ptr, Ptr2Block -- + * + * Convert between internal blocks and user pointers. + * + * Results: + * User pointer or internal block. + * + * Side effects: + * Invalid blocks will abort the server. + * + *---------------------------------------------------------------------- + */ + +static char * +Block2Ptr(Block *blockPtr, int bucket, unsigned int reqsize) +{ + register void *ptr; + + blockPtr->b_magic1 = blockPtr->b_magic2 = MAGIC; + blockPtr->b_bucket = bucket; + blockPtr->b_reqsize = reqsize; + ptr = ((void *) (blockPtr + 1)); +#if RCHECK + ((unsigned char *)(ptr))[reqsize] = MAGIC; +#endif + return (char *) ptr; +} + +static Block * +Ptr2Block(char *ptr) +{ + register Block *blockPtr; + + blockPtr = (((Block *) ptr) - 1); + if (blockPtr->b_magic1 != MAGIC +#if RCHECK + || ((unsigned char *) ptr)[blockPtr->b_reqsize] != MAGIC +#endif + || blockPtr->b_magic2 != MAGIC) { + panic("alloc: invalid block: %p: %x %x %x\n", + blockPtr, blockPtr->b_magic1, blockPtr->b_magic2, + ((unsigned char *) ptr)[blockPtr->b_reqsize]); + } + return blockPtr; +} + + +/* + *---------------------------------------------------------------------- + * + * LockBucket, UnlockBucket -- + * + * Set/unset the lock to access a bucket in the shared cache. + * + * Results: + * None. + * + * Side effects: + * Lock activity and contention are monitored globally and on + * a per-cache basis. + * + *---------------------------------------------------------------------- + */ + +static void +LockBucket(Cache *cachePtr, int bucket) +{ +#if 0 + if (Tcl_MutexTryLock(binfo[bucket].lockPtr) != TCL_OK) { + Tcl_MutexLock(binfo[bucket].lockPtr); + ++cachePtr->buckets[bucket].nwait; + ++sharedPtr->buckets[bucket].nwait; + } +#else + Tcl_MutexLock(binfo[bucket].lockPtr); +#endif + ++cachePtr->buckets[bucket].nlock; + ++sharedPtr->buckets[bucket].nlock; +} + + +static void +UnlockBucket(Cache *cachePtr, int bucket) +{ + Tcl_MutexUnlock(binfo[bucket].lockPtr); +} + + +/* + *---------------------------------------------------------------------- + * + * PutBlocks -- + * + * Return unused blocks to the shared cache. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +PutBlocks(Cache *cachePtr, int bucket, int nmove) +{ + register Block *lastPtr, *firstPtr; + register int n = nmove; + + /* + * Before acquiring the lock, walk the block list to find + * the last block to be moved. + */ + + firstPtr = lastPtr = cachePtr->buckets[bucket].firstPtr; + while (--n > 0) { + lastPtr = lastPtr->b_next; + } + cachePtr->buckets[bucket].firstPtr = lastPtr->b_next; + cachePtr->buckets[bucket].nfree -= nmove; + + /* + * Aquire the lock and place the list of blocks at the front + * of the shared cache bucket. + */ + + LockBucket(cachePtr, bucket); + lastPtr->b_next = sharedPtr->buckets[bucket].firstPtr; + sharedPtr->buckets[bucket].firstPtr = firstPtr; + sharedPtr->buckets[bucket].nfree += nmove; + UnlockBucket(cachePtr, bucket); +} + + +/* + *---------------------------------------------------------------------- + * + * GetBlocks -- + * + * Get more blocks for a bucket. + * + * Results: + * 1 if blocks where allocated, 0 otherwise. + * + * Side effects: + * Cache may be filled with available blocks. + * + *---------------------------------------------------------------------- + */ + +static int +GetBlocks(Cache *cachePtr, int bucket) +{ + register Block *blockPtr; + register int n; + register size_t size; + + /* + * First, atttempt to move blocks from the shared cache. Note + * the potentially dirty read of nfree before acquiring the lock + * which is a slight performance enhancement. The value is + * verified after the lock is actually acquired. + */ + + if (cachePtr != sharedPtr && sharedPtr->buckets[bucket].nfree > 0) { + LockBucket(cachePtr, bucket); + if (sharedPtr->buckets[bucket].nfree > 0) { + + /* + * Either move the entire list or walk the list to find + * the last block to move. + */ + + n = binfo[bucket].nmove; + if (n >= sharedPtr->buckets[bucket].nfree) { + cachePtr->buckets[bucket].firstPtr = + sharedPtr->buckets[bucket].firstPtr; + cachePtr->buckets[bucket].nfree = + sharedPtr->buckets[bucket].nfree; + sharedPtr->buckets[bucket].firstPtr = NULL; + sharedPtr->buckets[bucket].nfree = 0; + } else { + blockPtr = sharedPtr->buckets[bucket].firstPtr; + cachePtr->buckets[bucket].firstPtr = blockPtr; + sharedPtr->buckets[bucket].nfree -= n; + cachePtr->buckets[bucket].nfree = n; + while (--n > 0) { + blockPtr = blockPtr->b_next; + } + sharedPtr->buckets[bucket].firstPtr = blockPtr->b_next; + blockPtr->b_next = NULL; + } + } + UnlockBucket(cachePtr, bucket); + } + + if (cachePtr->buckets[bucket].nfree == 0) { + + /* + * If no blocks could be moved from shared, first look for a + * larger block in this cache to split up. + */ + + blockPtr = NULL; + n = NBUCKETS; + size = 0; /* lint */ + while (--n > bucket) { + if (cachePtr->buckets[n].nfree > 0) { + size = binfo[n].blocksize; + blockPtr = cachePtr->buckets[n].firstPtr; + cachePtr->buckets[n].firstPtr = blockPtr->b_next; + --cachePtr->buckets[n].nfree; + break; + } + } + + /* + * Otherwise, allocate a big new block directly. + */ + + if (blockPtr == NULL) { + size = MAXALLOC; + blockPtr = malloc(size); + if (blockPtr == NULL) { + return 0; + } + } + + /* + * Split the larger block into smaller blocks for this bucket. + */ + + n = size / binfo[bucket].blocksize; + cachePtr->buckets[bucket].nfree = n; + cachePtr->buckets[bucket].firstPtr = blockPtr; + while (--n > 0) { + blockPtr->b_next = (Block *) + ((char *) blockPtr + binfo[bucket].blocksize); + blockPtr = blockPtr->b_next; + } + blockPtr->b_next = NULL; + } + return 1; +} + +#endif /* TCL_THREADS */ diff --git a/tcl/generic/tclThreadJoin.c b/tcl/generic/tclThreadJoin.c new file mode 100644 index 00000000000..d06c4dee016 --- /dev/null +++ b/tcl/generic/tclThreadJoin.c @@ -0,0 +1,311 @@ +/* + * tclThreadJoin.c -- + * + * This file implements a platform independent emulation layer for + * the handling of joinable threads. The Mac and Windows platforms + * use this code to provide the functionality of joining threads. + * This code is currently not necessary on Unix. + * + * Copyright (c) 2000 by Scriptics Corporation + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id$ + */ + +#include "tclInt.h" + +#if defined(WIN32) || defined(MAC_TCL) + +/* The information about each joinable thread is remembered in a + * structure as defined below. + */ + +typedef struct JoinableThread { + Tcl_ThreadId id; /* The id of the joinable thread */ + int result; /* A place for the result after the + * demise of the thread */ + int done; /* Boolean flag. Initialized to 0 + * and set to 1 after the exit of + * the thread. This allows a thread + * requesting a join to detect when + * waiting is not necessary. */ + int waitedUpon; /* Boolean flag. Initialized to 0 + * and set to 1 by the thread waiting + * for this one via Tcl_JoinThread. + * Used to lock any other thread + * trying to wait on this one. + */ + Tcl_Mutex threadMutex; /* The mutex used to serialize access + * to this structure. */ + Tcl_Condition cond; /* This is the condition a thread has + * to wait upon to get notified of the + * end of the described thread. It is + * signaled indirectly by + * Tcl_ExitThread. */ + struct JoinableThread* nextThreadPtr; /* Reference to the next thread in the + * list of joinable threads */ +} JoinableThread; + +/* The following variable is used to maintain the global list of all + * joinable threads. Usage by a thread is allowed only if the + * thread acquired the 'joinMutex'. + */ + +TCL_DECLARE_MUTEX(joinMutex) + +static JoinableThread* firstThreadPtr; + + + +/* + *---------------------------------------------------------------------- + * + * TclJoinThread -- + * + * This procedure waits for the exit of the thread with the specified + * id and returns its result. + * + * Results: + * A standard tcl result signaling the overall success/failure of the + * operation and an integer result delivered by the thread which was + * waited upon. + * + * Side effects: + * Deallocates the memory allocated by TclRememberJoinableThread. + * Removes the data associated to the thread waited upon from the + * list of joinable threads. + * + *---------------------------------------------------------------------- + */ + +int +TclJoinThread(id, result) + Tcl_ThreadId id; /* The id of the thread to wait upon. */ + int* result; /* Reference to a location for the result + * of the thread we are waiting upon. */ +{ + /* Steps done here: + * i. Acquire the joinMutex and search for the thread. + * ii. Error out if it could not be found. + * iii. If found, switch from exclusive access to the list to exclusive + * access to the thread structure. + * iv. Error out if some other is already waiting. + * v. Skip the waiting part of the thread is already done. + * vi. Wait for the thread to exit, mark it as waited upon too. + * vii. Get the result form the structure, + * viii. switch to exclusive access of the list, + * ix. remove the structure from the list, + * x. then switch back to exclusive access to the structure + * xi. and delete it. + */ + + JoinableThread* threadPtr; + + Tcl_MutexLock (&joinMutex); + + for (threadPtr = firstThreadPtr; + (threadPtr != (JoinableThread*) NULL) && (threadPtr->id != id); + threadPtr = threadPtr->nextThreadPtr) + /* empty body */ + ; + + if (threadPtr == (JoinableThread*) NULL) { + /* Thread not found. Either not joinable, or already waited + * upon and exited. Whatever, an error is in order. + */ + + Tcl_MutexUnlock (&joinMutex); + return TCL_ERROR; + } + + /* [1] If we don't lock the structure before giving up exclusive access + * to the list some other thread just completing its wait on the same + * thread can delete the structure from under us, leaving us with a + * dangling pointer. + */ + + Tcl_MutexLock (&threadPtr->threadMutex); + Tcl_MutexUnlock (&joinMutex); + + /* [2] Now that we have the structure mutex any other thread that just + * tries to delete structure will wait at location [3] until we are + * done with the structure. And in that case we are done with it + * rather quickly as 'waitedUpon' will be set and we will have to + * error out. + */ + + if (threadPtr->waitedUpon) { + Tcl_MutexUnlock (&threadPtr->threadMutex); + return TCL_ERROR; + } + + /* We are waiting now, let other threads recognize this + */ + + threadPtr->waitedUpon = 1; + + while (!threadPtr->done) { + Tcl_ConditionWait (&threadPtr->cond, &threadPtr->threadMutex, NULL); + } + + /* We have to release the structure before trying to access the list + * again or we can run into deadlock with a thread at [1] (see above) + * because of us holding the structure and the other holding the list. + * There is no problem with dangling pointers here as 'waitedUpon == 1' + * is still valid and any other thread will error out and not come to + * this place. IOW, the fact that we are here also means that no other + * thread came here before us and is able to delete the structure. + */ + + Tcl_MutexUnlock (&threadPtr->threadMutex); + Tcl_MutexLock (&joinMutex); + + /* We have to search the list again as its structure may (may, almost + * certainly) have changed while we were waiting. Especially now is the + * time to compute the predecessor in the list. Any earlier result can + * be dangling by now. + */ + + if (firstThreadPtr == threadPtr) { + firstThreadPtr = threadPtr->nextThreadPtr; + } else { + JoinableThread* prevThreadPtr; + + for (prevThreadPtr = firstThreadPtr; + prevThreadPtr->nextThreadPtr != threadPtr; + prevThreadPtr = prevThreadPtr->nextThreadPtr) + /* empty body */ + ; + + prevThreadPtr->nextThreadPtr = threadPtr->nextThreadPtr; + } + + Tcl_MutexUnlock (&joinMutex); + + /* [3] Now that the structure is not part of the list anymore no other + * thread can acquire its mutex from now on. But it is possible that + * another thread is still holding the mutex though, see location [2]. + * So we have to acquire the mutex one more time to wait for that thread + * to finish. We can (and have to) release the mutex immediately. + */ + + Tcl_MutexLock (&threadPtr->threadMutex); + Tcl_MutexUnlock (&threadPtr->threadMutex); + + /* Copy the result to us, finalize the synchronisation objects, then + * free the structure and return. + */ + + *result = threadPtr->result; + + Tcl_ConditionFinalize (&threadPtr->cond); + Tcl_MutexFinalize (&threadPtr->threadMutex); + ckfree ((VOID*) threadPtr); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclRememberJoinableThread -- + * + * This procedure remebers a thread as joinable. Only a call to + * TclJoinThread will remove the structre created (and initialized) + * here. IOW, not waiting upon a joinable thread will cause memory + * leaks. + * + * Results: + * None. + * + * Side effects: + * Allocates memory, adds it to the global list of all joinable + * threads. + * + *---------------------------------------------------------------------- + */ + +VOID +TclRememberJoinableThread(id) + Tcl_ThreadId id; /* The thread to remember as joinable */ +{ + JoinableThread* threadPtr; + + threadPtr = (JoinableThread*) ckalloc (sizeof (JoinableThread)); + threadPtr->id = id; + threadPtr->done = 0; + threadPtr->waitedUpon = 0; + threadPtr->threadMutex = (Tcl_Mutex) NULL; + threadPtr->cond = (Tcl_Condition) NULL; + + Tcl_MutexLock (&joinMutex); + + threadPtr->nextThreadPtr = firstThreadPtr; + firstThreadPtr = threadPtr; + + Tcl_MutexUnlock (&joinMutex); +} + +/* + *---------------------------------------------------------------------- + * + * TclSignalExitThread -- + * + * This procedure signals that the specified thread is done with + * its work. If the thread is joinable this signal is propagated + * to the thread waiting upon it. + * + * Results: + * None. + * + * Side effects: + * Modifies the associated structure to hold the result. + * + *---------------------------------------------------------------------- + */ + +VOID +TclSignalExitThread(id,result) + Tcl_ThreadId id; /* Id of the thread signaling its exit */ + int result; /* The result from the thread */ +{ + JoinableThread* threadPtr; + + Tcl_MutexLock (&joinMutex); + + for (threadPtr = firstThreadPtr; + (threadPtr != (JoinableThread*) NULL) && (threadPtr->id != id); + threadPtr = threadPtr->nextThreadPtr) + /* empty body */ + ; + + if (threadPtr == (JoinableThread*) NULL) { + /* Thread not found. Not joinable. No problem, nothing to do. + */ + + Tcl_MutexUnlock (&joinMutex); + return; + } + + /* Switch over the exclusive access from the list to the structure, + * then store the result, set the flag and notify the waiting thread, + * provided that it exists. The order of lock/unlock ensures that a + * thread entering 'TclJoinThread' will not interfere with us. + */ + + Tcl_MutexLock (&threadPtr->threadMutex); + Tcl_MutexUnlock (&joinMutex); + + threadPtr->done = 1; + threadPtr->result = result; + + if (threadPtr->waitedUpon) { + Tcl_ConditionNotify (&threadPtr->cond); + } + + Tcl_MutexUnlock (&threadPtr->threadMutex); +} + +#endif /* WIN32 || MAC_TCL */ diff --git a/tcl/generic/tclThreadTest.c b/tcl/generic/tclThreadTest.c index 25a3938a009..4f73ce7c55d 100644 --- a/tcl/generic/tclThreadTest.c +++ b/tcl/generic/tclThreadTest.c @@ -118,7 +118,7 @@ EXTERN int TclThread_Init _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN int Tcl_ThreadObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int TclCreateThread _ANSI_ARGS_((Tcl_Interp *interp, - CONST char *script)); + char *script, int joinable)); EXTERN int TclThreadList _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN int TclThreadSend _ANSI_ARGS_((Tcl_Interp *interp, Tcl_ThreadId id, char *script, int wait)); @@ -126,7 +126,7 @@ EXTERN int TclThreadSend _ANSI_ARGS_((Tcl_Interp *interp, Tcl_ThreadId id, #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT -Tcl_ThreadCreateType NewThread _ANSI_ARGS_((ClientData clientData)); +Tcl_ThreadCreateType NewTestThread _ANSI_ARGS_((ClientData clientData)); static void ListRemove _ANSI_ARGS_((ThreadSpecificData *tsdPtr)); static void ListUpdateInner _ANSI_ARGS_((ThreadSpecificData *tsdPtr)); static int ThreadEventProc _ANSI_ARGS_((Tcl_Event *evPtr, int mask)); @@ -175,13 +175,14 @@ TclThread_Init(interp) * This procedure is invoked to process the "testthread" Tcl command. * See the user documentation for details on what it does. * - * thread create + * thread create ?-joinable? ?script? * thread send id ?-async? script * thread exit * thread info id * thread names * thread wait * thread errorproc proc + * thread join id * * Results: * A standard Tcl result. @@ -202,10 +203,11 @@ Tcl_ThreadObjCmd(dummy, interp, objc, objv) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); int option; - static char *threadOptions[] = {"create", "exit", "id", "names", - "send", "wait", "errorproc", (char *) NULL}; - enum options {THREAD_CREATE, THREAD_EXIT, THREAD_ID, THREAD_NAMES, - THREAD_SEND, THREAD_WAIT, THREAD_ERRORPROC}; + static CONST char *threadOptions[] = {"create", "exit", "id", "join", "names", + "send", "wait", "errorproc", + (char *) NULL}; + enum options {THREAD_CREATE, THREAD_EXIT, THREAD_ID, THREAD_JOIN, + THREAD_NAMES, THREAD_SEND, THREAD_WAIT, THREAD_ERRORPROC}; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?args?"); @@ -231,15 +233,51 @@ Tcl_ThreadObjCmd(dummy, interp, objc, objv) switch ((enum options)option) { case THREAD_CREATE: { char *script; + int joinable, len; + if (objc == 2) { - script = "testthread wait"; /* Just enter the event loop */ + /* Neither joinable nor special script + */ + + joinable = 0; + script = "testthread wait"; /* Just enter the event loop */ + } else if (objc == 3) { - script = Tcl_GetString(objv[2]); + /* Possibly -joinable, then no special script, + * no joinable, then its a script. + */ + + script = Tcl_GetString(objv[2]); + len = strlen (script); + + if ((len > 1) && + (script [0] == '-') && (script [1] == 'j') && + (0 == strncmp (script, "-joinable", (size_t) len))) { + joinable = 1; + script = "testthread wait"; /* Just enter the event loop + */ + } else { + /* Remember the script */ + joinable = 0; + } + } else if (objc == 4) { + /* Definitely a script available, but is the flag + * -joinable ? + */ + + script = Tcl_GetString(objv[2]); + len = strlen (script); + + joinable = ((len > 1) && + (script [0] == '-') && (script [1] == 'j') && + (0 == strncmp (script, "-joinable", (size_t) len))); + + script = Tcl_GetString(objv[3]); } else { - Tcl_WrongNumArgs(interp, 2, objv, "?script?"); + Tcl_WrongNumArgs(interp, 2, objv, "?-joinable? ?script?"); return TCL_ERROR; } - return TclCreateThread(interp, script); + return TclCreateThread(interp, script, joinable); } case THREAD_EXIT: { if (objc > 2) { @@ -259,6 +297,28 @@ Tcl_ThreadObjCmd(dummy, interp, objc, objv) Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } + case THREAD_JOIN: { + long id; + int result, status; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "join id"); + return TCL_ERROR; + } + if (Tcl_GetLongFromObj(interp, objv[2], &id) != TCL_OK) { + return TCL_ERROR; + } + + result = Tcl_JoinThread ((Tcl_ThreadId) id, &status); + if (result == TCL_OK) { + Tcl_SetIntObj (Tcl_GetObjResult (interp), status); + } else { + char buf [20]; + sprintf (buf, "%ld", id); + Tcl_AppendResult (interp, "cannot join thread ", buf, NULL); + } + return result; + } case THREAD_NAMES: { if (objc > 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); @@ -343,20 +403,23 @@ Tcl_ThreadObjCmd(dummy, interp, objc, objv) /* ARGSUSED */ int -TclCreateThread(interp, script) +TclCreateThread(interp, script, joinable) Tcl_Interp *interp; /* Current interpreter. */ - CONST char *script; /* Script to execute */ + char *script; /* Script to execute */ + int joinable; /* Flag, joinable thread or not */ { ThreadCtrl ctrl; Tcl_ThreadId id; - ctrl.script = (char *) script; + ctrl.script = script; ctrl.condWait = NULL; ctrl.flags = 0; + joinable = joinable ? TCL_THREAD_JOINABLE : TCL_THREAD_NOFLAGS; + Tcl_MutexLock(&threadMutex); - if (Tcl_CreateThread(&id, NewThread, (ClientData) &ctrl, - TCL_THREAD_STACK_DEFAULT, TCL_THREAD_NOFLAGS) != TCL_OK) { + if (Tcl_CreateThread(&id, NewTestThread, (ClientData) &ctrl, + TCL_THREAD_STACK_DEFAULT, joinable) != TCL_OK) { Tcl_MutexUnlock(&threadMutex); Tcl_AppendResult(interp,"can't create a new thread",0); ckfree((void*)ctrl.script); @@ -377,7 +440,7 @@ TclCreateThread(interp, script) /* *------------------------------------------------------------------------ * - * NewThread -- + * NewTestThread -- * * This routine is the "main()" for a new thread whose task is to * execute a single TCL script. The argument to this function is @@ -403,7 +466,7 @@ TclCreateThread(interp, script) *------------------------------------------------------------------------ */ Tcl_ThreadCreateType -NewThread(clientData) +NewTestThread(clientData) ClientData clientData; { ThreadCtrl *ctrlPtr = (ThreadCtrl*)clientData; @@ -483,8 +546,8 @@ ThreadErrorProc(interp) Tcl_Interp *interp; /* Interp that failed */ { Tcl_Channel errChannel; - char *errorInfo, *script; - char *argv[3]; + CONST char *errorInfo, *argv[3]; + char *script; char buf[TCL_DOUBLE_SPACE+1]; sprintf(buf, "%ld", (long) Tcl_GetCurrentThread()); @@ -780,7 +843,7 @@ TclThreadSend(interp, id, script, wait) * *------------------------------------------------------------------------ */ -int +static int ThreadEventProc(evPtr, mask) Tcl_Event *evPtr; /* Really ThreadEvent */ int mask; @@ -790,7 +853,7 @@ ThreadEventProc(evPtr, mask) ThreadEventResult *resultPtr = threadEventPtr->resultPtr; Tcl_Interp *interp = tsdPtr->interp; int code; - char *result, *errorCode, *errorInfo; + CONST char *result, *errorCode, *errorInfo; if (interp == NULL) { code = TCL_ERROR; @@ -853,7 +916,7 @@ ThreadEventProc(evPtr, mask) *------------------------------------------------------------------------ */ /* ARGSUSED */ -void +static void ThreadFreeProc(clientData) ClientData clientData; { @@ -879,7 +942,7 @@ ThreadFreeProc(clientData) *------------------------------------------------------------------------ */ /* ARGSUSED */ -int +static int ThreadDeleteEvent(eventPtr, clientData) Tcl_Event *eventPtr; /* Really ThreadEvent */ ClientData clientData; /* dummy */ @@ -912,7 +975,7 @@ ThreadDeleteEvent(eventPtr, clientData) *------------------------------------------------------------------------ */ /* ARGSUSED */ -void +static void ThreadExitProc(clientData) ClientData clientData; { @@ -964,4 +1027,3 @@ ThreadExitProc(clientData) } #endif /* TCL_THREADS */ - diff --git a/tcl/generic/tclTimer.c b/tcl/generic/tclTimer.c index 4c39fe23c2a..84be1bbf37f 100644 --- a/tcl/generic/tclTimer.c +++ b/tcl/generic/tclTimer.c @@ -174,7 +174,7 @@ InitTimer() * None. * * Side effects: - * Removes the timer and idle event sources. + * Removes the timer and idle event sources and remaining events. * *---------------------------------------------------------------------- */ @@ -183,7 +183,19 @@ static void TimerExitProc(clientData) ClientData clientData; /* Not used. */ { + ThreadSpecificData *tsdPtr = + (ThreadSpecificData *) TclThreadDataKeyGet(&dataKey); + Tcl_DeleteEventSource(TimerSetupProc, TimerCheckProc, NULL); + if (tsdPtr != NULL) { + register TimerHandler *timerHandlerPtr; + timerHandlerPtr = tsdPtr->firstTimerHandlerPtr; + while (timerHandlerPtr != NULL) { + tsdPtr->firstTimerHandlerPtr = timerHandlerPtr->nextPtr; + ckfree((char *) timerHandlerPtr); + timerHandlerPtr = tsdPtr->firstTimerHandlerPtr; + } + } } /* @@ -224,7 +236,7 @@ Tcl_CreateTimerHandler(milliseconds, proc, clientData) * Compute when the event should fire. */ - TclpGetTime(&time); + Tcl_GetTime(&time); timerHandlerPtr->time.sec = time.sec + milliseconds/1000; timerHandlerPtr->time.usec = time.usec + (milliseconds%1000)*1000; if (timerHandlerPtr->time.usec >= 1000000) { @@ -350,7 +362,7 @@ TimerSetupProc(data, flags) * Compute the timeout for the next timer on the list. */ - TclpGetTime(&blockTime); + Tcl_GetTime(&blockTime); blockTime.sec = tsdPtr->firstTimerHandlerPtr->time.sec - blockTime.sec; blockTime.usec = tsdPtr->firstTimerHandlerPtr->time.usec - blockTime.usec; @@ -401,7 +413,7 @@ TimerCheckProc(data, flags) * Compute the timeout for the next timer on the list. */ - TclpGetTime(&blockTime); + Tcl_GetTime(&blockTime); blockTime.sec = tsdPtr->firstTimerHandlerPtr->time.sec - blockTime.sec; blockTime.usec = tsdPtr->firstTimerHandlerPtr->time.usec - blockTime.usec; @@ -500,7 +512,7 @@ TimerHandlerEventProc(evPtr, flags) tsdPtr->timerPending = 0; currentTimerId = tsdPtr->lastTimerId; - TclpGetTime(&time); + Tcl_GetTime(&time); while (1) { nextPtrPtr = &tsdPtr->firstTimerHandlerPtr; timerHandlerPtr = tsdPtr->firstTimerHandlerPtr; @@ -735,7 +747,9 @@ Tcl_AfterObjCmd(clientData, interp, objc, objv) char *argString; int index; char buf[16 + TCL_INTEGER_SPACE]; - static char *afterSubCmds[] = {"cancel", "idle", "info", (char *) NULL}; + static CONST char *afterSubCmds[] = { + "cancel", "idle", "info", (char *) NULL + }; enum afterSubCmds {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO}; ThreadSpecificData *tsdPtr = InitTimer(); diff --git a/tcl/generic/tclUniData.c b/tcl/generic/tclUniData.c index 612aba8e864..9f0c6e05ae0 100644 --- a/tcl/generic/tclUniData.c +++ b/tcl/generic/tclUniData.c @@ -1,5 +1,5 @@ /* - * tclUtfData.c -- + * tclUniData.c -- * * Declarations of Unicode character information tables. This file is * automatically generated by the tools/uniParse.tcl script. Do not @@ -26,44 +26,33 @@ */ static unsigned char pageMap[] = { - 0, 1, 2, 3, 0, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, - 19, 20, 21, 22, 23, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 7, 33, - 7, 34, 35, 16, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, - 49, 50, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, - 55, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 77, 78, - 81, 82, 77, 16, 16, 16, 16, 83, 84, 85, 16, 86, 87, 88, 16, 89, 90, - 91, 92, 93, 94, 16, 16, 16, 16, 16, 16, 16, 95, 96, 97, 47, 47, 98, - 47, 47, 99, 47, 100, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 7, - 7, 7, 7, 101, 7, 7, 102, 103, 104, 105, 106, 104, 107, 108, 109, 110, - 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122, 123, 124, - 125, 126, 126, 126, 126, 126, 126, 126, 127, 128, 129, 123, 130, 16, - 16, 16, 16, 123, 131, 125, 132, 133, 134, 135, 136, 123, 123, 123, - 123, 137, 123, 123, 138, 139, 123, 123, 138, 16, 16, 16, 16, 140, 141, - 142, 143, 144, 145, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 146, 147, 83, 47, 148, 83, 47, 149, 150, 151, 47, 47, 152, - 16, 16, 16, 153, 154, 155, 156, 154, 157, 158, 159, 123, 123, 123, - 160, 123, 123, 161, 159, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 47, 47, 47, 47, 47, 47, 47, + 0, 1, 2, 3, 0, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 7, 15, 16, 17, + 18, 19, 20, 21, 22, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 7, 32, + 7, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 47, + 48, 49, 50, 51, 52, 35, 47, 53, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, + 58, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 80, 81, + 84, 85, 80, 86, 87, 88, 89, 90, 91, 92, 35, 93, 94, 95, 35, 96, 97, + 98, 99, 100, 101, 102, 35, 47, 103, 104, 35, 35, 105, 106, 107, 47, + 47, 108, 47, 47, 109, 47, 110, 111, 47, 112, 47, 113, 114, 115, 116, + 114, 47, 117, 118, 35, 47, 47, 119, 90, 47, 47, 47, 47, 47, 47, 47, + 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 120, 121, 47, 47, 122, + 35, 35, 35, 35, 47, 123, 124, 125, 126, 47, 127, 128, 47, 129, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 7, 7, 7, 7, 130, 7, 7, 131, 132, 133, 134, + 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, 146, 147, 148, + 149, 150, 151, 152, 153, 154, 155, 156, 156, 156, 156, 156, 156, 156, + 157, 158, 159, 160, 161, 162, 35, 35, 35, 160, 163, 164, 165, 166, + 167, 168, 169, 160, 160, 160, 160, 170, 171, 172, 173, 174, 160, 160, + 175, 35, 35, 35, 35, 176, 177, 178, 179, 180, 181, 35, 35, 160, 160, + 160, 160, 160, 160, 160, 160, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 182, 160, 160, 155, 160, 160, 160, 160, 160, 160, 170, 183, 184, 185, + 90, 47, 186, 90, 47, 187, 188, 189, 47, 47, 190, 128, 35, 35, 191, + 192, 193, 194, 192, 195, 196, 197, 160, 160, 160, 198, 160, 160, 199, + 197, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, @@ -75,6 +64,7 @@ static unsigned char pageMap[] = { 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, + 47, 47, 200, 35, 35, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, @@ -102,12 +92,6 @@ static unsigned char pageMap[] = { 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 162, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, - 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, @@ -118,8 +102,13 @@ static unsigned char pageMap[] = { 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, + 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 201, 35, 35, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, + 202, 203, 204, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, @@ -128,29 +117,269 @@ static unsigned char pageMap[] = { 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 163, 16, 16, 164, 164, 164, 164, 164, 164, - 164, 164, 164, 164, 164, 164, 164, 164, 164, 164, 164, 164, 164, 164, - 164, 164, 164, 164, 164, 164, 164, 164, 164, 164, 164, 164, 164, 164, - 164, 164, 164, 164, 164, 164, 164, 164, 164, 164, 164, 164, 164, 164, - 164, 164, 164, 164, 164, 164, 164, 164, 164, 164, 164, 164, 164, 164, - 164, 164, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, - 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, - 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, - 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, - 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, - 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, - 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, - 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, - 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, - 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, - 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, - 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, - 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, - 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, - 165, 165, 165, 165, 165, 165, 47, 47, 47, 47, 47, 47, 47, 47, 47, 166, - 16, 16, 16, 16, 16, 16, 167, 168, 169, 47, 47, 170, 171, 47, 47, 47, - 47, 47, 47, 47, 47, 47, 47, 172, 173, 47, 174, 47, 175, 176, 16, 177, - 178, 179, 47, 47, 47, 180, 181, 2, 182, 183, 184, 185, 186, 187 + 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, + 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, + 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, + 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, + 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, + 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, + 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, + 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, + 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, + 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, + 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, + 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, + 47, 47, 205, 35, 35, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, + 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, + 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, + 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, + 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 207, 207, + 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, + 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, + 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, + 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, + 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, + 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, + 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, + 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, + 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, + 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, + 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, + 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, + 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, + 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, + 207, 207, 47, 47, 47, 47, 47, 47, 47, 47, 47, 208, 35, 35, 35, 35, + 35, 35, 209, 210, 211, 47, 47, 212, 213, 47, 47, 47, 47, 47, 47, 47, + 47, 47, 47, 214, 215, 47, 216, 47, 217, 218, 35, 219, 220, 221, 47, + 47, 47, 222, 223, 2, 224, 225, 226, 227, 228, 229, 230, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 231, 35, 232, 233, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, + 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, + 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, + 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, + 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, + 47, 208, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 47, 234, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 235, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, + 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, + 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, + 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, + 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, + 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, + 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, + 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, + 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, + 207, 207, 207, 236, 207, 207, 207, 207, 207, 207, 207, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, + 35, 35, 35, 35, 35 }; /* @@ -167,326 +396,413 @@ static unsigned char groupMap[] = { 10, 10, 10, 10, 10, 10, 5, 3, 6, 11, 12, 11, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 5, 7, 6, 7, 1, 2, 3, 4, 4, 4, 4, 14, 14, 11, 14, 15, 16, - 7, 8, 14, 11, 14, 7, 17, 17, 11, 15, 14, 3, 11, 17, 15, 18, 17, 17, + 7, 8, 14, 11, 14, 7, 17, 17, 11, 18, 14, 3, 11, 17, 15, 19, 17, 17, 17, 3, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 7, 10, 10, 10, 10, 10, 10, 10, 15, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, - 13, 13, 13, 13, 13, 13, 7, 13, 13, 13, 13, 13, 13, 13, 19, 20, 21, - 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, - 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, - 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 22, 23, 20, 21, 20, - 21, 20, 21, 15, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, - 21, 20, 21, 15, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, - 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, - 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 24, - 20, 21, 20, 21, 20, 21, 25, 15, 26, 20, 21, 20, 21, 27, 20, 21, 28, - 28, 20, 21, 15, 29, 30, 31, 20, 21, 28, 32, 15, 33, 34, 20, 21, 15, - 15, 33, 35, 15, 36, 20, 21, 20, 21, 20, 21, 37, 20, 21, 37, 38, 15, - 20, 21, 37, 20, 21, 39, 39, 20, 21, 20, 21, 40, 20, 21, 15, 38, 20, - 21, 38, 38, 38, 38, 38, 38, 41, 42, 43, 41, 42, 43, 41, 42, 43, 20, - 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 44, 20, - 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, - 15, 41, 42, 43, 20, 21, 0, 0, 0, 0, 20, 21, 20, 21, 20, 21, 20, 21, - 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, - 21, 20, 21, 20, 21, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 45, - 46, 15, 47, 47, 15, 48, 15, 49, 15, 15, 15, 15, 47, 15, 15, 50, 15, - 15, 15, 15, 51, 52, 15, 15, 15, 15, 15, 52, 15, 15, 53, 15, 15, 54, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 55, 15, 15, 55, 15, 15, 15, - 15, 55, 15, 56, 56, 15, 15, 15, 15, 15, 15, 57, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 0, 0, 0, 0, 0, 0, 0, 58, 58, 58, 58, 58, 58, 58, 58, 58, 11, 11, 58, - 58, 58, 58, 58, 58, 58, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, - 11, 11, 11, 58, 58, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, - 11, 0, 58, 58, 58, 58, 58, 11, 11, 11, 11, 11, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 59, 59, 59, 59, 59, 59, - 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, - 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 60, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 59, 59, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 11, 11, - 0, 0, 0, 0, 58, 0, 0, 0, 3, 0, 0, 0, 0, 0, 11, 11, 61, 3, 62, 62, 62, - 0, 63, 0, 64, 64, 15, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, - 10, 10, 10, 10, 10, 0, 10, 10, 10, 10, 10, 10, 10, 10, 10, 65, 66, - 66, 66, 15, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, - 13, 13, 13, 67, 13, 13, 13, 13, 13, 13, 13, 13, 13, 68, 69, 69, 0, - 70, 71, 72, 72, 72, 73, 74, 0, 0, 0, 72, 0, 72, 0, 72, 0, 72, 0, 20, - 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 75, 76, 44, 38, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 77, 77, 77, 77, 77, 77, 77, - 77, 77, 77, 77, 77, 0, 77, 77, 10, 10, 10, 10, 10, 10, 10, 10, 10, + 13, 13, 13, 13, 13, 13, 7, 13, 13, 13, 13, 13, 13, 13, 20, 21, 22, + 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, + 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, + 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 23, 24, 21, 22, 21, + 22, 21, 22, 15, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, + 22, 21, 22, 15, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, + 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, + 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 25, + 21, 22, 21, 22, 21, 22, 26, 15, 27, 21, 22, 21, 22, 28, 21, 22, 29, + 29, 21, 22, 15, 30, 31, 32, 21, 22, 29, 33, 34, 35, 36, 21, 22, 15, + 15, 35, 37, 15, 38, 21, 22, 21, 22, 21, 22, 39, 21, 22, 39, 15, 15, + 21, 22, 39, 21, 22, 40, 40, 21, 22, 21, 22, 41, 21, 22, 15, 42, 21, + 22, 15, 43, 42, 42, 42, 42, 44, 45, 46, 44, 45, 46, 44, 45, 46, 21, + 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 47, 21, + 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, + 15, 44, 45, 46, 21, 22, 48, 49, 21, 22, 21, 22, 21, 22, 21, 22, 0, + 0, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, + 21, 22, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 50, 51, 15, 52, 52, 15, 53, 15, + 54, 15, 15, 15, 15, 52, 15, 15, 55, 15, 15, 15, 15, 56, 57, 15, 15, + 15, 15, 15, 57, 15, 15, 58, 15, 15, 59, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 60, 15, 15, 60, 15, 15, 15, 15, 60, 15, 61, 61, 15, 15, + 15, 15, 15, 15, 62, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 63, + 63, 63, 63, 63, 63, 63, 63, 63, 11, 11, 63, 63, 63, 63, 63, 63, 63, + 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 63, 63, 11, + 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 63, 63, 63, 63, + 63, 11, 11, 11, 11, 11, 11, 11, 11, 11, 63, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, + 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, + 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 65, 64, 64, 64, 64, 64, 64, + 64, 64, 64, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 64, + 64, 64, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 11, 11, + 0, 0, 0, 0, 63, 0, 0, 0, 3, 0, 0, 0, 0, 0, 11, 11, 66, 3, 67, 67, 67, + 0, 68, 0, 69, 69, 15, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, + 10, 10, 10, 10, 10, 0, 10, 10, 10, 10, 10, 10, 10, 10, 10, 70, 71, + 71, 71, 15, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, + 13, 13, 13, 72, 13, 13, 13, 13, 13, 13, 13, 13, 13, 73, 74, 74, 0, + 75, 76, 77, 77, 77, 78, 79, 15, 0, 0, 21, 22, 21, 22, 21, 22, 21, 22, + 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 80, 81, 47, + 15, 82, 83, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 84, 84, 84, 84, 84, 84, 84, + 84, 84, 84, 84, 84, 84, 84, 84, 84, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, - 10, 10, 10, 10, 10, 10, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, + 10, 10, 10, 10, 10, 10, 10, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, - 13, 13, 13, 13, 0, 76, 76, 76, 76, 76, 76, 76, 76, 76, 76, 76, 76, - 0, 76, 76, 20, 21, 14, 59, 59, 59, 59, 0, 0, 0, 0, 0, 0, 0, 0, 0, 20, - 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 38, 20, - 21, 20, 21, 0, 0, 20, 21, 0, 0, 20, 21, 0, 0, 0, 20, 21, 20, 21, 20, - 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, - 20, 21, 20, 21, 20, 21, 0, 0, 20, 21, 20, 21, 20, 21, 20, 21, 0, 0, - 20, 21, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, - 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, - 78, 78, 78, 78, 78, 78, 0, 0, 58, 3, 3, 3, 3, 3, 3, 0, 79, 79, 79, - 79, 79, 79, 79, 79, 79, 79, 79, 79, 79, 79, 79, 79, 79, 79, 79, 79, - 79, 79, 79, 79, 79, 79, 79, 79, 79, 79, 79, 79, 79, 79, 79, 79, 79, - 79, 15, 0, 3, 0, 0, 0, 0, 0, 0, 0, 59, 59, 59, 59, 59, 59, 59, 59, - 59, 59, 59, 59, 59, 59, 59, 59, 59, 0, 59, 59, 59, 59, 59, 59, 59, - 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 0, - 59, 59, 59, 3, 59, 3, 59, 59, 3, 59, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 0, 0, 0, 0, 0, 38, 38, - 38, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0, 0, 0, - 3, 0, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 0, 0, 0, 0, 0, 58, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 59, 59, 59, 59, 59, 59, 59, 59, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, - 3, 3, 3, 0, 0, 59, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 0, 0, 38, 38, 38, 38, 38, 0, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 0, 38, 38, 38, - 38, 3, 38, 59, 59, 59, 59, 59, 59, 59, 80, 80, 59, 59, 59, 59, 59, - 59, 58, 58, 59, 59, 14, 59, 59, 59, 59, 0, 0, 9, 9, 9, 9, 9, 9, 9, - 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 59, 59, 81, 0, 38, 38, 38, 38, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 0, 0, 59, 38, 81, - 81, 81, 59, 59, 59, 59, 59, 59, 59, 59, 81, 81, 81, 81, 59, 0, 0, 38, - 59, 59, 59, 59, 0, 0, 0, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 59, - 59, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 59, 81, 81, 0, 38, 38, 38, 38, 38, 38, 38, - 38, 0, 0, 38, 38, 0, 0, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 0, 38, 38, 38, 38, 38, - 38, 38, 0, 38, 0, 0, 0, 38, 38, 38, 38, 0, 0, 59, 0, 81, 81, 81, 59, - 59, 59, 59, 0, 0, 81, 81, 0, 0, 81, 81, 59, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 81, 0, 0, 0, 0, 38, 38, 0, 38, 38, 38, 59, 59, 0, 0, 9, 9, 9, 9, - 9, 9, 9, 9, 9, 9, 38, 38, 4, 4, 17, 17, 17, 17, 17, 17, 14, 0, 0, 0, - 0, 0, 0, 0, 59, 0, 0, 38, 38, 38, 38, 38, 38, 0, 0, 0, 0, 38, 38, 0, - 0, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 38, 38, 38, 38, 38, 38, 0, 38, 38, 38, 38, 38, 38, 38, 0, 38, 38, 0, - 38, 38, 0, 38, 38, 0, 0, 59, 0, 81, 81, 81, 59, 59, 0, 0, 0, 0, 59, - 59, 0, 0, 59, 59, 59, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 38, 38, 38, - 38, 0, 38, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 59, 59, - 38, 38, 38, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 59, 59, 81, 0, 38, - 38, 38, 38, 38, 38, 38, 0, 38, 0, 38, 38, 38, 0, 38, 38, 38, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 0, 38, 38, 38, 38, 38, 38, 38, 0, 38, 38, 0, 38, 38, 38, 38, 38, 0, - 0, 59, 38, 81, 81, 81, 59, 59, 59, 59, 59, 0, 59, 59, 81, 0, 81, 81, - 59, 0, 0, 38, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 38, 0, 0, - 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 38, 38, 38, 38, 38, 38, 38, 38, 38, 0, 38, 38, 38, - 38, 38, 38, 38, 0, 38, 38, 0, 0, 38, 38, 38, 38, 0, 0, 59, 38, 81, - 59, 81, 59, 59, 59, 0, 0, 0, 81, 81, 0, 0, 81, 81, 59, 0, 0, 0, 0, - 0, 0, 0, 0, 59, 81, 0, 0, 0, 0, 38, 38, 0, 38, 38, 38, 0, 0, 0, 0, - 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 59, 81, 0, 38, 38, 38, 38, 38, 38, 0, 0, 0, 38, 38, - 38, 0, 38, 38, 38, 38, 0, 0, 0, 38, 38, 0, 38, 0, 38, 38, 0, 0, 0, - 38, 38, 0, 0, 0, 38, 38, 38, 0, 0, 0, 38, 38, 38, 38, 38, 38, 38, 38, - 0, 38, 38, 38, 0, 0, 0, 0, 81, 81, 59, 81, 81, 0, 0, 0, 81, 81, 81, - 0, 81, 81, 81, 59, 0, 0, 0, 0, 0, 0, 0, 0, 0, 81, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 17, 17, 17, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 81, 81, 81, 0, 38, 38, 38, 38, - 38, 38, 38, 38, 0, 38, 38, 38, 0, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 0, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 0, 38, 38, 38, 38, 38, 0, 0, 0, 0, - 59, 59, 59, 81, 81, 81, 81, 0, 59, 59, 59, 0, 59, 59, 59, 59, 0, 0, - 0, 0, 0, 0, 0, 59, 59, 0, 0, 0, 0, 0, 0, 0, 0, 0, 38, 38, 0, 0, 0, - 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 81, 81, 0, 38, 38, 38, 38, 38, 38, 38, 38, 0, 38, - 38, 38, 0, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 0, 38, 38, 38, 38, 38, 38, 38, - 38, 38, 38, 0, 38, 38, 38, 38, 38, 0, 0, 0, 0, 81, 59, 81, 81, 81, - 81, 81, 0, 59, 81, 81, 0, 81, 81, 59, 59, 0, 0, 0, 0, 0, 0, 0, 81, - 81, 0, 0, 0, 0, 0, 0, 0, 38, 0, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 0, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 0, 0, 0, 0, 81, 81, 81, 59, 59, 59, 0, 0, 81, 81, 81, 0, 81, 81, 81, - 59, 0, 0, 0, 0, 0, 0, 0, 0, 0, 81, 0, 0, 0, 0, 0, 0, 0, 0, 0, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 59, 38, 38, 59, 59, - 59, 59, 59, 59, 59, 0, 0, 0, 0, 4, 38, 38, 38, 38, 38, 38, 58, 59, - 59, 59, 59, 59, 59, 59, 59, 14, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, - 0, 0, 0, 0, 0, 38, 38, 0, 38, 0, 0, 38, 38, 0, 38, 0, 0, 38, 0, 0, - 0, 0, 0, 0, 38, 38, 38, 38, 0, 38, 38, 38, 38, 38, 38, 38, 0, 38, 38, - 38, 0, 38, 0, 38, 0, 0, 38, 38, 0, 38, 38, 38, 38, 59, 38, 38, 59, - 59, 59, 59, 59, 59, 0, 59, 59, 38, 0, 0, 38, 38, 38, 38, 38, 0, 58, - 0, 59, 59, 59, 59, 59, 59, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, - 38, 38, 0, 0, 38, 14, 14, 14, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, - 3, 3, 14, 14, 14, 14, 14, 59, 59, 14, 14, 14, 14, 14, 14, 9, 9, 9, - 9, 9, 9, 9, 9, 9, 9, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 14, 59, - 14, 59, 14, 59, 5, 6, 5, 6, 81, 81, 38, 38, 38, 38, 38, 38, 38, 38, - 0, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 0, 0, 0, 0, 0, 0, 0, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, - 59, 59, 81, 59, 59, 59, 59, 59, 3, 59, 59, 38, 38, 38, 38, 0, 0, 0, - 0, 59, 59, 59, 59, 59, 59, 0, 59, 0, 59, 59, 59, 59, 59, 59, 59, 59, - 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 0, 0, 0, 59, 59, - 59, 59, 59, 59, 59, 0, 59, 0, 0, 0, 0, 0, 0, 78, 78, 78, 78, 78, 78, - 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, - 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 3, 0, 0, 0, 0, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 0, 0, 0, 0, 0, 38, 38, 38, 38, - 0, 0, 0, 0, 0, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 38, 38, 38, 0, 0, 0, 0, 0, 0, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, - 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 15, 15, 15, 15, 15, - 82, 0, 0, 0, 0, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, - 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 0, 0, 0, 0, 0, - 0, 83, 83, 83, 83, 83, 83, 83, 83, 84, 84, 84, 84, 84, 84, 84, 84, - 83, 83, 83, 83, 83, 83, 0, 0, 84, 84, 84, 84, 84, 84, 0, 0, 83, 83, - 83, 83, 83, 83, 83, 83, 84, 84, 84, 84, 84, 84, 84, 84, 83, 83, 83, - 83, 83, 83, 83, 83, 84, 84, 84, 84, 84, 84, 84, 84, 83, 83, 83, 83, - 83, 83, 0, 0, 84, 84, 84, 84, 84, 84, 0, 0, 15, 83, 15, 83, 15, 83, - 15, 83, 0, 84, 0, 84, 0, 84, 0, 84, 83, 83, 83, 83, 83, 83, 83, 83, - 84, 84, 84, 84, 84, 84, 84, 84, 85, 85, 86, 86, 86, 86, 87, 87, 88, - 88, 89, 89, 90, 90, 0, 0, 83, 83, 83, 83, 83, 83, 83, 83, 84, 84, 84, - 84, 84, 84, 84, 84, 83, 83, 15, 91, 15, 0, 15, 15, 84, 84, 92, 92, - 93, 11, 94, 11, 11, 11, 15, 91, 15, 0, 15, 15, 95, 95, 95, 95, 93, - 11, 11, 11, 83, 83, 15, 15, 0, 0, 15, 15, 84, 84, 96, 96, 0, 11, 11, - 11, 83, 83, 15, 15, 15, 97, 15, 15, 84, 84, 98, 98, 99, 11, 11, 11, - 0, 0, 15, 91, 15, 0, 15, 15, 100, 100, 101, 101, 93, 11, 11, 0, 2, - 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 102, 102, 102, 102, 8, 8, 8, 8, 8, - 8, 3, 3, 16, 18, 5, 16, 16, 18, 5, 16, 3, 3, 3, 3, 3, 3, 3, 3, 103, - 104, 102, 102, 102, 102, 102, 0, 3, 3, 3, 3, 3, 3, 3, 3, 3, 16, 18, - 3, 3, 3, 3, 12, 12, 3, 3, 3, 7, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 13, 13, 13, 13, 13, 81, 81, 81, 81, 81, 81, 81, 81, 81, 81, 81, 81, + 81, 81, 81, 81, 21, 22, 14, 64, 64, 64, 64, 0, 85, 85, 0, 0, 21, 22, + 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, + 22, 77, 21, 22, 21, 22, 0, 0, 21, 22, 0, 0, 21, 22, 0, 0, 0, 21, 22, + 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, + 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, + 21, 22, 0, 0, 21, 22, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 102, 102, 102, 102, 102, 102, 17, 0, 0, 0, 17, 17, 17, 17, 17, - 17, 7, 7, 7, 5, 6, 15, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 7, 7, - 7, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 4, 4, - 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 59, - 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 80, 80, 80, 80, 59, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 86, 86, 86, 86, + 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, + 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, + 0, 0, 63, 3, 3, 3, 3, 3, 3, 0, 87, 87, 87, 87, 87, 87, 87, 87, 87, + 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, + 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, 15, 0, 3, 8, 0, 0, + 0, 0, 0, 0, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, + 64, 64, 64, 0, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, + 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 0, 64, 64, 64, 3, 64, 3, 64, + 64, 3, 64, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 0, 0, 0, 0, 0, 42, 42, 42, 3, 3, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0, 0, 0, 3, 0, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 0, 0, 0, 0, 0, 63, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 3, 3, 0, 0, 64, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 3, 42, 64, + 64, 64, 64, 64, 64, 64, 85, 85, 64, 64, 64, 64, 64, 64, 63, 63, 64, + 64, 14, 64, 64, 64, 64, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 42, 42, + 42, 14, 14, 0, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 0, 88, 42, + 64, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0, 0, 64, 64, 64, 64, + 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, + 64, 64, 64, 64, 64, 64, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 42, 42, 42, 42, 42, 42, 64, 64, 64, 64, 64, 64, 64, + 64, 64, 64, 64, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 64, + 64, 89, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 0, 0, 64, 42, 89, 89, 89, 64, 64, 64, 64, 64, 64, + 64, 64, 89, 89, 89, 89, 64, 0, 0, 42, 64, 64, 64, 64, 0, 0, 0, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 64, 64, 3, 3, 9, 9, 9, 9, 9, 9, + 9, 9, 9, 9, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 64, + 89, 89, 0, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0, 42, 42, 0, 0, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 0, 42, 42, 42, 42, 42, 42, 42, 0, 42, 0, 0, 0, 42, + 42, 42, 42, 0, 0, 64, 0, 89, 89, 89, 64, 64, 64, 64, 0, 0, 89, 89, + 0, 0, 89, 89, 64, 0, 0, 0, 0, 0, 0, 0, 0, 0, 89, 0, 0, 0, 0, 42, 42, + 0, 42, 42, 42, 64, 64, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 42, 42, + 4, 4, 17, 17, 17, 17, 17, 17, 14, 0, 0, 0, 0, 0, 0, 0, 64, 0, 0, 42, + 42, 42, 42, 42, 42, 0, 0, 0, 0, 42, 42, 0, 0, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, + 42, 42, 42, 42, 42, 42, 42, 0, 42, 42, 0, 42, 42, 0, 42, 42, 0, 0, + 64, 0, 89, 89, 89, 64, 64, 0, 0, 0, 0, 64, 64, 0, 0, 64, 64, 64, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, 42, 42, 42, 0, 42, 0, 0, 0, 0, 0, + 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 64, 64, 42, 42, 42, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 64, 64, 89, 0, 42, 42, 42, 42, 42, 42, 42, + 0, 42, 0, 42, 42, 42, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 42, 42, 42, 42, 42, + 42, 42, 0, 42, 42, 0, 42, 42, 42, 42, 42, 0, 0, 64, 42, 89, 89, 89, + 64, 64, 64, 64, 64, 0, 64, 64, 89, 0, 89, 89, 64, 0, 0, 42, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, 0, 0, 0, 0, 0, 9, 9, 9, 9, + 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 0, 42, 42, 42, 42, 42, 42, 42, 0, 42, + 42, 0, 0, 42, 42, 42, 42, 0, 0, 64, 42, 89, 64, 89, 64, 64, 64, 0, + 0, 0, 89, 89, 0, 0, 89, 89, 64, 0, 0, 0, 0, 0, 0, 0, 0, 64, 89, 0, + 0, 0, 0, 42, 42, 0, 42, 42, 42, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, + 9, 9, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 64, 89, + 0, 42, 42, 42, 42, 42, 42, 0, 0, 0, 42, 42, 42, 0, 42, 42, 42, 42, + 0, 0, 0, 42, 42, 0, 42, 0, 42, 42, 0, 0, 0, 42, 42, 0, 0, 0, 42, 42, + 42, 0, 0, 0, 42, 42, 42, 42, 42, 42, 42, 42, 0, 42, 42, 42, 0, 0, 0, + 0, 89, 89, 64, 89, 89, 0, 0, 0, 89, 89, 89, 0, 89, 89, 89, 64, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 89, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 17, 17, 17, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 89, 89, 89, 0, 42, 42, 42, 42, 42, 42, 42, 42, 0, 42, + 42, 42, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 0, 42, 42, 42, 42, 42, 0, 0, 0, 0, 64, 64, 64, 89, 89, + 89, 89, 0, 64, 64, 64, 0, 64, 64, 64, 64, 0, 0, 0, 0, 0, 0, 0, 64, + 64, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, 42, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, + 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 89, + 89, 0, 42, 42, 42, 42, 42, 42, 42, 42, 0, 42, 42, 42, 0, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 42, 42, 42, + 42, 42, 0, 0, 0, 0, 89, 64, 89, 89, 89, 89, 89, 0, 64, 89, 89, 0, 89, + 89, 64, 64, 0, 0, 0, 0, 0, 0, 0, 89, 89, 0, 0, 0, 0, 0, 0, 0, 42, 0, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0, 0, 0, 89, 89, 89, 64, 64, + 64, 0, 0, 89, 89, 89, 0, 89, 89, 89, 64, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 89, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 89, 89, 0, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0, 0, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 42, 0, 0, + 42, 42, 42, 42, 42, 42, 42, 0, 0, 0, 64, 0, 0, 0, 0, 89, 89, 89, 64, + 64, 64, 0, 64, 0, 89, 89, 89, 89, 89, 89, 89, 89, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 89, 89, 3, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 64, 42, 42, 64, 64, 64, 64, 64, 64, 64, 0, 0, 0, 0, 4, 42, 42, + 42, 42, 42, 42, 63, 64, 64, 64, 64, 64, 64, 64, 64, 3, 9, 9, 9, 9, + 9, 9, 9, 9, 9, 9, 3, 3, 0, 0, 0, 0, 0, 42, 42, 0, 42, 0, 0, 42, 42, + 0, 42, 0, 0, 42, 0, 0, 0, 0, 0, 0, 42, 42, 42, 42, 0, 42, 42, 42, 42, + 42, 42, 42, 0, 42, 42, 42, 0, 42, 0, 42, 0, 0, 42, 42, 0, 42, 42, 42, + 42, 64, 42, 42, 64, 64, 64, 64, 64, 64, 0, 64, 64, 42, 0, 0, 42, 42, + 42, 42, 42, 0, 63, 0, 64, 64, 64, 64, 64, 64, 0, 0, 9, 9, 9, 9, 9, + 9, 9, 9, 9, 9, 0, 0, 42, 42, 0, 0, 42, 14, 14, 14, 3, 3, 3, 3, 3, 3, + 3, 3, 3, 3, 3, 3, 3, 3, 3, 14, 14, 14, 14, 14, 64, 64, 14, 14, 14, + 14, 14, 14, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 14, 64, 14, 64, 14, 64, 5, 6, 5, 6, 89, 89, 42, 42, 42, + 42, 42, 42, 42, 42, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 0, 0, 0, 0, 0, 0, 64, 64, 64, 64, 64, 64, 64, + 64, 64, 64, 64, 64, 64, 64, 89, 64, 64, 64, 64, 64, 3, 64, 64, 42, + 42, 42, 42, 0, 0, 0, 0, 64, 64, 64, 64, 64, 64, 64, 64, 0, 64, 64, + 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, + 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, + 0, 14, 14, 14, 14, 14, 14, 14, 14, 64, 14, 14, 14, 14, 14, 14, 0, 0, + 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, 42, 0, 42, + 42, 42, 42, 42, 0, 42, 42, 0, 89, 64, 64, 64, 64, 89, 64, 0, 0, 0, + 64, 64, 89, 64, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, + 3, 3, 3, 3, 3, 42, 42, 42, 42, 42, 42, 89, 89, 64, 64, 0, 0, 0, 0, + 0, 0, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, + 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, + 77, 77, 77, 77, 77, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 0, 0, 0, 0, 3, 0, 0, 0, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, + 0, 0, 0, 0, 42, 42, 42, 42, 0, 0, 0, 0, 0, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0, 0, 0, 0, 0, 42, 42, 42, + 42, 42, 42, 42, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 0, 42, 0, 42, 42, 42, 42, 0, 0, 42, 42, 42, 42, 42, 42, 42, + 0, 42, 0, 42, 42, 42, 42, 0, 0, 42, 42, 42, 42, 42, 42, 42, 0, 42, + 0, 42, 42, 42, 42, 0, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 0, 42, 0, 42, 42, 42, 42, 0, 0, 42, 42, 42, 42, 42, 42, + 42, 0, 42, 0, 42, 42, 42, 42, 0, 0, 42, 42, 42, 42, 42, 42, 42, 0, + 42, 42, 42, 42, 42, 42, 42, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, + 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 0, 0, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 3, 3, 42, 42, 42, 42, 42, + 42, 42, 42, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 5, 6, 0, 0, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 3, 3, 3, 90, 90, 90, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 89, 89, 89, 64, 64, 64, 64, 64, 64, 64, 89, 89, 89, 89, 89, + 89, 89, 89, 64, 89, 89, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, + 3, 3, 3, 3, 3, 3, 3, 4, 3, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, + 3, 3, 3, 3, 8, 3, 3, 3, 3, 88, 88, 88, 88, 0, 9, 9, 9, 9, 9, 9, 9, + 9, 9, 9, 0, 0, 0, 0, 0, 0, 42, 42, 42, 63, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0, 0, 0, 0, 0, 0, + 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 64, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 21, 22, 21, 22, 21, 22, 21, + 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 15, 15, + 15, 15, 15, 91, 0, 0, 0, 0, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, + 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 0, + 0, 0, 0, 0, 0, 92, 92, 92, 92, 92, 92, 92, 92, 93, 93, 93, 93, 93, + 93, 93, 93, 92, 92, 92, 92, 92, 92, 0, 0, 93, 93, 93, 93, 93, 93, 0, + 0, 92, 92, 92, 92, 92, 92, 92, 92, 93, 93, 93, 93, 93, 93, 93, 93, + 92, 92, 92, 92, 92, 92, 92, 92, 93, 93, 93, 93, 93, 93, 93, 93, 92, + 92, 92, 92, 92, 92, 0, 0, 93, 93, 93, 93, 93, 93, 0, 0, 15, 92, 15, + 92, 15, 92, 15, 92, 0, 93, 0, 93, 0, 93, 0, 93, 92, 92, 92, 92, 92, + 92, 92, 92, 93, 93, 93, 93, 93, 93, 93, 93, 94, 94, 95, 95, 95, 95, + 96, 96, 97, 97, 98, 98, 99, 99, 0, 0, 92, 92, 92, 92, 92, 92, 92, 92, + 100, 100, 100, 100, 100, 100, 100, 100, 92, 92, 92, 92, 92, 92, 92, + 92, 100, 100, 100, 100, 100, 100, 100, 100, 92, 92, 92, 92, 92, 92, + 92, 92, 100, 100, 100, 100, 100, 100, 100, 100, 92, 92, 15, 101, 15, + 0, 15, 15, 93, 93, 102, 102, 103, 11, 104, 11, 11, 11, 15, 101, 15, + 0, 15, 15, 105, 105, 105, 105, 103, 11, 11, 11, 92, 92, 15, 15, 0, + 0, 15, 15, 93, 93, 106, 106, 0, 11, 11, 11, 92, 92, 15, 15, 15, 107, + 15, 15, 93, 93, 108, 108, 109, 11, 11, 11, 0, 0, 15, 101, 15, 0, 15, + 15, 110, 110, 111, 111, 103, 11, 11, 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 88, 88, 88, 88, 8, 8, 8, 8, 8, 8, 3, 3, 16, 19, 5, 16, 16, + 19, 5, 16, 3, 3, 3, 3, 3, 3, 3, 3, 112, 113, 88, 88, 88, 88, 88, 2, + 3, 3, 3, 3, 3, 3, 3, 3, 3, 16, 19, 3, 3, 3, 3, 12, 12, 3, 3, 3, 7, + 5, 6, 0, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 88, 88, 88, 88, 88, 88, 17, + 0, 0, 0, 17, 17, 17, 17, 17, 17, 7, 7, 7, 5, 6, 15, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 17, 7, 7, 7, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 14, 14, 72, 14, 14, 14, 14, 72, 14, 14, 15, 72, - 72, 72, 15, 15, 72, 72, 72, 15, 14, 72, 14, 14, 15, 72, 72, 72, 72, - 72, 14, 14, 14, 14, 14, 14, 72, 14, 72, 14, 72, 14, 72, 72, 72, 72, - 15, 15, 72, 72, 14, 72, 15, 38, 38, 38, 38, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 17, 17, 17, - 17, 17, 17, 17, 17, 17, 17, 17, 17, 105, 105, 105, 105, 105, 105, 105, - 105, 105, 105, 105, 105, 105, 105, 105, 105, 106, 106, 106, 106, 106, - 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 107, 107, 107, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 7, 7, 7, 7, 7, 14, 14, 14, 14, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, + 64, 64, 64, 85, 85, 85, 85, 64, 85, 85, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 77, + 14, 14, 14, 14, 77, 14, 14, 15, 77, 77, 77, 15, 15, 77, 77, 77, 15, + 14, 77, 14, 14, 14, 77, 77, 77, 77, 77, 14, 14, 14, 14, 14, 14, 77, + 14, 114, 14, 77, 14, 115, 116, 77, 77, 14, 15, 77, 77, 14, 77, 15, + 42, 42, 42, 42, 15, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, + 117, 117, 117, 117, 117, 118, 118, 118, 118, 118, 118, 118, 118, 118, + 118, 118, 118, 118, 118, 118, 118, 90, 90, 90, 90, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 7, 7, 14, 14, + 14, 14, 7, 14, 14, 7, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 14, 14, 7, + 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 7, 7, 14, 14, 14, 14, 14, 14, 14, 5, 6, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 7, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 7, 7, 7, 7, 7, 7, 7, - 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, - 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 0, 14, 14, 14, 14, 14, 14, 7, - 7, 7, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 7, 7, 14, 14, 14, 14, 14, 14, 14, 5, 6, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 14, - 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, - 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 108, 108, 108, 108, 108, 108, 108, - 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, - 108, 108, 108, 108, 108, 109, 109, 109, 109, 109, 109, 109, 109, 109, - 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, - 109, 109, 109, 17, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 119, 119, 119, 119, 119, 119, + 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, + 119, 119, 119, 119, 119, 119, 120, 120, 120, 120, 120, 120, 120, 120, + 120, 120, 120, 120, 120, 120, 120, 120, 120, 120, 120, 120, 120, 120, + 120, 120, 120, 120, 17, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, - 0, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 14, 0, 14, 14, 14, 14, 0, - 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 0, 14, - 14, 14, 14, 0, 0, 0, 14, 0, 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14, - 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 17, + 14, 14, 14, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 7, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, + 14, 14, 14, 0, 14, 14, 14, 14, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 0, 14, 0, 14, 14, 14, 14, 0, 0, 0, 14, 0, 14, 14, + 14, 14, 14, 14, 14, 0, 0, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, - 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 14, 0, 0, 0, 14, 14, 14, + 17, 17, 17, 14, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 0, 2, 3, 3, 3, 14, 58, 38, 107, 5, 6, 5, 6, 5, 6, 5, 6, 5, - 6, 14, 14, 5, 6, 5, 6, 5, 6, 5, 6, 8, 5, 6, 6, 14, 107, 107, 107, 107, - 107, 107, 107, 107, 107, 59, 59, 59, 59, 59, 59, 8, 58, 58, 58, 58, - 58, 14, 14, 0, 0, 0, 0, 0, 0, 0, 14, 38, 38, 38, 38, 38, 38, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 0, 0, 0, 0, 59, - 59, 11, 11, 58, 58, 0, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 12, - 58, 58, 58, 0, 0, 0, 0, 0, 0, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 0, 0, 0, 0, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 0, 14, 14, 17, 17, - 17, 17, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 0, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, + 0, 0, 0, 2, 3, 3, 3, 14, 63, 42, 90, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, + 14, 14, 5, 6, 5, 6, 5, 6, 5, 6, 8, 5, 6, 6, 14, 90, 90, 90, 90, 90, + 90, 90, 90, 90, 64, 64, 64, 64, 64, 64, 8, 63, 63, 63, 63, 63, 14, + 14, 90, 90, 90, 0, 0, 0, 14, 14, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0, 0, 0, 64, 64, + 11, 11, 63, 63, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 12, 63, + 63, 63, 0, 0, 0, 0, 0, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0, 0, 0, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 14, 14, 17, 17, 17, + 17, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 17, 17, 17, 17, 17, 17, 17, 17, - 17, 17, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, + 14, 14, 14, 14, 14, 14, 0, 0, 0, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 38, 38, 38, 38, 38, - 38, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 38, 38, 38, 38, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 110, 110, 110, 110, - 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, - 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, - 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, - 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, - 111, 111, 111, 111, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 38, 38, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, - 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, - 15, 15, 0, 0, 0, 0, 0, 0, 59, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 7, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 0, 38, 38, 38, - 38, 38, 0, 38, 0, 38, 38, 0, 38, 38, 0, 38, 38, 38, 38, 38, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 38, 38, 38, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 38, 38, 38, 38, 38, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 38, 38, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 0, 0, 38, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 38, 38, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 0, 0, 0, 0, 59, 59, 59, 59, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, 42, 42, 42, 42, 42, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0, 0, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 0, 14, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 42, 42, 42, 42, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 121, 121, 121, 121, 121, 121, 121, + 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, + 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, 122, 122, 122, + 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, + 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, + 122, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, + 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 0, + 0, 0, 0, 0, 42, 64, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 7, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 42, 42, 42, 42, + 42, 0, 42, 0, 42, 42, 0, 42, 42, 0, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0, 0, 0, 64, 64, 64, 64, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 8, 8, 12, 12, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 0, 0, 0, 0, 3, 3, 3, 3, 12, 12, 12, 3, 3, 3, 0, 3, 3, 3, 3, 8, 5, 6, 5, 6, 5, 6, 3, 3, 3, 7, 8, 7, 7, 7, - 0, 3, 4, 3, 3, 0, 0, 0, 0, 38, 38, 38, 0, 38, 0, 38, 38, 38, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 0, 0, 102, 0, 3, 3, 3, 4, 3, 3, 3, 5, 6, 3, 7, 3, 8, 3, 3, 9, 9, 9, + 0, 3, 4, 3, 3, 0, 0, 0, 0, 42, 42, 42, 0, 42, 0, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 0, 0, 88, 0, 3, 3, 3, 4, 3, 3, 3, 5, 6, 3, 7, 3, 8, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 7, 7, 7, 3, 11, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, - 13, 13, 13, 5, 7, 6, 7, 0, 0, 3, 5, 6, 3, 12, 38, 38, 38, 38, 38, 38, - 38, 38, 38, 38, 58, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 58, - 58, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, - 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 0, 0, 0, - 38, 38, 38, 38, 38, 38, 0, 0, 38, 38, 38, 38, 38, 38, 0, 0, 38, 38, - 38, 38, 38, 38, 0, 0, 38, 38, 38, 0, 0, 0, 4, 4, 7, 11, 14, 4, 4, 0, - 14, 7, 7, 7, 7, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, - 14, 0, 0 + 13, 13, 13, 5, 7, 6, 7, 0, 0, 3, 5, 6, 3, 12, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 63, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 63, + 63, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, + 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0, 0, + 42, 42, 42, 42, 42, 42, 0, 0, 42, 42, 42, 42, 42, 42, 0, 0, 42, 42, + 42, 42, 42, 42, 0, 0, 42, 42, 42, 0, 0, 0, 4, 4, 7, 11, 14, 4, 4, 0, + 14, 7, 7, 7, 7, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 88, 88, 88, 14, + 14, 42, 17, 42, 42, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 123, 123, 123, + 126, 126, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 89, 64, 14, 14, 14, + 14, 14, 0, 0, 77, 77, 15, 15, 77, 15, 15, 77, 77, 15, 77, 77, 15, 77, + 77, 15, 15, 77, 15, 15, 77, 77, 15, 77, 77, 15, 77, 77, 15, 15, 77, + 15, 15, 77, 77, 15, 77, 77, 15, 77, 77, 15, 15, 77, 77, 15, 15, 77, + 15, 15, 77, 77, 15, 15, 77, 15, 15, 77, 77, 15, 15, 9, 9, 9, 42, 42, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 88, 0, 88, 88, 88, 88, 88, 88, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 122, 122, + 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, + 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, + 122 }; /* @@ -510,21 +826,23 @@ static unsigned char groupMap[] = { static int groups[] = { 0, 15, 12, 25, 27, 21, 22, 26, 20, 9, 134217793, 28, 19, 134217858, - 29, 2, 23, 11, 24, -507510654, 4194369, 4194434, -834666431, 973078658, - -507510719, 1258291330, 880803905, 864026689, 859832385, 331350081, - 847249473, 851443777, 868220993, 884998209, 876609601, 893386817, - 897581121, 914358337, 5, 910164033, 918552641, 8388705, 4194499, - 8388770, 331350146, 880803970, 864026754, 859832450, 847249538, - 851443842, 868221058, 876609666, 884998274, 893386882, 897581186, - 914358402, 910164098, 918552706, 4, 6, -352321338, 159383617, - 155189313, 268435521, 264241217, 159383682, 155189378, 130023554, - 268435586, 264241282, 260046978, 239075458, 1, 197132418, 226492546, - 360710274, 335544450, 335544385, 201326657, 201326722, 7, 8, 247464066, - -33554302, -33554367, -310378366, -360710014, -419430270, -536870782, - -469761918, -528482174, -37748606, -310378431, -37748671, 155189442, - -360710079, -419430335, -29359998, -469761983, -29360063, -536870847, - -528482239, 16, 13, 14, 67108938, 67109002, 10, 109051997, 109052061, - 18, 17 + 29, 2, 23, 11, 1178599554, 24, -507510654, 4194369, 4194434, -834666431, + 973078658, -507510719, 1258291330, 880803905, 864026689, 859832385, + 331350081, 847249473, 851443777, 868220993, -406847358, 884998209, + 876609601, 893386817, 897581121, 914358337, 910164033, 918552641, + 5, -234880894, 8388705, 4194499, 8388770, 331350146, -406847423, + -234880959, 880803970, 864026754, 859832450, 847249538, 851443842, + 868221058, 876609666, 884998274, 893386882, 897581186, 914358402, + 910164098, 918552706, 4, 6, -352321402, 159383617, 155189313, + 268435521, 264241217, 159383682, 155189378, 130023554, 268435586, + 264241282, 260046978, 239075458, 1, 197132418, 226492546, 360710274, + 335544450, -251658175, 402653314, 335544385, 7, 201326657, 201326722, + 16, 8, 10, 247464066, -33554302, -33554367, -310378366, -360710014, + -419430270, -536870782, -469761918, -528482174, -33554365, -37748606, + -310378431, -37748669, 155189378, -360710079, -419430335, -29359998, + -469761983, -29360063, -536870847, -528482239, 13, 14, -1463812031, + -801111999, -293601215, 67108938, 67109002, 109051997, 109052061, + 18, 17, 8388673, 12582977, 8388738, 12583042 }; /* @@ -575,7 +893,7 @@ enum { #define GetCaseType(info) (((info) & 0xE0) >> 5) #define GetCategory(info) ((info) & 0x1F) -#define GetDelta(infO) (((info) > 0) ? ((info) >> 22) : (~(~((info)) >> 22))) +#define GetDelta(info) (((info) > 0) ? ((info) >> 22) : (~(~((info)) >> 22))) /* * This macro extracts the information about a character from the diff --git a/tcl/generic/tclUtf.c b/tcl/generic/tclUtf.c index 5f6826ddf01..8ba7bb56655 100644 --- a/tcl/generic/tclUtf.c +++ b/tcl/generic/tclUtf.c @@ -61,8 +61,8 @@ * The following structures are used when mapping between Unicode (UCS-2) * and UTF-8. */ - -CONST unsigned char totalBytes[256] = { + +static CONST unsigned char totalBytes[256] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, @@ -111,7 +111,7 @@ static int UtfCount _ANSI_ARGS_((int ch)); *--------------------------------------------------------------------------- */ -static int +INLINE static int UtfCount(ch) int ch; /* The Tcl_UniChar whose size is returned. */ { @@ -309,7 +309,7 @@ Tcl_UtfToUniChar(str, chPtr) * Also treats \0 and naked trail bytes 0x80 to 0xBF as valid * characters representing themselves. */ - + *chPtr = (Tcl_UniChar) byte; return 1; } else if (byte < 0xE0) { @@ -317,7 +317,7 @@ Tcl_UtfToUniChar(str, chPtr) /* * Two-byte-character lead-byte followed by a trail-byte. */ - + *chPtr = (Tcl_UniChar) (((byte & 0x1F) << 6) | (str[1] & 0x3F)); return 2; } @@ -325,7 +325,7 @@ Tcl_UtfToUniChar(str, chPtr) * A two-byte-character lead-byte not followed by trail-byte * represents itself. */ - + *chPtr = (Tcl_UniChar) byte; return 1; } else if (byte < 0xF0) { @@ -536,7 +536,7 @@ Tcl_NumUtfChars(str, len) * *--------------------------------------------------------------------------- */ -char * +CONST char * Tcl_UtfFindFirst(string, ch) CONST char *string; /* The UTF-8 string to be searched. */ int ch; /* The Tcl_UniChar to search for. */ @@ -547,7 +547,7 @@ Tcl_UtfFindFirst(string, ch) while (1) { len = Tcl_UtfToUniChar(string, &find); if (find == ch) { - return (char *) string; + return string; } if (*string == '\0') { return NULL; @@ -576,7 +576,7 @@ Tcl_UtfFindFirst(string, ch) *--------------------------------------------------------------------------- */ -char * +CONST char * Tcl_UtfFindLast(string, ch) CONST char *string; /* The UTF-8 string to be searched. */ int ch; /* The Tcl_UniChar to search for. */ @@ -596,7 +596,7 @@ Tcl_UtfFindLast(string, ch) } string += len; } - return (char *) last; + return last; } /* @@ -619,13 +619,13 @@ Tcl_UtfFindLast(string, ch) *--------------------------------------------------------------------------- */ -char * +CONST char * Tcl_UtfNext(str) CONST char *str; /* The current location in the string. */ { Tcl_UniChar ch; - return (char *) str + Tcl_UtfToUniChar(str, &ch); + return str + Tcl_UtfToUniChar(str, &ch); } /* @@ -634,7 +634,8 @@ Tcl_UtfNext(str) * Tcl_UtfPrev -- * * Given a pointer to some current location in a UTF-8 string, - * move backwards one character. + * move backwards one character. This works correctly when the + * pointer is in the middle of a UTF-8 character. * * Results: * The return value is a pointer to the previous character in the @@ -648,7 +649,7 @@ Tcl_UtfNext(str) *--------------------------------------------------------------------------- */ -char * +CONST char * Tcl_UtfPrev(str, start) CONST char *str; /* The current location in the string. */ CONST char *start; /* Pointer to the beginning of the @@ -670,16 +671,13 @@ Tcl_UtfPrev(str, start) byte = *((unsigned char *) look); if (byte < 0x80) { break; - } + } if (byte >= 0xC0) { - if (totalBytes[byte] != i + 1) { - break; - } - return (char *) look; + return look; } look--; } - return (char *) str; + return str; } /* @@ -730,7 +728,7 @@ Tcl_UniCharAtIndex(src, index) *--------------------------------------------------------------------------- */ -char * +CONST char * Tcl_UtfAtIndex(src, index) register CONST char *src; /* The UTF-8 string. */ register int index; /* The position of the desired character. */ @@ -741,7 +739,7 @@ Tcl_UtfAtIndex(src, index) index--; src += Tcl_UtfToUniChar(src, &ch); } - return (char *) src; + return src; } /* @@ -780,118 +778,19 @@ Tcl_UtfBackslash(src, readPtr, dst) char *dst; /* Filled with the bytes represented by the * backslash sequence. */ { - register CONST char *p = src+1; - int result, count, n; - char buf[TCL_UTF_MAX]; - - if (dst == NULL) { - dst = buf; +#define LINE_LENGTH 128 + int numRead; + int result; + + result = TclParseBackslash(src, LINE_LENGTH, &numRead, dst); + if (numRead == LINE_LENGTH) { + /* We ate a whole line. Pay the price of a strlen() */ + result = TclParseBackslash(src, (int)strlen(src), &numRead, dst); } - - count = 2; - switch (*p) { - /* - * Note: in the conversions below, use absolute values (e.g., - * 0xa) rather than symbolic values (e.g. \n) that get converted - * by the compiler. It's possible that compilers on some - * platforms will do the symbolic conversions differently, which - * could result in non-portable Tcl scripts. - */ - - case 'a': - result = 0x7; - break; - case 'b': - result = 0x8; - break; - case 'f': - result = 0xc; - break; - case 'n': - result = 0xa; - break; - case 'r': - result = 0xd; - break; - case 't': - result = 0x9; - break; - case 'v': - result = 0xb; - break; - case 'x': - if (isxdigit(UCHAR(p[1]))) { /* INTL: digit */ - char *end; - - result = (unsigned char) strtoul(p+1, &end, 16); - count = end - src; - } else { - count = 2; - result = 'x'; - } - break; - case 'u': - result = 0; - for (count = 0; count < 4; count++) { - p++; - if (!isxdigit(UCHAR(*p))) { /* INTL: digit */ - break; - } - n = *p - '0'; - if (n > 9) { - n = n + '0' + 10 - 'A'; - } - if (n > 16) { - n = n + 'A' - 'a'; - } - result = (result << 4) + n; - } - if (count == 0) { - result = 'u'; - } - count += 2; - break; - - case '\n': - do { - p++; - } while ((*p == ' ') || (*p == '\t')); - result = ' '; - count = p - src; - break; - case 0: - result = '\\'; - count = 1; - break; - default: - /* - * Check for an octal number \oo?o? - */ - if (isdigit(UCHAR(*p)) && (UCHAR(*p) < '8')) { /* INTL: digit */ - result = (unsigned char)(*p - '0'); - p++; - if (!isdigit(UCHAR(*p)) || (UCHAR(*p) >= '8')) { /* INTL: digit */ - break; - } - count = 3; - result = (unsigned char)((result << 3) + (*p - '0')); - p++; - if (!isdigit(UCHAR(*p)) || (UCHAR(*p) >= '8')) { /* INTL: digit */ - break; - } - count = 4; - result = (unsigned char)((result << 3) + (*p - '0')); - break; - } - result = *p; - count = 2; - break; - } - if (readPtr != NULL) { - *readPtr = count; + *readPtr = numRead; } - return Tcl_UniCharToUtf(result, dst); + return result; } /* @@ -1065,6 +964,51 @@ Tcl_UtfToTitle(str) /* *---------------------------------------------------------------------- * + * TclpUtfNcmp2 -- + * + * Compare at most n bytes of utf-8 strings cs and ct. Both cs + * and ct are assumed to be at least n bytes long. + * + * Results: + * Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclpUtfNcmp2(cs, ct, n) + CONST char *cs; /* UTF string to compare to ct. */ + CONST char *ct; /* UTF string cs is compared to. */ + unsigned long n; /* Number of *bytes* to compare. */ +{ + /* + * We can't simply call 'memcmp(cs, ct, n);' because we need to check + * for Tcl's \xC0\x80 non-utf-8 null encoding. + * Otherwise utf-8 lexes fine in the strcmp manner. + */ + register int result = 0; + + for ( ; n != 0; n--, cs++, ct++) { + if (*cs != *ct) { + result = UCHAR(*cs) - UCHAR(*ct); + break; + } + } + if (n && ((UCHAR(*cs) == 0xC0) || (UCHAR(*ct) == 0xC0))) { + unsigned char c1, c2; + c1 = ((UCHAR(*cs) == 0xC0) && (UCHAR(cs[1]) == 0x80)) ? 0 : UCHAR(*cs); + c2 = ((UCHAR(*ct) == 0xC0) && (UCHAR(ct[1]) == 0x80)) ? 0 : UCHAR(*ct); + result = (c1 - c2); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_UtfNcmp -- * * Compare at most n UTF chars of string cs to string ct. Both cs @@ -1087,11 +1031,9 @@ Tcl_UtfNcmp(cs, ct, n) { Tcl_UniChar ch1, ch2; /* - * Another approach that should work is: - * return memcmp(cs, ct, (unsigned) (Tcl_UtfAtIndex(cs, n) - cs)); - * That assumes that ct is a properly formed UTF, so we will just - * be comparing the bytes that compromise those strings to the - * char length n. + * Cannot use 'memcmp(cs, ct, n);' as byte representation of + * \u0000 (the pair of bytes 0xc0,0x80) is larger than byte + * representation of \u0001 (the byte 0x01.) */ while (n-- > 0) { /* @@ -1265,7 +1207,7 @@ Tcl_UniCharToTitle(ch) int Tcl_UniCharLen(str) - Tcl_UniChar *str; /* Unicode string to find length of. */ + CONST Tcl_UniChar *str; /* Unicode string to find length of. */ { int len = 0; @@ -1299,12 +1241,53 @@ Tcl_UniCharNcmp(cs, ct, n) CONST Tcl_UniChar *ct; /* Unicode string cs is compared to. */ unsigned long n; /* Number of unichars to compare. */ { - for ( ; n != 0; n--, cs++, ct++) { +#ifdef WORDS_BIGENDIAN + /* + * We are definitely on a big-endian machine; memcmp() is safe + */ + return memcmp(cs, ct, n*sizeof(Tcl_UniChar)); + +#else /* !WORDS_BIGENDIAN */ + /* + * We can't simply call memcmp() because that is not lexically correct. + */ + for ( ; n != 0; cs++, ct++, n--) { if (*cs != *ct) { - return *cs - *ct; + return (*cs - *ct); } - if (*cs == '\0') { - break; + } + return 0; +#endif /* WORDS_BIGENDIAN */ +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UniCharNcasecmp -- + * + * Compare at most n unichars of string cs to string ct case + * insensitive. Both cs and ct are assumed to be at least n + * unichars long. + * + * Results: + * Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_UniCharNcasecmp(cs, ct, n) + CONST Tcl_UniChar *cs; /* Unicode string to compare to ct. */ + CONST Tcl_UniChar *ct; /* Unicode string cs is compared to. */ + unsigned long n; /* Number of unichars to compare. */ +{ + for ( ; n != 0; n--, cs++, ct++) { + if ((*cs != *ct) && + (Tcl_UniCharToLower(*cs) != Tcl_UniCharToLower(*ct))) { + return (*cs - *ct); } } return 0; @@ -1584,3 +1567,182 @@ Tcl_UniCharIsWordChar(ch) return (((ALPHA_BITS | DIGIT_BITS | CONNECTOR_BITS) >> category) & 1); } + +/* + *---------------------------------------------------------------------- + * + * Tcl_UniCharCaseMatch -- + * + * See if a particular Unicode string matches a particular pattern. + * Allows case insensitivity. This is the Unicode equivalent of + * the char* Tcl_StringCaseMatch. + * + * Results: + * The return value is 1 if string matches pattern, and + * 0 otherwise. The matching operation permits the following + * special characters in the pattern: *?\[] (see the manual + * entry for details on what these mean). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_UniCharCaseMatch(string, pattern, nocase) + CONST Tcl_UniChar *string; /* Unicode String. */ + CONST Tcl_UniChar *pattern; /* Pattern, which may contain special + * characters. */ + int nocase; /* 0 for case sensitive, 1 for insensitive */ +{ + Tcl_UniChar ch1, p; + + while (1) { + p = *pattern; + + /* + * 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 (*string == 0); + } + if ((*string == 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 (*(++pattern) == '*') {} + p = *pattern; + 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 (*string && (p != *string) + && (p != Tcl_UniCharToLower(*string))) { + string++; + } + } else { + while (*string && (p != *string)) { string++; } + } + } + if (Tcl_UniCharCaseMatch(string, pattern, nocase)) { + return 1; + } + if (*string == 0) { + return 0; + } + string++; + } + } + + /* + * Check for a "?" as the next pattern character. It matches + * any single character. + */ + + if (p == '?') { + pattern++; + string++; + 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 == '[') { + Tcl_UniChar startChar, endChar; + + pattern++; + ch1 = (nocase ? Tcl_UniCharToLower(*string) : *string); + string++; + while (1) { + if ((*pattern == ']') || (*pattern == 0)) { + return 0; + } + startChar = (nocase ? Tcl_UniCharToLower(*pattern) : *pattern); + pattern++; + if (*pattern == '-') { + pattern++; + if (*pattern == 0) { + return 0; + } + endChar = (nocase ? Tcl_UniCharToLower(*pattern) + : *pattern); + pattern++; + 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 (*pattern != ']') { + if (*pattern == 0) { + pattern--; + break; + } + pattern++; + } + pattern++; + continue; + } + + /* + * If the next pattern character is '\', just strip off the '\' + * so we do exact matching on the character that follows. + */ + + if (p == '\\') { + if (*(++pattern) == '\0') { + return 0; + } + } + + /* + * There's no special character. Just make sure that the next + * bytes of each string match. + */ + + if (nocase) { + if (Tcl_UniCharToLower(*string) != Tcl_UniCharToLower(*pattern)) { + return 0; + } + } else if (*string != *pattern) { + return 0; + } + string++; + pattern++; + } +} diff --git a/tcl/generic/tclUtil.c b/tcl/generic/tclUtil.c index 041036b80fd..4e71f668f96 100644 --- a/tcl/generic/tclUtil.c +++ b/tcl/generic/tclUtil.c @@ -6,6 +6,7 @@ * * 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. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -62,6 +63,30 @@ static char precisionFormat[10] = "%.12g"; * to sprintf. */ TCL_DECLARE_MUTEX(precisionMutex) +/* + * Prototypes for procedures defined later in this file. + */ + +static void UpdateStringOfEndOffset _ANSI_ARGS_((Tcl_Obj* objPtr)); +static int SetEndOffsetFromAny _ANSI_ARGS_((Tcl_Interp* interp, + Tcl_Obj* objPtr)); + +/* + * 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. + */ + +Tcl_ObjType tclEndOffsetType = { + "end-offset", /* name */ + (Tcl_FreeInternalRepProc*) NULL, /* freeIntRepProc */ + (Tcl_DupInternalRepProc*) NULL, /* dupIntRepProc */ + UpdateStringOfEndOffset, /* updateStringProc */ + SetEndOffsetFromAny +}; + /* *---------------------------------------------------------------------- @@ -318,11 +343,11 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr, * Copy a string and eliminate any backslashes that aren't in braces. * * Results: - * There is no return value. Count characters get copied from src to - * dst. Along the way, if backslash sequences are found outside braces, - * the backslashes are eliminated in the copy. After scanning count - * chars from source, a null character is placed at the end of dst. - * Returns the number of characters that got copied. + * Count characters get copied from src to dst. Along the way, if + * backslash sequences are found outside braces, the backslashes are + * eliminated in the copy. After scanning count chars from source, a + * null character is placed at the end of dst. Returns the number + * of characters that got copied. * * Side effects: * None. @@ -395,10 +420,10 @@ Tcl_SplitList(interp, list, argcPtr, argvPtr) CONST char *list; /* Pointer to string with list structure. */ int *argcPtr; /* Pointer to location to fill in with * the number of elements in the list. */ - char ***argvPtr; /* Pointer to place to store pointer to + CONST char ***argvPtr; /* Pointer to place to store pointer to * array of pointers to list elements. */ { - char **argv; + CONST char **argv; CONST char *l; char *p; int length, size, i, result, elSize, brace; @@ -417,7 +442,7 @@ Tcl_SplitList(interp, list, argcPtr, argvPtr) } } size++; /* Leave space for final NULL pointer. */ - argv = (char **) ckalloc((unsigned) + argv = (CONST char **) ckalloc((unsigned) ((size * sizeof(char *)) + (l - list) + 1)); length = strlen(list); for (i = 0, p = ((char *) argv) + size*sizeof(char *); @@ -822,7 +847,7 @@ Tcl_ConvertCountedElement(src, length, dst, flags) char * Tcl_Merge(argc, argv) int argc; /* How many strings to merge. */ - char **argv; /* Array of string values. */ + CONST char * CONST *argv; /* Array of string values. */ { # define LOCAL_SIZE 20 int localFlags[LOCAL_SIZE], *flagPtr; @@ -925,7 +950,7 @@ Tcl_Backslash(src, readPtr) char * Tcl_Concat(argc, argv) int argc; /* Number of strings to concatenate. */ - char **argv; /* Array of strings to concatenate. */ + CONST char * CONST *argv; /* Array of strings to concatenate. */ { int totalSize, i; char *p; @@ -940,7 +965,7 @@ Tcl_Concat(argc, argv) return result; } for (p = result, i = 0; i < argc; i++) { - char *element; + CONST char *element; int length; /* @@ -1071,8 +1096,8 @@ Tcl_ConcatObj(objc, objv) for (i = 0; i < objc; i++) { objPtr = objv[i]; element = Tcl_GetStringFromObj(objPtr, &elemLength); - while ((elemLength > 0) - && (isspace(UCHAR(*element)))) { /* INTL: ISO space. */ + while ((elemLength > 0) && (UCHAR(*element) < 127) + && isspace(UCHAR(*element))) { /* INTL: ISO C space. */ element++; elemLength--; } @@ -1083,8 +1108,8 @@ Tcl_ConcatObj(objc, objv) * this case it could be significant. */ - while ((elemLength > 0) - && isspace(UCHAR(element[elemLength-1])) /* INTL: ISO space. */ + while ((elemLength > 0) && (UCHAR(element[elemLength-1]) < 127) + && isspace(UCHAR(element[elemLength-1])) /* INTL: ISO C space. */ && ((elemLength < 2) || (element[elemLength-2] != '\\'))) { elemLength--; } @@ -1136,131 +1161,7 @@ Tcl_StringMatch(string, pattern) CONST char *pattern; /* Pattern, which may contain special * characters. */ { - int p, s; - CONST char *pstart = pattern; - - while (1) { - p = *pattern; - s = *string; - - /* - * See if we're at the end of both the pattern and the string. If - * so, we succeeded. If we're at the end of the pattern but not at - * the end of the string, we failed. - */ - - if (p == '\0') { - if (s == '\0') { - return 1; - } else { - return 0; - } - } - if ((s == '\0') && (p != '*')) { - return 0; - } - - /* Check for a "*" as the next pattern character. It matches - * any substring. We handle this by calling ourselves - * recursively for each postfix of string, until either we - * match or we reach the end of the string. - */ - - if (p == '*') { - pattern++; - if (*pattern == '\0') { - return 1; - } - while (1) { - if (Tcl_StringMatch(string, pattern)) { - return 1; - } - if (*string == '\0') { - return 0; - } - string++; - } - } - - /* Check for a "?" as the next pattern character. It matches - * any single character. - */ - - if (p == '?') { - Tcl_UniChar ch; - - pattern++; - string += Tcl_UtfToUniChar(string, &ch); - 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 == '[') { - Tcl_UniChar ch, startChar, endChar; - - pattern++; - string += Tcl_UtfToUniChar(string, &ch); - - while (1) { - if ((*pattern == ']') || (*pattern == '\0')) { - return 0; - } - pattern += Tcl_UtfToUniChar(pattern, &startChar); - if (*pattern == '-') { - pattern++; - if (*pattern == '\0') { - return 0; - } - pattern += Tcl_UtfToUniChar(pattern, &endChar); - if (((startChar <= ch) && (ch <= endChar)) - || ((endChar <= ch) && (ch <= startChar))) { - /* - * Matches ranges of form [a-z] or [z-a]. - */ - - break; - } - } else if (startChar == ch) { - break; - } - } - while (*pattern != ']') { - if (*pattern == '\0') { - pattern = Tcl_UtfPrev(pattern, pstart); - break; - } - pattern++; - } - pattern++; - continue; - } - - /* If the next pattern character is '\', just strip off the '\' - * so we do exact matching on the character that follows. - */ - - if (p == '\\') { - pattern++; - p = *pattern; - if (p == '\0') { - return 0; - } - } - - /* There's no special character. Just make sure that the next - * bytes of each string match. - */ - - if (s != p) { - return 0; - } - pattern++; - string++; - } + return Tcl_StringCaseMatch(string, pattern, 0); } /* @@ -1290,13 +1191,12 @@ Tcl_StringCaseMatch(string, pattern, nocase) * characters. */ int nocase; /* 0 for case sensitive, 1 for insensitive */ { - int p, s; + int p; CONST char *pstart = pattern; Tcl_UniChar ch1, ch2; while (1) { p = *pattern; - s = *string; /* * See if we're at the end of both the pattern and the string. If @@ -1305,35 +1205,74 @@ Tcl_StringCaseMatch(string, pattern, nocase) */ if (p == '\0') { - return (s == '\0'); + return (*string == '\0'); } - if ((s == '\0') && (p != '*')) { + if ((*string == '\0') && (p != '*')) { return 0; } - /* Check for a "*" as the next pattern character. It matches + /* + * Check for a "*" as the next pattern character. It matches * any substring. We handle this by calling ourselves * recursively for each postfix of string, until either we * match or we reach the end of the string. */ if (p == '*') { - pattern++; - if (*pattern == '\0') { + /* + * Skip all successive *'s in the pattern + */ + while (*(++pattern) == '*') {} + p = *pattern; + if (p == '\0') { return 1; } + Tcl_UtfToUniChar(pattern, &ch2); + if (nocase) { + ch2 = Tcl_UniCharToLower(ch2); + } 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 (*string) { + int charLen = Tcl_UtfToUniChar(string, &ch1); + if (ch2==ch1 || ch2==Tcl_UniCharToLower(ch1)) { + break; + } + string += charLen; + } + } else { + /* + * There's no point in trying to make this code + * shorter, as the number of bytes you want to + * compare each time is non-constant. + */ + while (*string) { + int charLen = Tcl_UtfToUniChar(string, &ch1); + if (ch2 == ch1) { + break; + } + string += charLen; + } + } + } if (Tcl_StringCaseMatch(string, pattern, nocase)) { return 1; } if (*string == '\0') { return 0; } - string++; + string += Tcl_UtfToUniChar(string, &ch1); } } - /* Check for a "?" as the next pattern character. It matches + /* + * Check for a "?" as the next pattern character. It matches * any single character. */ @@ -1343,11 +1282,12 @@ Tcl_StringCaseMatch(string, pattern, nocase) continue; } - /* Check for a "[" as the next pattern character. It is followed + /* + * 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 == '[') { Tcl_UniChar startChar, endChar; @@ -1396,22 +1336,23 @@ Tcl_StringCaseMatch(string, pattern, nocase) continue; } - /* If the next pattern character is '\', just strip off the '\' + /* + * If the next pattern character is '\', just strip off the '\' * so we do exact matching on the character that follows. */ - + if (p == '\\') { pattern++; - p = *pattern; - if (p == '\0') { + if (*pattern == '\0') { return 0; } } - /* There's no special character. Just make sure that the next + /* + * There's no special character. Just make sure that the next * bytes of each string match. */ - + string += Tcl_UtfToUniChar(string, &ch1); pattern += Tcl_UtfToUniChar(pattern, &ch2); if (nocase) { @@ -1547,10 +1488,12 @@ Tcl_DStringAppendElement(dsPtr, string) CONST char *string; /* String to append. Must be * null-terminated. */ { - int newSize, flags; + int newSize, flags, strSize; char *dst; - newSize = Tcl_ScanElement(string, &flags) + dsPtr->length + 1; + strSize = ((string == NULL) ? 0 : strlen(string)); + newSize = Tcl_ScanCountedElement(string, strSize, &flags) + + dsPtr->length + 1; /* * Allocate a larger buffer for the string if the current one isn't @@ -1587,7 +1530,7 @@ Tcl_DStringAppendElement(dsPtr, string) dst++; dsPtr->length++; } - dsPtr->length += Tcl_ConvertElement(string, dst, flags); + dsPtr->length += Tcl_ConvertCountedElement(string, strSize, dst, flags); return dsPtr->string; } @@ -1935,11 +1878,12 @@ char * TclPrecTraceProc(clientData, interp, name1, name2, flags) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Interpreter containing variable. */ - char *name1; /* Name of variable. */ - char *name2; /* Second part of variable name. */ + CONST char *name1; /* Name of variable. */ + CONST char *name2; /* Second part of variable name. */ int flags; /* Information about what happened. */ { - char *value, *end; + CONST char *value; + char *end; int prec; /* @@ -2022,10 +1966,12 @@ TclPrecTraceProc(clientData, interp, name1, name2, flags) int TclNeedSpace(start, end) - char *start; /* First character in string. */ - char *end; /* End of string (place where space will + CONST char *start; /* First character in string. */ + CONST char *end; /* End of string (place where space will * be added, if appropriate). */ { + Tcl_UniChar ch; + /* * A space is needed unless either * (a) we're at the start of the string, or @@ -2039,10 +1985,14 @@ TclNeedSpace(start, end) if (end == start) { return 0; } - end--; + end = Tcl_UtfPrev(end, start); if (*end != '{') { - if (isspace(UCHAR(*end)) /* INTL: ISO space. */ - && ((end == start) || (end[-1] != '\\'))) { + Tcl_UtfToUniChar(end, &ch); + /* + * Direct char comparison on next line is safe as it is with + * a character in the ASCII subset, and so single-byte in UTF8. + */ + if (Tcl_UniCharIsSpace(ch) && ((end == start) || (end[-1] != '\\'))) { return 0; } return 1; @@ -2051,9 +2001,10 @@ TclNeedSpace(start, end) if (end == start) { return 0; } - end--; + end = Tcl_UtfPrev(end, start); } while (*end == '{'); - if (isspace(UCHAR(*end))) { /* INTL: ISO space. */ + Tcl_UtfToUniChar(end, &ch); + if (Tcl_UniCharIsSpace(ch)) { return 0; } return 1; @@ -2167,44 +2118,34 @@ TclFormatInt(buffer, n) int TclLooksLikeInt(bytes, length) - register char *bytes; /* Points to first byte of the string. */ + register CONST char *bytes; /* Points to first byte of the string. */ int length; /* Number of bytes in the string. If < 0 * bytes up to the first null byte are * considered (if they may appear in an * integer). */ { - register char *p, *end; + register CONST char *p; + + if ((bytes == NULL) && (length > 0)) { + Tcl_Panic("TclLooksLikeInt: cannot scan %d bytes from NULL", length); + } if (length < 0) { - length = (bytes? strlen(bytes) : 0); + length = (bytes? strlen(bytes) : 0); } - end = (bytes + length); p = bytes; - while ((p < end) && isspace(UCHAR(*p))) { /* INTL: ISO space. */ - p++; + while (length && isspace(UCHAR(*p))) { /* INTL: ISO space. */ + length--; p++; } - if (p == end) { - return 0; + if (length == 0) { + return 0; } - if ((*p == '+') || (*p == '-')) { - p++; - } - if ((p == end) || !isdigit(UCHAR(*p))) { /* INTL: digit */ - return 0; - } - p++; - while ((p < end) && isdigit(UCHAR(*p))) { /* INTL: digit */ - p++; - } - if (p == end) { - return 1; - } - if ((*p != '.') && (*p != 'e') && (*p != 'E')) { - return 1; + p++; length--; } - return 0; + + return (0 != TclParseInteger(p, length)); } /* @@ -2228,7 +2169,7 @@ TclLooksLikeInt(bytes, length) * * Side effects: * The object referenced by "objPtr" might be converted to an - * integer object. + * integer, wide integer, or end-based-index object. * *---------------------------------------------------------------------- */ @@ -2246,26 +2187,193 @@ TclGetIntForIndex(interp, objPtr, endValue, indexPtr) * representing an index. */ { char *bytes; - int length, offset; + int offset; +#ifndef TCL_WIDE_INT_IS_LONG + Tcl_WideInt wideOffset; +#endif + + /* + * If the object is already an integer, use it. + */ if (objPtr->typePtr == &tclIntType) { *indexPtr = (int)objPtr->internalRep.longValue; return TCL_OK; } - bytes = Tcl_GetStringFromObj(objPtr, &length); + /* + * If the object is already a wide-int, and it is not out of range + * for an integer, use it. [Bug #526717] + */ +#ifndef TCL_WIDE_INT_IS_LONG + if (objPtr->typePtr == &tclWideIntType) { + Tcl_WideInt wideOffset = objPtr->internalRep.wideValue; + if (wideOffset >= Tcl_LongAsWide(INT_MIN) + && wideOffset <= Tcl_LongAsWide(INT_MAX)) { + *indexPtr = (int) Tcl_WideAsLong(wideOffset); + return TCL_OK; + } + } +#endif /* TCL_WIDE_INT_IS_LONG */ - if ((*bytes != 'e') || (strncmp(bytes, "end", - (size_t)((length > 3) ? 3 : length)) != 0)) { - if (Tcl_GetIntFromObj(NULL, objPtr, &offset) != TCL_OK) { - goto intforindex_error; + if (SetEndOffsetFromAny(NULL, objPtr) == TCL_OK) { + /* + * If the object is already an offset from the end of the + * list, or can be converted to one, use it. + */ + + *indexPtr = endValue + objPtr->internalRep.longValue; + +#ifdef TCL_WIDE_INT_IS_LONG + } else if (Tcl_GetIntFromObj(NULL, objPtr, &offset) == TCL_OK) { + /* + * If the object can be converted to an integer, use that. + */ + + *indexPtr = offset; + +#else /* !TCL_WIDE_INT_IS_LONG */ + } else if (Tcl_GetWideIntFromObj(NULL, objPtr, &wideOffset) == TCL_OK) { + /* + * If the object can be converted to a wide integer, use + * that. [Bug #526717] + */ + + offset = (int) Tcl_WideAsLong(wideOffset); + if (Tcl_LongAsWide(offset) == wideOffset) { + /* + * But it is representable as a narrow integer, so we + * prefer that (so preserving old behaviour in the + * majority of cases.) + */ + objPtr->typePtr = &tclIntType; + objPtr->internalRep.longValue = offset; } *indexPtr = offset; + +#endif /* TCL_WIDE_INT_IS_LONG */ + } else { + /* + * Report a parse error. + */ + + if (interp != NULL) { + bytes = Tcl_GetString(objPtr); + /* + * The result might not be empty; this resets it which + * should be both a cheap operation, and of little problem + * because this is an error-generation path anyway. + */ + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad index \"", bytes, + "\": must be integer or end?-integer?", + (char *) NULL); + if (!strncmp(bytes, "end-", 3)) { + bytes += 3; + } + TclCheckBadOctal(interp, bytes); + } + + 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 procedure 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. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateStringOfEndOffset(objPtr) + register Tcl_Obj* objPtr; +{ + char buffer[TCL_INTEGER_SPACE + sizeof("end") + 1]; + register int len; + + strcpy(buffer, "end"); + len = sizeof("end") - 1; + if (objPtr->internalRep.longValue != 0) { + buffer[len++] = '-'; + len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue)); + } + objPtr->bytes = ckalloc((unsigned) (len+1)); + strcpy(objPtr->bytes, buffer); + objPtr->length = len; +} + +/* + *---------------------------------------------------------------------- + * + * 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. + * + *---------------------------------------------------------------------- + */ + +static int +SetEndOffsetFromAny(interp, objPtr) + Tcl_Interp* interp; /* Tcl interpreter or NULL */ + Tcl_Obj* objPtr; /* Pointer to the object to parse */ +{ + int offset; /* Offset in the "end-offset" expression */ + Tcl_ObjType* oldTypePtr = objPtr->typePtr; + /* Old internal rep type of the object */ + register char* bytes; /* String rep of the object */ + int length; /* Length of the object's string rep */ + + /* If it's already the right type, we're fine. */ + + if (objPtr->typePtr == &tclEndOffsetType) { return TCL_OK; } + /* Check for a string rep of the right form. */ + + bytes = Tcl_GetStringFromObj(objPtr, &length); + if ((*bytes != 'e') || (strncmp(bytes, "end", + (size_t)((length > 3) ? 3 : length)) != 0)) { + if (interp != NULL) { + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad index \"", bytes, + "\": must be end?-integer?", + (char*) NULL); + } + return TCL_ERROR; + } + + /* Convert the string rep */ + if (length <= 3) { - *indexPtr = endValue; + offset = 0; } else if (bytes[3] == '-') { /* * This is our limited string expression evaluator @@ -2273,19 +2381,35 @@ TclGetIntForIndex(interp, objPtr, endValue, indexPtr) if (Tcl_GetInt(interp, bytes+3, &offset) != TCL_OK) { return TCL_ERROR; } - *indexPtr = endValue + offset; + } else { - intforindex_error: - if ((Interp *)interp != NULL) { + /* + * Conversion failed. Report the error. + */ + if (interp != NULL) { + Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "bad index \"", bytes, - "\": must be integer or end?-integer?", (char *) NULL); - TclCheckBadOctal(interp, bytes); + "bad index \"", bytes, + "\": must be integer or end?-integer?", + (char *) NULL); } return TCL_ERROR; } + + /* + * The conversion succeeded. Free the old internal rep and set + * the new one. + */ + + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); + } + + objPtr->internalRep.longValue = offset; + objPtr->typePtr = &tclEndOffsetType; + return TCL_OK; -} +} /* *---------------------------------------------------------------------- @@ -2309,9 +2433,9 @@ TclCheckBadOctal(interp, value) Tcl_Interp *interp; /* Interpreter to use for error reporting. * If NULL, then no error message is left * after errors. */ - char *value; /* String to check. */ + CONST char *value; /* String to check. */ { - register char *p = value; + register CONST char *p = value; /* * A frequent mistake is invalid octal values due to an unwanted @@ -2334,6 +2458,10 @@ TclCheckBadOctal(interp, value) if (*p == '\0') { /* Reached end of string */ if (interp != NULL) { + /* + * Don't reset the result here because we want this result + * to be added to an existing error message as extra info. + */ Tcl_AppendResult(interp, " (looks like invalid octal number)", (char *) NULL); } @@ -2367,105 +2495,31 @@ TclCheckBadOctal(interp, value) CONST char * Tcl_GetNameOfExecutable() { - return (tclExecutableName); + return tclExecutableName; } /* *---------------------------------------------------------------------- * - * Tcl_GetCwd -- + * TclpGetTime -- * - * This function replaces the library version of getcwd(). + * Deprecated synonym for Tcl_GetTime. * * Results: - * The result is a pointer to a string specifying the current - * directory, or NULL if the current directory could not be - * determined. If NULL is returned, an error message is left in the - * interp's result. Storage for the result string is allocated in - * bufferPtr; the caller must call Tcl_DStringFree() when the result - * is no longer needed. - * - * Side effects: * None. * - *---------------------------------------------------------------------- - */ - -char * -Tcl_GetCwd(interp, cwdPtr) - Tcl_Interp *interp; - Tcl_DString *cwdPtr; -{ - return TclpGetCwd(interp, cwdPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_Chdir -- - * - * This function replaces the library version of chdir(). - * - * Results: - * See chdir() documentation. - * - * Side effects: - * See chdir() documentation. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_Chdir(dirName) - CONST char *dirName; -{ - return TclpChdir(dirName); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_Access -- - * - * This function replaces the library version of access(). - * - * Results: - * See access() documentation. - * * Side effects: - * See access() documentation. + * Stores current time in the buffer designated by "timePtr" * - *---------------------------------------------------------------------- - */ - -int -Tcl_Access(path, mode) - CONST char *path; /* Path of file to access (UTF-8). */ - int mode; /* Permission setting. */ -{ - return TclAccess(path, mode); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_Stat -- - * - * This function replaces the library version of stat(). - * - * Results: - * See stat() documentation. - * - * Side effects: - * See stat() documentation. + * This procedure is provided for the benefit of extensions written + * before Tcl_GetTime was exported from the library. * *---------------------------------------------------------------------- */ -int -Tcl_Stat(path, bufPtr) - CONST char *path; /* Path of file to stat (in UTF-8). */ - struct stat *bufPtr; /* Filled with results of stat call. */ +void +TclpGetTime(timePtr) + Tcl_Time* timePtr; { - return TclStat(path, bufPtr); + Tcl_GetTime(timePtr); } diff --git a/tcl/generic/tclVar.c b/tcl/generic/tclVar.c index fce00ab6138..3bbbcc3ac25 100644 --- a/tcl/generic/tclVar.c +++ b/tcl/generic/tclVar.c @@ -10,6 +10,7 @@ * 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 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -25,46 +26,130 @@ * variable access is denied. */ -static char *noSuchVar = "no such variable"; -static char *isArray = "variable is array"; -static char *needArray = "variable isn't array"; -static char *noSuchElement = "no such element in array"; -static char *danglingElement = "upvar refers to element in deleted array"; -static char *danglingVar = "upvar refers to variable in deleted namespace"; -static char *badNamespace = "parent namespace doesn't exist"; -static char *missingName = "missing variable name"; -static char *isArrayElement = "name refers to an element in an array"; +static CONST char *noSuchVar = "no such variable"; +static CONST char *isArray = "variable is array"; +static CONST char *needArray = "variable isn't array"; +static CONST char *noSuchElement = "no such element in array"; +static CONST char *danglingElement = + "upvar refers to element in deleted array"; +static CONST char *danglingVar = + "upvar refers to variable in deleted namespace"; +static CONST char *badNamespace = "parent namespace doesn't exist"; +static CONST char *missingName = "missing variable name"; +static CONST char *isArrayElement = "name refers to an element in an array"; /* * Forward references to procedures defined later in this file: */ -static char * CallTraces _ANSI_ARGS_((Interp *iPtr, Var *arrayPtr, - Var *varPtr, char *part1, char *part2, - int flags)); +static int CallVarTraces _ANSI_ARGS_((Interp *iPtr, Var *arrayPtr, + Var *varPtr, CONST char *part1, CONST char *part2, + int flags, CONST int leaveErrMsg)); static void CleanupVar _ANSI_ARGS_((Var *varPtr, Var *arrayPtr)); static void DeleteSearches _ANSI_ARGS_((Var *arrayVarPtr)); static void DeleteArray _ANSI_ARGS_((Interp *iPtr, - char *arrayName, Var *varPtr, int flags)); -static int MakeUpvar _ANSI_ARGS_(( - Interp *iPtr, CallFrame *framePtr, - char *otherP1, char *otherP2, int otherFlags, - char *myName, int myFlags)); + CONST char *arrayName, Var *varPtr, int flags)); +static void DisposeTraceResult _ANSI_ARGS_((int flags, + char *result)); +static int ObjMakeUpvar _ANSI_ARGS_((Tcl_Interp *interp, + CallFrame *framePtr, Tcl_Obj *otherP1Ptr, + CONST char *otherP2, CONST int otherFlags, + CONST char *myName, CONST int myFlags, int index)); static Var * NewVar _ANSI_ARGS_((void)); static ArraySearch * ParseSearchId _ANSI_ARGS_((Tcl_Interp *interp, - Var *varPtr, char *varName, char *string)); + CONST Var *varPtr, CONST char *varName, + Tcl_Obj *handleObj)); static void VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp, - char *part1, char *part2, char *operation, - char *reason)); + CONST char *part1, CONST char *part2, + CONST char *operation, CONST char *reason)); +static int SetArraySearchObj _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); + + +/* + * Functions defined in this file that may be exported in the future + * for use by the bytecode compiler and engine or to the public interface. + */ + +Var * TclLookupSimpleVar _ANSI_ARGS_((Tcl_Interp *interp, + CONST char *varName, int flags, CONST int create, + CONST char **errMsgPtr, int *indexPtr)); +int TclObjUnsetVar2 _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *part1Ptr, CONST char *part2, int flags)); + +static Tcl_FreeInternalRepProc FreeLocalVarName; +static Tcl_DupInternalRepProc DupLocalVarName; +static Tcl_UpdateStringProc UpdateLocalVarName; +static Tcl_FreeInternalRepProc FreeNsVarName; +static Tcl_DupInternalRepProc DupNsVarName; +static Tcl_FreeInternalRepProc FreeParsedVarName; +static Tcl_DupInternalRepProc DupParsedVarName; +static Tcl_UpdateStringProc UpdateParsedVarName; + +/* + * Types of Tcl_Objs used to cache variable lookups. + * + * + * localVarName - INTERNALREP DEFINITION: + * twoPtrValue.ptr1 = pointer to the corresponding Proc + * twoPtrValue.ptr2 = index into locals table + * + * nsVarName - INTERNALREP DEFINITION: + * twoPtrValue.ptr1: pointer to the namespace containing the + * reference + * twoPtrValue.ptr2: pointer to the corresponding Var + * + * parsedVarName - INTERNALREP DEFINITION: + * twoPtrValue.ptr1 = pointer to the array name Tcl_Obj, + * or NULL if it is a scalar variable + * twoPtrValue.ptr2 = pointer to the element name string + * (owned by this Tcl_Obj), or NULL if + * it is a scalar variable + */ + +Tcl_ObjType tclLocalVarNameType = { + "localVarName", + FreeLocalVarName, DupLocalVarName, UpdateLocalVarName, NULL +}; + +Tcl_ObjType tclNsVarNameType = { + "namespaceVarName", + FreeNsVarName, DupNsVarName, NULL, NULL +}; + +Tcl_ObjType tclParsedVarNameType = { + "parsedVarName", + FreeParsedVarName, DupParsedVarName, UpdateParsedVarName, NULL +}; + +/* + * Type of Tcl_Objs used to speed up array searches. + * + * INTERNALREP DEFINITION: + * twoPtrValue.ptr1 = searchIdNumber as offset from (char*)NULL + * twoPtrValue.ptr2 = variableNameStartInString as offset from (char*)NULL + * + * 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. + */ +Tcl_ObjType tclArraySearchType = { + "array search", + NULL, NULL, NULL, SetArraySearchObj +}; + /* *---------------------------------------------------------------------- * * TclLookupVar -- * - * This procedure is used by virtually all of the variable code to - * locate a variable given its name(s). + * This procedure is used to locate a variable given its name(s). It + * has been mostly superseded by TclObjLookupVar, it is now only used + * by the string-based interfaces. It is kept in tcl8.4 mainly because + * it is in the internal stubs table, so that some extension may be + * calling it. * * Results: * The return value is a pointer to the variable structure indicated by @@ -93,19 +178,18 @@ static void VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp, * *---------------------------------------------------------------------- */ - Var * TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, arrayPtrPtr) Tcl_Interp *interp; /* Interpreter to use for lookup. */ - register char *part1; /* If part2 isn't NULL, this is the name of + CONST char *part1; /* If part2 isn't NULL, this is the name of * an array. Otherwise, this * is a full variable name that could * include a parenthesized array element. */ - char *part2; /* Name of element within array, or NULL. */ + CONST char *part2; /* Name of element within array, or NULL. */ int flags; /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * and TCL_LEAVE_ERR_MSG bits matter. */ - char *msg; /* Verb to use in error messages, e.g. + CONST char *msg; /* Verb to use in error messages, e.g. * "read" or "set". Only needed if * TCL_LEAVE_ERR_MSG is set in flags. */ int createPart1; /* If 1, create hash table entry for part 1 @@ -119,35 +203,24 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, * address of array variable. Otherwise * this is set to NULL. */ { - Interp *iPtr = (Interp *) interp; - CallFrame *varFramePtr = iPtr->varFramePtr; - /* Points to the procedure call frame whose - * variables are currently in use. Same as - * the current procedure's frame, if any, - * unless an "uplevel" is executing. */ - Tcl_HashTable *tablePtr; /* Points to the hashtable, if any, in which - * to look up the variable. */ - Tcl_Var var; /* Used to search for global names. */ - Var *varPtr; /* Points to the Var structure returned for - * the variable. */ - char *elName; /* Name of array element or NULL; may be + Var *varPtr; + CONST char *elName; /* Name of array element or NULL; may be * same as part2, or may be openParen+1. */ - char *openParen, *closeParen; + int openParen, closeParen; /* If this procedure parses a name into - * array and index, these point to the - * parens around the index. Otherwise they - * are NULL. These are needed to restore - * the parens after parsing the name. */ - Namespace *varNsPtr, *cxtNsPtr, *dummy1Ptr, *dummy2Ptr; - ResolverScheme *resPtr; - Tcl_HashEntry *hPtr; - register char *p; - int new, i, result; + * array and index, these are the offsets to + * the parens around the index. Otherwise + * they are -1. */ + register CONST char *p; + CONST char *errMsg = NULL; + int index; +#define VAR_NAME_BUF_SIZE 26 + char buffer[VAR_NAME_BUF_SIZE]; + char *newVarName = buffer; varPtr = NULL; *arrayPtrPtr = NULL; - openParen = closeParen = NULL; - varNsPtr = NULL; /* set non-NULL if a nonlocal variable */ + openParen = closeParen = -1; /* * Parse part1 into array name and index. @@ -162,28 +235,439 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, elName = part2; for (p = part1; *p ; p++) { if (*p == '(') { - openParen = p; + openParen = p - part1; do { p++; } while (*p != '\0'); p--; if (*p == ')') { if (part2 != NULL) { - openParen = NULL; if (flags & TCL_LEAVE_ERR_MSG) { VarErrMsg(interp, part1, part2, msg, needArray); } - goto done; + return NULL; } - closeParen = p; - *openParen = 0; - elName = openParen+1; + closeParen = p - part1; } else { - openParen = NULL; + openParen = -1; } break; } } + if (openParen != -1) { + if (closeParen >= VAR_NAME_BUF_SIZE) { + newVarName = ckalloc((unsigned int) (closeParen+1)); + } + memcpy(newVarName, part1, (unsigned int) closeParen); + newVarName[openParen] = '\0'; + newVarName[closeParen] = '\0'; + part1 = newVarName; + elName = newVarName + openParen + 1; + } + + varPtr = TclLookupSimpleVar(interp, part1, flags, + createPart1, &errMsg, &index); + if (varPtr == NULL) { + if ((errMsg != NULL) && (flags & TCL_LEAVE_ERR_MSG)) { + VarErrMsg(interp, part1, elName, msg, errMsg); + } + } else { + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + if (elName != NULL) { + *arrayPtrPtr = varPtr; + varPtr = TclLookupArrayElement(interp, part1, elName, flags, + msg, createPart1, createPart2, varPtr); + } + } + if (newVarName != buffer) { + ckfree(newVarName); + } + + return varPtr; + +#undef VAR_NAME_BUF_SIZE +} + +/* + *---------------------------------------------------------------------- + * + * TclObjLookupVar -- + * + * This procedure is used by virtually all of the variable code to + * locate a variable given its name(s). The parsing into array/element + * components and (if possible) the lookup results are cached in + * part1Ptr, which is converted to one of the varNameTypes. + * + * Results: + * The return value is a pointer to the variable structure indicated by + * part1Ptr and part2, or NULL if the variable couldn't be found. If + * the variable is found, *arrayPtrPtr is filled with the address of the + * variable structure for the array that contains the variable (or NULL + * if the variable is a scalar). If the variable can't be found and + * either createPart1 or createPart2 are 1, a new as-yet-undefined + * (VAR_UNDEFINED) variable structure is created, entered into a hash + * table, and returned. + * + * If the variable isn't found and creation wasn't specified, or some + * other error occurs, NULL is returned and an error message is left in + * the interp's result if TCL_LEAVE_ERR_MSG is set in flags. + * + * Note: it's possible for the variable returned to be VAR_UNDEFINED + * even if createPart1 or createPart2 are 1 (these only cause the hash + * table entry or array to be created). For example, the variable might + * be a global that has been unset but is still referenced by a + * procedure, or a variable that has been unset but it only being kept + * in existence (if VAR_UNDEFINED) by a trace. + * + * Side effects: + * New hashtable entries may be created if createPart1 or createPart2 + * are 1. + * The object part1Ptr is converted to one of tclLocalVarNameType, + * tclNsVarNameType or tclParsedVarNameType and caches as much of the + * lookup as it can. + * + *---------------------------------------------------------------------- + */ +Var * +TclObjLookupVar(interp, part1Ptr, part2, flags, msg, createPart1, createPart2, + arrayPtrPtr) + Tcl_Interp *interp; /* Interpreter to use for lookup. */ + register Tcl_Obj *part1Ptr; /* If part2 isn't NULL, this is the name + * of an array. Otherwise, this is a full + * variable name that could include a parenthesized + * array element. */ + CONST char *part2; /* Name of element within array, or NULL. */ + int flags; /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, + * and TCL_LEAVE_ERR_MSG bits matter. */ + CONST char *msg; /* Verb to use in error messages, e.g. + * "read" or "set". Only needed if + * TCL_LEAVE_ERR_MSG is set in flags. */ + CONST int createPart1; /* If 1, create hash table entry for part 1 + * of name, if it doesn't already exist. If + * 0, return error if it doesn't exist. */ + CONST int createPart2; /* If 1, create hash table entry for part 2 + * of name, if it doesn't already exist. If + * 0, return error if it doesn't exist. */ + Var **arrayPtrPtr; /* If the name refers to an element of an + * array, *arrayPtrPtr gets filled in with + * address of array variable. Otherwise + * this is set to NULL. */ +{ + Interp *iPtr = (Interp *) interp; + register Var *varPtr; /* Points to the variable's in-frame Var + * structure. */ + char *part1; + int index, len1, len2; + int parsed = 0; + Tcl_Obj *objPtr; + Tcl_ObjType *typePtr = part1Ptr->typePtr; + CONST char *errMsg = NULL; + CallFrame *varFramePtr = iPtr->varFramePtr; + Namespace *nsPtr; + + /* + * If part1Ptr is a tclParsedVarNameType, separate it into the + * pre-parsed parts. + */ + + *arrayPtrPtr = NULL; + if (typePtr == &tclParsedVarNameType) { + if (part1Ptr->internalRep.twoPtrValue.ptr1 != NULL) { + if (part2 != NULL) { + /* + * ERROR: part1Ptr is already an array element, cannot + * specify a part2. + */ + + if (flags & TCL_LEAVE_ERR_MSG) { + part1 = TclGetString(part1Ptr); + VarErrMsg(interp, part1, part2, msg, needArray); + } + return NULL; + } + part2 = (char *) part1Ptr->internalRep.twoPtrValue.ptr2; + part1Ptr = (Tcl_Obj *) part1Ptr->internalRep.twoPtrValue.ptr1; + typePtr = part1Ptr->typePtr; + } + parsed = 1; + } + part1 = Tcl_GetStringFromObj(part1Ptr, &len1); + + nsPtr = ((varFramePtr == NULL)? iPtr->globalNsPtr : varFramePtr->nsPtr); + if (nsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) { + goto doParse; + } + + if (typePtr == &tclLocalVarNameType) { + Proc *procPtr = (Proc *) part1Ptr->internalRep.twoPtrValue.ptr1; + int localIndex = (int) part1Ptr->internalRep.twoPtrValue.ptr2; + int useLocal; + + useLocal = ((varFramePtr != NULL) && varFramePtr->isProcCallFrame + && !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY))); + if (useLocal && (procPtr == varFramePtr->procPtr)) { + /* + * part1Ptr points to an indexed local variable of the + * correct procedure: use the cached value. + */ + + varPtr = &(varFramePtr->compiledLocals[localIndex]); + goto donePart1; + } + goto doneParsing; + } else if (typePtr == &tclNsVarNameType) { + Namespace *cachedNsPtr; + int useGlobal, useReference; + + varPtr = (Var *) part1Ptr->internalRep.twoPtrValue.ptr2; + cachedNsPtr = (Namespace *) part1Ptr->internalRep.twoPtrValue.ptr1; + useGlobal = (cachedNsPtr == iPtr->globalNsPtr) + && ((flags & TCL_GLOBAL_ONLY) + || ((*part1 == ':') && (*(part1+1) == ':')) + || (varFramePtr == NULL) + || (!varFramePtr->isProcCallFrame + && (nsPtr == iPtr->globalNsPtr))); + useReference = useGlobal || ((cachedNsPtr == nsPtr) + && ((flags & TCL_NAMESPACE_ONLY) + || (varFramePtr && !varFramePtr->isProcCallFrame + && !(flags & TCL_GLOBAL_ONLY) + /* careful: an undefined ns variable could + * be hiding a valid global reference. */ + && !(varPtr->flags & VAR_UNDEFINED)))); + if (useReference && (varPtr->hPtr != NULL)) { + /* + * A straight global or namespace reference, use it. It isn't + * so simple to deal with 'implicit' namespace references, i.e., + * those where the reference could be to either a namespace + * or a global variable. Those we lookup again. + * + * If (varPtr->hPtr == NULL), this might be a reference to a + * variable in a deleted namespace, kept alive by e.g. part1Ptr. + * We could conceivably be so unlucky that a new namespace was + * created at the same address as the deleted one, so to be + * safe we test for a valid hPtr. + */ + goto donePart1; + } + goto doneParsing; + } + + doParse: + if (!parsed && (*(part1 + len1 - 1) == ')')) { + /* + * part1Ptr is possibly an unparsed array element. + */ + register int i; + char *newPart2; + len2 = -1; + for (i = 0; i < len1; i++) { + if (*(part1 + i) == '(') { + if (part2 != NULL) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, msg, needArray); + } + } + + /* + * part1Ptr points to an array element; first copy + * the element name to a new string part2. + */ + + part2 = part1 + i + 1; + len2 = len1 - i - 2; + len1 = i; + + newPart2 = ckalloc((unsigned int) (len2+1)); + memcpy(newPart2, part2, (unsigned int) len2); + *(newPart2+len2) = '\0'; + part2 = newPart2; + + /* + * Free the internal rep of the original part1Ptr, now + * renamed objPtr, and set it to tclParsedVarNameType. + */ + + objPtr = part1Ptr; + if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { + typePtr->freeIntRepProc(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. + */ + + part1Ptr = Tcl_NewStringObj(part1, len1); + Tcl_IncrRefCount(part1Ptr); + + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) part1Ptr; + objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) part2; + + typePtr = part1Ptr->typePtr; + part1 = TclGetString(part1Ptr); + break; + } + } + } + + doneParsing: + /* + * part1Ptr is not an array element; look it up, and convert + * it to one of the cached types if possible. + */ + + if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { + typePtr->freeIntRepProc(part1Ptr); + part1Ptr->typePtr = NULL; + } + + varPtr = TclLookupSimpleVar(interp, part1, flags, + createPart1, &errMsg, &index); + if (varPtr == NULL) { + if ((errMsg != NULL) && (flags & TCL_LEAVE_ERR_MSG)) { + VarErrMsg(interp, part1, part2, msg, errMsg); + } + return NULL; + } + + /* + * Cache the newly found variable if possible. + */ + + if (index >= 0) { + /* + * An indexed local variable. + */ + + Proc *procPtr = ((Interp *) interp)->varFramePtr->procPtr; + + part1Ptr->typePtr = &tclLocalVarNameType; + procPtr->refCount++; + part1Ptr->internalRep.twoPtrValue.ptr1 = (VOID *) procPtr; + part1Ptr->internalRep.twoPtrValue.ptr2 = (VOID *) index; + } else if (index > -3) { + Namespace *nsPtr; + + nsPtr = ((index == -1)? iPtr->globalNsPtr : varFramePtr->nsPtr); + varPtr->refCount++; + part1Ptr->typePtr = &tclNsVarNameType; + part1Ptr->internalRep.twoPtrValue.ptr1 = (VOID *) nsPtr; + part1Ptr->internalRep.twoPtrValue.ptr2 = (VOID *) varPtr; + } else { + /* + * At least mark part1Ptr as already parsed. + */ + part1Ptr->typePtr = &tclParsedVarNameType; + part1Ptr->internalRep.twoPtrValue.ptr1 = NULL; + part1Ptr->internalRep.twoPtrValue.ptr2 = NULL; + } + + donePart1: +#if 0 + if (varPtr == NULL) { + if (flags & TCL_LEAVE_ERR_MSG) { + part1 = TclGetString(part1Ptr); + VarErrMsg(interp, part1, part2, msg, + "Cached variable reference is NULL."); + } + return NULL; + } +#endif + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + + if (part2 != NULL) { + /* + * Array element sought: look it up. + */ + + part1 = TclGetString(part1Ptr); + *arrayPtrPtr = varPtr; + varPtr = TclLookupArrayElement(interp, part1, part2, + flags, msg, createPart1, createPart2, varPtr); + } + return varPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclLookupSimpleVar -- + * + * This procedure is used by to locate a simple variable (i.e., not + * an array element) given its name. + * + * Results: + * The return value is a pointer to the variable structure indicated by + * varName, or NULL if the variable couldn't be found. If the variable + * can't be found and create is 1, a new as-yet-undefined (VAR_UNDEFINED) + * variable structure is created, entered into a hash table, and returned. + * + * If the current CallFrame corresponds to a proc and the variable found is + * one of the compiledLocals, its index is placed in *indexPtr. Otherwise, + * *indexPtr will be set to (according to the needs of TclObjLookupVar): + * -1 a global reference + * -2 a reference to a namespace variable + * -3 a non-cachable reference, i.e., one of: + * . non-indexed local var + * . a reference of unknown origin; + * . resolution by a namespace or interp resolver + * + * If the variable isn't found and creation wasn't specified, or some + * other error occurs, NULL is returned and the corresponding error + * message is left in *errMsgPtr. + * + * Note: it's possible for the variable returned to be VAR_UNDEFINED + * even if create is 1 (this only causes the hash table entry to be + * created). For example, the variable might be a global that has been + * unset but is still referenced by a procedure, or a variable that has + * been unset but it only being kept in existence (if VAR_UNDEFINED) by + * a trace. + * + * Side effects: + * A new hashtable entry may be created if create is 1. + * + *---------------------------------------------------------------------- + */ + +Var * +TclLookupSimpleVar(interp, varName, flags, create, errMsgPtr, indexPtr) + Tcl_Interp *interp; /* Interpreter to use for lookup. */ + CONST char *varName; /* This is a simple variable name that could + * representa scalar or an array. */ + int flags; /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, + * and TCL_LEAVE_ERR_MSG bits matter. */ + CONST int create; /* If 1, create hash table entry for varname, + * if it doesn't already exist. If 0, return + * error if it doesn't exist. */ + CONST char **errMsgPtr; + int *indexPtr; +{ + Interp *iPtr = (Interp *) interp; + CallFrame *varFramePtr = iPtr->varFramePtr; + /* Points to the procedure call frame whose + * variables are currently in use. Same as + * the current procedure's frame, if any, + * unless an "uplevel" is executing. */ + Tcl_HashTable *tablePtr; /* Points to the hashtable, if any, in which + * to look up the variable. */ + Tcl_Var var; /* Used to search for global names. */ + Var *varPtr; /* Points to the Var structure returned for + * the variable. */ + Namespace *varNsPtr, *cxtNsPtr, *dummy1Ptr, *dummy2Ptr; + ResolverScheme *resPtr; + Tcl_HashEntry *hPtr; + int new, i, result; + + varPtr = NULL; + varNsPtr = NULL; /* set non-NULL if a nonlocal variable */ + *indexPtr = -3; /* * If this namespace has a variable resolver, then give it first @@ -191,7 +675,7 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, * value, it may signal to continue onward, or it may signal * an error. */ - if ((flags & TCL_GLOBAL_ONLY) != 0 || iPtr->varFramePtr == NULL) { + if ((flags & TCL_GLOBAL_ONLY) || iPtr->varFramePtr == NULL) { cxtNsPtr = iPtr->globalNsPtr; } else { cxtNsPtr = iPtr->varFramePtr->nsPtr; @@ -201,7 +685,7 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, resPtr = iPtr->resolverPtr; if (cxtNsPtr->varResProc) { - result = (*cxtNsPtr->varResProc)(interp, part1, + result = (*cxtNsPtr->varResProc)(interp, varName, (Tcl_Namespace *) cxtNsPtr, flags, &var); } else { result = TCL_CONTINUE; @@ -209,7 +693,7 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, while (result == TCL_CONTINUE && resPtr) { if (resPtr->varResProc) { - result = (*resPtr->varResProc)(interp, part1, + result = (*resPtr->varResProc)(interp, varName, (Tcl_Namespace *) cxtNsPtr, flags, &var); } resPtr = resPtr->nextPtr; @@ -217,71 +701,85 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, if (result == TCL_OK) { varPtr = (Var *) var; - goto lookupVarPart2; + return varPtr; } else if (result != TCL_CONTINUE) { - return (Var *) NULL; + return NULL; } } /* - * Look up part1. Look it up as either a namespace variable or as a + * Look up varName. Look it up as either a namespace variable or as a * local variable in a procedure call frame (varFramePtr). - * Interpret part1 as a namespace variable if: + * Interpret varName as a namespace variable if: * 1) so requested by a TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY flag, * 2) there is no active frame (we're at the global :: scope), * 3) the active frame was pushed to define the namespace context * for a "namespace eval" or "namespace inscope" command, * 4) the name has namespace qualifiers ("::"s). - * Otherwise, if part1 is a local variable, search first in the + * Otherwise, if varName is a local variable, search first in the * frame's array of compiler-allocated local variables, then in its * hashtable for runtime-created local variables. * - * If createPart1 and the variable isn't found, create the variable and, + * If create and the variable isn't found, create the variable and, * if necessary, create varFramePtr's local var hashtable. */ if (((flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) != 0) || (varFramePtr == NULL) || !varFramePtr->isProcCallFrame - || (strstr(part1, "::") != NULL)) { - char *tail; + || (strstr(varName, "::") != NULL)) { + CONST char *tail; + int lookGlobal; + lookGlobal = (flags & TCL_GLOBAL_ONLY) + || (cxtNsPtr == iPtr->globalNsPtr) + || ((*varName == ':') && (*(varName+1) == ':')); + if (lookGlobal) { + *indexPtr = -1; + flags = (flags | TCL_GLOBAL_ONLY) & ~TCL_NAMESPACE_ONLY; + } else if (flags & TCL_NAMESPACE_ONLY) { + *indexPtr = -2; + } + /* * Don't pass TCL_LEAVE_ERR_MSG, we may yet create the variable, * or otherwise generate our own error! */ - var = Tcl_FindNamespaceVar(interp, part1, (Tcl_Namespace *) NULL, + var = Tcl_FindNamespaceVar(interp, varName, (Tcl_Namespace *) cxtNsPtr, flags & ~TCL_LEAVE_ERR_MSG); if (var != (Tcl_Var) NULL) { varPtr = (Var *) var; } if (varPtr == NULL) { - if (createPart1) { /* var wasn't found so create it */ - TclGetNamespaceForQualName(interp, part1, (Namespace *) NULL, + if (create) { /* var wasn't found so create it */ + TclGetNamespaceForQualName(interp, varName, cxtNsPtr, flags, &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail); - if (varNsPtr == NULL) { - if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, msg, badNamespace); - } - goto done; + *errMsgPtr = badNamespace; + return NULL; } if (tail == NULL) { - if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, msg, missingName); - } - goto done; + *errMsgPtr = missingName; + return NULL; } hPtr = Tcl_CreateHashEntry(&varNsPtr->varTable, tail, &new); varPtr = NewVar(); Tcl_SetHashValue(hPtr, varPtr); varPtr->hPtr = hPtr; varPtr->nsPtr = varNsPtr; - } else { /* var wasn't found and not to create it */ - if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, msg, noSuchVar); + if ((lookGlobal) || (varNsPtr == NULL)) { + /* + * 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; } - goto done; + } else { /* var wasn't found and not to create it */ + *errMsgPtr = noSuchVar; + return NULL; } } } else { /* local var: look in frame varFramePtr */ @@ -289,156 +787,170 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, int localCt = procPtr->numCompiledLocals; CompiledLocal *localPtr = procPtr->firstLocalPtr; Var *localVarPtr = varFramePtr->compiledLocals; - int part1Len = strlen(part1); + int varNameLen = strlen(varName); for (i = 0; i < localCt; i++) { if (!TclIsVarTemporary(localPtr)) { register char *localName = localVarPtr->name; - if ((part1[0] == localName[0]) - && (part1Len == localPtr->nameLength) - && (strcmp(part1, localName) == 0)) { - varPtr = localVarPtr; - break; + if ((varName[0] == localName[0]) + && (varNameLen == localPtr->nameLength) + && (strcmp(varName, localName) == 0)) { + *indexPtr = i; + return localVarPtr; } } localVarPtr++; localPtr = localPtr->nextPtr; } - if (varPtr == NULL) { /* look in the frame's var hash table */ - tablePtr = varFramePtr->varTablePtr; - if (createPart1) { - if (tablePtr == NULL) { - tablePtr = (Tcl_HashTable *) - ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS); - varFramePtr->varTablePtr = tablePtr; - } - hPtr = Tcl_CreateHashEntry(tablePtr, part1, &new); - if (new) { - varPtr = NewVar(); - Tcl_SetHashValue(hPtr, varPtr); - varPtr->hPtr = hPtr; - varPtr->nsPtr = NULL; /* a local variable */ - } else { - varPtr = (Var *) Tcl_GetHashValue(hPtr); - } + tablePtr = varFramePtr->varTablePtr; + if (create) { + if (tablePtr == NULL) { + tablePtr = (Tcl_HashTable *) + ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS); + varFramePtr->varTablePtr = tablePtr; + } + hPtr = Tcl_CreateHashEntry(tablePtr, varName, &new); + if (new) { + varPtr = NewVar(); + Tcl_SetHashValue(hPtr, varPtr); + varPtr->hPtr = hPtr; + varPtr->nsPtr = NULL; /* a local variable */ } else { - hPtr = NULL; - if (tablePtr != NULL) { - hPtr = Tcl_FindHashEntry(tablePtr, part1); - } - if (hPtr == NULL) { - if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, msg, noSuchVar); - } - goto done; - } varPtr = (Var *) Tcl_GetHashValue(hPtr); } + } else { + hPtr = NULL; + if (tablePtr != NULL) { + hPtr = Tcl_FindHashEntry(tablePtr, varName); + } + if (hPtr == NULL) { + *errMsgPtr = noSuchVar; + return NULL; + } + varPtr = (Var *) Tcl_GetHashValue(hPtr); } } + return varPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclLookupArrayElement -- + * + * This procedure is used to locate a variable which is in an array's + * hashtable given a pointer to the array's Var structure and the + * element's name. + * + * Results: + * The return value is a pointer to the variable structure , or NULL if + * the variable couldn't be found. + * + * If arrayPtr points to a variable that isn't an array and createPart1 + * is 1, the corresponding variable will be converted to an array. + * Otherwise, NULL is returned and an error message is left in + * the interp's result if TCL_LEAVE_ERR_MSG is set in flags. + * + * If the variable is not found and createPart2 is 1, the variable is + * created. Otherwise, NULL is returned and an error message is left in + * the interp's result if TCL_LEAVE_ERR_MSG is set in flags. + * + * Note: it's possible for the variable returned to be VAR_UNDEFINED + * even if createPart1 or createPart2 are 1 (these only cause the hash + * table entry or array to be created). For example, the variable might + * be a global that has been unset but is still referenced by a + * procedure, or a variable that has been unset but it only being kept + * in existence (if VAR_UNDEFINED) by a trace. + * + * Side effects: + * The variable at arrayPtr may be converted to be an array if + * createPart1 is 1. A new hashtable entry may be created if createPart2 + * is 1. + * + *---------------------------------------------------------------------- + */ - lookupVarPart2: - if (openParen != NULL) { - *openParen = '('; - openParen = NULL; - } - - /* - * If varPtr is a link variable, we have a reference to some variable - * that was created through an "upvar" or "global" command. Traverse - * through any links until we find the referenced variable. - */ - - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - - /* - * If we're not dealing with an array element, return varPtr. - */ - - if (elName == NULL) { - goto done; - } +Var * +TclLookupArrayElement(interp, arrayName, elName, flags, msg, createArray, createElem, arrayPtr) + Tcl_Interp *interp; /* Interpreter to use for lookup. */ + CONST char *arrayName; /* This is the name of the array. */ + CONST char *elName; /* Name of element within array. */ + CONST int flags; /* Only TCL_LEAVE_ERR_MSG bit matters. */ + CONST char *msg; /* Verb to use in error messages, e.g. + * "read" or "set". Only needed if + * TCL_LEAVE_ERR_MSG is set in flags. */ + CONST int createArray; /* If 1, transform arrayName to be an array + * if it isn't one yet and the transformation + * is possible. If 0, return error if it + * isn't already an array. */ + CONST int createElem; /* If 1, create hash table entry for the + * element, if it doesn't already exist. If + * 0, return error if it doesn't exist. */ + Var *arrayPtr; /* Pointer to the array's Var structure. */ +{ + Tcl_HashEntry *hPtr; + int new; + Var *varPtr; /* * We're dealing with an array element. Make sure the variable is an * array and look up the element (create the element if desired). */ - if (TclIsVarUndefined(varPtr) && !TclIsVarArrayElement(varPtr)) { - if (!createPart1) { + if (TclIsVarUndefined(arrayPtr) && !TclIsVarArrayElement(arrayPtr)) { + if (!createArray) { if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, msg, noSuchVar); + VarErrMsg(interp, arrayName, elName, msg, noSuchVar); } - varPtr = NULL; - goto done; + return NULL; } /* * Make sure we are not resurrecting a namespace variable from a * deleted namespace! */ - if ((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) { + if ((arrayPtr->flags & VAR_IN_HASHTABLE) && (arrayPtr->hPtr == NULL)) { if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, msg, danglingVar); + VarErrMsg(interp, arrayName, elName, msg, danglingVar); } - varPtr = NULL; - goto done; + return NULL; } - TclSetVarArray(varPtr); - TclClearVarUndefined(varPtr); - varPtr->value.tablePtr = + TclSetVarArray(arrayPtr); + TclClearVarUndefined(arrayPtr); + arrayPtr->value.tablePtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS); - } else if (!TclIsVarArray(varPtr)) { + Tcl_InitHashTable(arrayPtr->value.tablePtr, TCL_STRING_KEYS); + } else if (!TclIsVarArray(arrayPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, msg, needArray); + VarErrMsg(interp, arrayName, elName, msg, needArray); } - varPtr = NULL; - goto done; - } - *arrayPtrPtr = varPtr; - if (closeParen != NULL) { - *closeParen = 0; + return NULL; } - if (createPart2) { - hPtr = Tcl_CreateHashEntry(varPtr->value.tablePtr, elName, &new); - if (closeParen != NULL) { - *closeParen = ')'; - } + + if (createElem) { + hPtr = Tcl_CreateHashEntry(arrayPtr->value.tablePtr, elName, &new); if (new) { - if (varPtr->searchPtr != NULL) { - DeleteSearches(varPtr); + if (arrayPtr->searchPtr != NULL) { + DeleteSearches(arrayPtr); } varPtr = NewVar(); Tcl_SetHashValue(hPtr, varPtr); varPtr->hPtr = hPtr; - varPtr->nsPtr = varNsPtr; + varPtr->nsPtr = arrayPtr->nsPtr; TclSetVarArrayElement(varPtr); } } else { - hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, elName); - if (closeParen != NULL) { - *closeParen = ')'; - } + hPtr = Tcl_FindHashEntry(arrayPtr->value.tablePtr, elName); if (hPtr == NULL) { if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, msg, noSuchElement); + VarErrMsg(interp, arrayName, elName, msg, noSuchElement); } - varPtr = NULL; - goto done; + return NULL; } } - varPtr = (Var *) Tcl_GetHashValue(hPtr); - - done: - if (openParen != NULL) { - *openParen = '('; - } - return varPtr; + return (Var *) Tcl_GetHashValue(hPtr); } /* @@ -463,11 +975,11 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, *---------------------------------------------------------------------- */ -char * +CONST char * Tcl_GetVar(interp, varName, flags) Tcl_Interp *interp; /* Command interpreter in which varName is * to be looked up. */ - char *varName; /* Name of a variable in interp. */ + CONST char *varName; /* Name of a variable in interp. */ int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY or TCL_LEAVE_ERR_MSG * bits. */ @@ -498,13 +1010,13 @@ Tcl_GetVar(interp, varName, flags) *---------------------------------------------------------------------- */ -char * +CONST char * Tcl_GetVar2(interp, part1, part2, flags) Tcl_Interp *interp; /* Command interpreter in which variable is * to be looked up. */ - char *part1; /* Name of an array (if part2 is non-NULL) + CONST char *part1; /* Name of an array (if part2 is non-NULL) * or the name of a variable. */ - char *part2; /* If non-NULL, gives the name of an element + CONST char *part2; /* If non-NULL, gives the name of an element * in the array part1. */ int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY and TCL_LEAVE_ERR_MSG @@ -518,54 +1030,6 @@ Tcl_GetVar2(interp, part1, part2, flags) } return TclGetString(objPtr); } -/* - *---------------------------------------------------------------------- - * - * Tcl_ObjGetVar2 -- - * - * Return the value of a Tcl variable as a Tcl object, given a - * two-part name consisting of array name and element within array. - * - * Results: - * The return value points to the current object value of the variable - * given by part1Ptr and part2Ptr. If the specified variable doesn't - * exist, or if there is a clash in array usage, then NULL is returned - * and a message will be left in the interpreter's result if the - * TCL_LEAVE_ERR_MSG flag is set. - * - * Side effects: - * The ref count for the returned object is _not_ incremented to - * reflect the returned reference; if you want to keep a reference to - * the object you must increment its ref count yourself. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags) - Tcl_Interp *interp; /* Command interpreter in which variable is - * to be looked up. */ - register Tcl_Obj *part1Ptr; /* Points to an object holding the name of - * an array (if part2 is non-NULL) or the - * name of a variable. */ - register Tcl_Obj *part2Ptr; /* If non-null, points to an object holding - * the name of an element in the array - * part1Ptr. */ - int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, - * TCL_LEAVE_ERR_MSG, and - * TCL_PARSE_PART1 bits. */ -{ - char *part1, *part2; - - part1 = Tcl_GetString(part1Ptr); - if (part2Ptr != NULL) { - part2 = Tcl_GetString(part2Ptr); - } else { - part2 = NULL; - } - - return Tcl_GetVar2Ex(interp, part1, part2, flags); -} /* *---------------------------------------------------------------------- @@ -594,87 +1058,44 @@ Tcl_Obj * Tcl_GetVar2Ex(interp, part1, part2, flags) Tcl_Interp *interp; /* Command interpreter in which variable is * to be looked up. */ - char *part1; /* Name of an array (if part2 is non-NULL) + CONST char *part1; /* Name of an array (if part2 is non-NULL) * or the name of a variable. */ - char *part2; /* If non-NULL, gives the name of an element + CONST char *part2; /* If non-NULL, gives the name of an element * in the array part1. */ int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, * and TCL_LEAVE_ERR_MSG bits. */ { - Interp *iPtr = (Interp *) interp; - register Var *varPtr; - Var *arrayPtr; - char *msg; + Var *varPtr, *arrayPtr; + /* + * We need a special flag check to see if we want to create part 1, + * because commands like lappend require read traces to trigger for + * previously non-existent values. + */ varPtr = TclLookupVar(interp, part1, part2, flags, "read", - /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr); + /*createPart1*/ (flags & TCL_TRACE_READS), + /*createPart2*/ 1, &arrayPtr); if (varPtr == NULL) { return NULL; } - /* - * Invoke any traces that have been set for the variable. - */ - - if ((varPtr->tracePtr != NULL) - || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { - msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2, - (flags & (TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY)) | TCL_TRACE_READS); - if (msg != NULL) { - if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, "read", msg); - } - goto errorReturn; - } - } - - /* - * Return the element if it's an existing scalar variable. - */ - - if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) { - return varPtr->value.objPtr; - } - - if (flags & TCL_LEAVE_ERR_MSG) { - if (TclIsVarUndefined(varPtr) && (arrayPtr != NULL) - && !TclIsVarUndefined(arrayPtr)) { - msg = noSuchElement; - } else if (TclIsVarArray(varPtr)) { - msg = isArray; - } else { - msg = noSuchVar; - } - VarErrMsg(interp, part1, part2, "read", msg); - } - - /* - * An error. If the variable doesn't exist anymore and no-one's using - * it, then free up the relevant structures and hash table entries. - */ - - errorReturn: - if (TclIsVarUndefined(varPtr)) { - CleanupVar(varPtr, arrayPtr); - } - return NULL; + return TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags); } /* *---------------------------------------------------------------------- * - * TclGetIndexedScalar -- + * Tcl_ObjGetVar2 -- * - * Return the Tcl object value of a local scalar variable in the active - * procedure, given its index in the procedure's array of compiler - * allocated local variables. + * Return the value of a Tcl variable as a Tcl object, given a + * two-part name consisting of array name and element within array. * * Results: * The return value points to the current object value of the variable - * given by localIndex. If the specified variable doesn't exist, or - * there is a clash in array usage, or an error occurs while executing - * variable traces, then NULL is returned and a message will be left in - * the interpreter's result if leaveErrorMsg is 1. + * given by part1Ptr and part2Ptr. If the specified variable doesn't + * exist, or if there is a clash in array usage, then NULL is returned + * and a message will be left in the interpreter's result if the + * TCL_LEAVE_ERR_MSG flag is set. * * Side effects: * The ref count for the returned object is _not_ incremented to @@ -685,109 +1106,53 @@ Tcl_GetVar2Ex(interp, part1, part2, flags) */ Tcl_Obj * -TclGetIndexedScalar(interp, localIndex, leaveErrorMsg) +Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags) Tcl_Interp *interp; /* Command interpreter in which variable is * to be looked up. */ - register int localIndex; /* Index of variable in procedure's array - * of local variables. */ - int leaveErrorMsg; /* 1 if to leave an error message in - * interpreter's result on an error. - * Otherwise no error message is left. */ + register Tcl_Obj *part1Ptr; /* Points to an object holding the name of + * an array (if part2 is non-NULL) or the + * name of a variable. */ + register Tcl_Obj *part2Ptr; /* If non-null, points to an object holding + * the name of an element in the array + * part1Ptr. */ + int flags; /* OR-ed combination of TCL_GLOBAL_ONLY and + * TCL_LEAVE_ERR_MSG bits. */ { - Interp *iPtr = (Interp *) interp; - CallFrame *varFramePtr = iPtr->varFramePtr; - /* Points to the procedure call frame whose - * variables are currently in use. Same as - * the current procedure's frame, if any, - * unless an "uplevel" is executing. */ - Var *compiledLocals = varFramePtr->compiledLocals; - register Var *varPtr; /* Points to the variable's in-frame Var - * structure. */ - char *varName; /* Name of the local variable. */ - char *msg; - -#ifdef TCL_COMPILE_DEBUG - int localCt = varFramePtr->procPtr->numCompiledLocals; + Var *varPtr, *arrayPtr; + char *part1, *part2; - if (compiledLocals == NULL) { - fprintf(stderr, "\nTclGetIndexedScalar: can't get local %i in frame 0x%x, no compiled locals\n", - localIndex, (unsigned int) varFramePtr); - panic("TclGetIndexedScalar: no compiled locals in frame 0x%x", - (unsigned int) varFramePtr); - } - if ((localIndex < 0) || (localIndex >= localCt)) { - fprintf(stderr, "\nTclGetIndexedScalar: can't get local %i in frame 0x%x with %i locals\n", - localIndex, (unsigned int) varFramePtr, localCt); - panic("TclGetIndexedScalar: bad local index %i in frame 0x%x", - localIndex, (unsigned int) varFramePtr); - } -#endif /* TCL_COMPILE_DEBUG */ + part1 = Tcl_GetString(part1Ptr); + part2 = ((part2Ptr == NULL) ? NULL : Tcl_GetString(part2Ptr)); - varPtr = &(compiledLocals[localIndex]); - varName = varPtr->name; - - /* - * If varPtr is a link variable, we have a reference to some variable - * that was created through an "upvar" or "global" command, or we have a - * reference to a variable in an enclosing namespace. Traverse through - * any links until we find the referenced variable. - */ - - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - /* - * Invoke any traces that have been set for the variable. + * We need a special flag check to see if we want to create part 1, + * because commands like lappend require read traces to trigger for + * previously non-existent values. */ - - if (varPtr->tracePtr != NULL) { - msg = CallTraces(iPtr, /*arrayPtr*/ NULL, varPtr, varName, NULL, - TCL_TRACE_READS); - if (msg != NULL) { - if (leaveErrorMsg) { - VarErrMsg(interp, varName, NULL, "read", msg); - } - return NULL; - } - } - - /* - * Make sure we're dealing with a scalar variable and not an array, and - * that the variable exists (isn't undefined). - */ - - if (!TclIsVarScalar(varPtr) || TclIsVarUndefined(varPtr)) { - if (leaveErrorMsg) { - if (TclIsVarArray(varPtr)) { - msg = isArray; - } else { - msg = noSuchVar; - } - VarErrMsg(interp, varName, NULL, "read", msg); - - } + varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "read", + /*createPart1*/ (flags & TCL_TRACE_READS), + /*createPart2*/ 1, &arrayPtr); + if (varPtr == NULL) { return NULL; } - return varPtr->value.objPtr; + + return TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags); } /* *---------------------------------------------------------------------- * - * TclGetElementOfIndexedArray -- + * TclPtrGetVar -- * - * Return the Tcl object value for an element in a local array - * variable. The element is named by the object elemPtr while the - * array is specified by its index in the active procedure's array - * of compiler allocated local variables. + * Return the value of a Tcl variable as a Tcl object, given the + * pointers to the variable's (and possibly containing array's) + * VAR structure. * * Results: - * The return value points to the current object value of the - * element. If the specified array or element doesn't exist, or there - * is a clash in array usage, or an error occurs while executing - * variable traces, then NULL is returned and a message will be left in - * the interpreter's result if leaveErrorMsg is 1. + * The return value points to the current object value of the variable + * given by varPtr. If the specified variable doesn't exist, or if there + * is a clash in array usage, then NULL is returned and a message will be + * left in the interpreter's result if the TCL_LEAVE_ERR_MSG flag is set. * * Side effects: * The ref count for the returned object is _not_ incremented to @@ -798,114 +1163,31 @@ TclGetIndexedScalar(interp, localIndex, leaveErrorMsg) */ Tcl_Obj * -TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg) +TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags) Tcl_Interp *interp; /* Command interpreter in which variable is * to be looked up. */ - int localIndex; /* Index of array variable in procedure's - * array of local variables. */ - Tcl_Obj *elemPtr; /* Points to an object holding the name of - * an element to get in the array. */ - int leaveErrorMsg; /* 1 if to leave an error message in - * the interpreter's result on an error. - * Otherwise no error message is left. */ + register Var *varPtr; /* The variable to be read.*/ + Var *arrayPtr; /* NULL for scalar variables, pointer to + * the containing array otherwise. */ + CONST char *part1; /* Name of an array (if part2 is non-NULL) + * or the name of a variable. */ + CONST char *part2; /* If non-NULL, gives the name of an element + * in the array part1. */ + CONST int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, + * and TCL_LEAVE_ERR_MSG bits. */ { Interp *iPtr = (Interp *) interp; - CallFrame *varFramePtr = iPtr->varFramePtr; - /* Points to the procedure call frame whose - * variables are currently in use. Same as - * the current procedure's frame, if any, - * unless an "uplevel" is executing. */ - Var *compiledLocals = varFramePtr->compiledLocals; - Var *arrayPtr; /* Points to the array's in-frame Var - * structure. */ - char *arrayName; /* Name of the local array. */ - Tcl_HashEntry *hPtr; - Var *varPtr = NULL; /* Points to the element's Var structure - * that we return. Initialized to avoid - * compiler warning. */ - char *elem, *msg; - int new; - -#ifdef TCL_COMPILE_DEBUG - Proc *procPtr = varFramePtr->procPtr; - int localCt = procPtr->numCompiledLocals; - - if (compiledLocals == NULL) { - fprintf(stderr, "\nTclGetElementOfIndexedArray: can't get element of local %i in frame 0x%x, no compiled locals\n", - localIndex, (unsigned int) varFramePtr); - panic("TclGetIndexedScalar: no compiled locals in frame 0x%x", - (unsigned int) varFramePtr); - } - if ((localIndex < 0) || (localIndex >= localCt)) { - fprintf(stderr, "\nTclGetIndexedScalar: can't get element of local %i in frame 0x%x with %i locals\n", - localIndex, (unsigned int) varFramePtr, localCt); - panic("TclGetElementOfIndexedArray: bad local index %i in frame 0x%x", - localIndex, (unsigned int) varFramePtr); - } -#endif /* TCL_COMPILE_DEBUG */ - - elem = TclGetString(elemPtr); - arrayPtr = &(compiledLocals[localIndex]); - arrayName = arrayPtr->name; + CONST char *msg; /* - * If arrayPtr is a link variable, we have a reference to some variable - * that was created through an "upvar" or "global" command, or we have a - * reference to a variable in an enclosing namespace. Traverse through - * any links until we find the referenced variable. - */ - - while (TclIsVarLink(arrayPtr)) { - arrayPtr = arrayPtr->value.linkPtr; - } - - /* - * Make sure we're dealing with an array and that the array variable - * exists (isn't undefined). - */ - - if (!TclIsVarArray(arrayPtr) || TclIsVarUndefined(arrayPtr)) { - if (leaveErrorMsg) { - VarErrMsg(interp, arrayName, elem, "read", noSuchVar); - } - goto errorReturn; - } - - /* - * Look up the element. Note that we must create the element (but leave - * it marked undefined) if it does not already exist. This allows a - * trace to create new array elements "on the fly" that did not exist - * before. A trace is always passed a variable for the array element. If - * the trace does not define the variable, it will be deleted below (at - * errorReturn) and an error returned. - */ - - hPtr = Tcl_CreateHashEntry(arrayPtr->value.tablePtr, elem, &new); - if (new) { - if (arrayPtr->searchPtr != NULL) { - DeleteSearches(arrayPtr); - } - varPtr = NewVar(); - Tcl_SetHashValue(hPtr, varPtr); - varPtr->hPtr = hPtr; - varPtr->nsPtr = varFramePtr->nsPtr; - TclSetVarArrayElement(varPtr); - } else { - varPtr = (Var *) Tcl_GetHashValue(hPtr); - } - - /* - * Invoke any traces that have been set for the element variable. + * Invoke any traces that have been set for the variable. */ if ((varPtr->tracePtr != NULL) - || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { - msg = CallTraces(iPtr, arrayPtr, varPtr, arrayName, elem, - TCL_TRACE_READS); - if (msg != NULL) { - if (leaveErrorMsg) { - VarErrMsg(interp, arrayName, elem, "read", msg); - } + || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { + if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, + (flags & (TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY)) + | TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) { goto errorReturn; } } @@ -918,13 +1200,16 @@ TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg) return varPtr->value.objPtr; } - if (leaveErrorMsg) { - if (TclIsVarArray(varPtr)) { + if (flags & TCL_LEAVE_ERR_MSG) { + if (TclIsVarUndefined(varPtr) && (arrayPtr != NULL) + && !TclIsVarUndefined(arrayPtr)) { + msg = noSuchElement; + } else if (TclIsVarArray(varPtr)) { msg = isArray; } else { msg = noSuchVar; } - VarErrMsg(interp, arrayName, elem, "read", msg); + VarErrMsg(interp, part1, part2, "read", msg); } /* @@ -933,8 +1218,8 @@ TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg) */ errorReturn: - if ((varPtr != NULL) && TclIsVarUndefined(varPtr)) { - CleanupVar(varPtr, NULL); /* the array is not in a hashtable */ + if (TclIsVarUndefined(varPtr)) { + CleanupVar(varPtr, arrayPtr); } return NULL; } @@ -1012,12 +1297,12 @@ Tcl_SetObjCmd(dummy, interp, objc, objv) *---------------------------------------------------------------------- */ -char * +CONST char * Tcl_SetVar(interp, varName, newValue, flags) Tcl_Interp *interp; /* Command interpreter in which varName is * to be looked up. */ - char *varName; /* Name of a variable in interp. */ - char *newValue; /* New value for varName. */ + CONST char *varName; /* Name of a variable in interp. */ + CONST char *newValue; /* New value for varName. */ int flags; /* Various flags that tell how to set value: * any of TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE, @@ -1053,16 +1338,16 @@ Tcl_SetVar(interp, varName, newValue, flags) *---------------------------------------------------------------------- */ -char * +CONST char * Tcl_SetVar2(interp, part1, part2, newValue, flags) Tcl_Interp *interp; /* Command interpreter in which variable is * to be looked up. */ - char *part1; /* If part2 is NULL, this is name of scalar + CONST char *part1; /* If part2 is NULL, this is name of scalar * variable. Otherwise it is the name of * an array. */ - char *part2; /* Name of an element within an array, or + CONST char *part2; /* Name of an element within an array, or * NULL. */ - char *newValue; /* New value for variable. */ + CONST char *newValue; /* New value for variable. */ int flags; /* Various flags that tell how to set value: * any of TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE, @@ -1091,9 +1376,73 @@ Tcl_SetVar2(interp, part1, part2, newValue, flags) /* *---------------------------------------------------------------------- * + * Tcl_SetVar2Ex -- + * + * Given a two-part variable name, which may refer either to a scalar + * variable or an element of an array, change the value of the variable + * to a new Tcl object value. If the named scalar or array or element + * doesn't exist then create one. + * + * Results: + * Returns a pointer to the Tcl_Obj holding the new value of the + * variable. If the write operation was disallowed because an array was + * expected but not found (or vice versa), then NULL is returned; if + * the TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will + * be left in the interpreter's result. Note that the returned object + * may not be the same one referenced by newValuePtr; this is because + * variable traces may modify the variable's value. + * + * Side effects: + * The value of the given variable is set. If either the array or the + * entry didn't exist then a new variable is created. + * + * The reference count is decremented for any old value of the variable + * and incremented for its new value. If the new value for the variable + * is not the same one referenced by newValuePtr (perhaps as a result + * of a variable trace), then newValuePtr's ref count is left unchanged + * by Tcl_SetVar2Ex. newValuePtr's ref count is also left unchanged if + * we are appending it as a string value: that is, if "flags" includes + * TCL_APPEND_VALUE but not TCL_LIST_ELEMENT. + * + * The reference count for the returned object is _not_ incremented: if + * you want to keep a reference to the object you must increment its + * ref count yourself. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags) + Tcl_Interp *interp; /* Command interpreter in which variable is + * to be found. */ + CONST char *part1; /* Name of an array (if part2 is non-NULL) + * or the name of a variable. */ + CONST char *part2; /* If non-NULL, gives the name of an element + * in the array part1. */ + Tcl_Obj *newValuePtr; /* New value for variable. */ + int flags; /* Various flags that tell how to set value: + * any of TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE, + * TCL_LIST_ELEMENT or TCL_LEAVE_ERR_MSG. */ +{ + Var *varPtr, *arrayPtr; + + varPtr = TclLookupVar(interp, part1, part2, flags, "set", + /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); + if (varPtr == NULL) { + return NULL; + } + + return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, + newValuePtr, flags); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_ObjSetVar2 -- * - * This function is the same as Tcl_SetVar2Ex below, except the + * This function is the same as Tcl_SetVar2Ex above, except the * variable names are passed in Tcl object instead of strings. * * Results: @@ -1108,7 +1457,6 @@ Tcl_SetVar2(interp, part1, part2, newValue, flags) * Side effects: * The value of the given variable is set. If either the array or the * entry didn't exist then a new variable is created. - * *---------------------------------------------------------------------- */ @@ -1127,30 +1475,33 @@ Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags) int flags; /* Various flags that tell how to set value: * any of TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE, - * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG, or - * TCL_PARSE_PART1. */ + * TCL_LIST_ELEMENT, or TCL_LEAVE_ERR_MSG. */ { + Var *varPtr, *arrayPtr; char *part1, *part2; - part1 = Tcl_GetString(part1Ptr); - if (part2Ptr != NULL) { - part2 = Tcl_GetString(part2Ptr); - } else { - part2 = NULL; + part1 = TclGetString(part1Ptr); + part2 = ((part2Ptr == NULL) ? NULL : Tcl_GetString(part2Ptr)); + + varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "set", + /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); + if (varPtr == NULL) { + return NULL; } - - return Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags); + + return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, + newValuePtr, flags); } + /* *---------------------------------------------------------------------- * - * Tcl_SetVar2Ex -- + * TclPtrSetVar -- * - * Given a two-part variable name, which may refer either to a scalar - * variable or an element of an array, change the value of the variable - * to a new Tcl object value. If the named scalar or array or element - * doesn't exist then create one. + * This function is the same as Tcl_SetVar2Ex above, except that + * it requires pointers to the variable's Var structs in addition + * to the variable names. * * Results: * Returns a pointer to the Tcl_Obj holding the new value of the @@ -1164,49 +1515,29 @@ Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags) * Side effects: * The value of the given variable is set. If either the array or the * entry didn't exist then a new variable is created. - * - * The reference count is decremented for any old value of the variable - * and incremented for its new value. If the new value for the variable - * is not the same one referenced by newValuePtr (perhaps as a result - * of a variable trace), then newValuePtr's ref count is left unchanged - * by Tcl_SetVar2Ex. newValuePtr's ref count is also left unchanged if - * we are appending it as a string value: that is, if "flags" includes - * TCL_APPEND_VALUE but not TCL_LIST_ELEMENT. - * - * The reference count for the returned object is _not_ incremented: if - * you want to keep a reference to the object you must increment its - * ref count yourself. + * *---------------------------------------------------------------------- */ Tcl_Obj * -Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags) +TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, newValuePtr, flags) Tcl_Interp *interp; /* Command interpreter in which variable is - * to be found. */ - char *part1; /* Name of an array (if part2 is non-NULL) + * to be looked up. */ + register Var *varPtr; + Var *arrayPtr; + CONST char *part1; /* Name of an array (if part2 is non-NULL) * or the name of a variable. */ - char *part2; /* If non-NULL, gives the name of an element + CONST char *part2; /* If non-NULL, gives the name of an element * in the array part1. */ Tcl_Obj *newValuePtr; /* New value for variable. */ - int flags; /* Various flags that tell how to set value: - * any of TCL_GLOBAL_ONLY, - * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE, - * TCL_LIST_ELEMENT or TCL_LEAVE_ERR_MSG. */ + CONST int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, + * and TCL_LEAVE_ERR_MSG bits. */ { Interp *iPtr = (Interp *) interp; - register Var *varPtr; - Var *arrayPtr; Tcl_Obj *oldValuePtr; Tcl_Obj *resultPtr = NULL; - char *bytes; - int length, result; - - varPtr = TclLookupVar(interp, part1, part2, flags, "set", - /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); - if (varPtr == NULL) { - return NULL; - } + int result; /* * If the variable is in a hashtable and its hPtr field is NULL, then we @@ -1239,12 +1570,18 @@ Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags) } /* - * At this point, if we were appending, we used to call read traces: we - * treated append as a read-modify-write. However, it seemed unlikely to - * us that a real program would be interested in such reads being done - * during a set operation. + * Invoke any read traces that have been set for the variable if it + * is requested; this is only done in the core when lappending. */ + if ((flags & TCL_TRACE_READS) && ((varPtr->tracePtr != NULL) + || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL)))) { + if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, + TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) { + return NULL; + } + } + /* * Set the variable's new value. If appending, append the new value to * the variable, either as a list element or as a string. Also, if @@ -1281,10 +1618,9 @@ Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags) * We append newValuePtr's bytes but don't change its ref count. */ - bytes = Tcl_GetStringFromObj(newValuePtr, &length); if (oldValuePtr == NULL) { - varPtr->value.objPtr = Tcl_NewStringObj(bytes, length); - Tcl_IncrRefCount(varPtr->value.objPtr); + varPtr->value.objPtr = newValuePtr; + Tcl_IncrRefCount(newValuePtr); } else { if (Tcl_IsShared(oldValuePtr)) { /* append to copy */ varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); @@ -1295,34 +1631,16 @@ Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags) Tcl_AppendObjToObj(oldValuePtr, newValuePtr); } } - } else { - if (flags & TCL_LIST_ELEMENT) { /* set var to list element */ - int neededBytes, listFlags; - - /* - * We set the variable to the result of converting newValuePtr's - * string rep to a list element. We do not change newValuePtr's - * ref count. - */ + } else if (newValuePtr != oldValuePtr) { + /* + * In this case we are replacing the value, so we don't need to + * do more than swap the objects. + */ - if (oldValuePtr != NULL) { - Tcl_DecrRefCount(oldValuePtr); /* discard old value */ - } - bytes = Tcl_GetStringFromObj(newValuePtr, &length); - neededBytes = Tcl_ScanElement(bytes, &listFlags); - oldValuePtr = Tcl_NewObj(); - oldValuePtr->bytes = (char *) - ckalloc((unsigned) (neededBytes + 1)); - oldValuePtr->length = Tcl_ConvertElement(bytes, - oldValuePtr->bytes, listFlags); - varPtr->value.objPtr = oldValuePtr; - Tcl_IncrRefCount(varPtr->value.objPtr); - } else if (newValuePtr != oldValuePtr) { - varPtr->value.objPtr = newValuePtr; - Tcl_IncrRefCount(newValuePtr); /* var is another ref */ - if (oldValuePtr != NULL) { - TclDecrRefCount(oldValuePtr); /* discard old value */ - } + varPtr->value.objPtr = newValuePtr; + Tcl_IncrRefCount(newValuePtr); /* var is another ref */ + if (oldValuePtr != NULL) { + TclDecrRefCount(oldValuePtr); /* discard old value */ } } TclSetVarScalar(varPtr); @@ -1337,12 +1655,9 @@ Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags) if ((varPtr->tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { - char *msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2, - (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_WRITES); - if (msg != NULL) { - if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, "set", msg); - } + if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, + (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) + | TCL_TRACE_WRITES, (flags & TCL_LEAVE_ERR_MSG))) { goto cleanup; } } @@ -1379,403 +1694,6 @@ Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags) /* *---------------------------------------------------------------------- * - * TclSetIndexedScalar -- - * - * Change the Tcl object value of a local scalar variable in the active - * procedure, given its compile-time allocated index in the procedure's - * array of local variables. - * - * Results: - * Returns a pointer to the Tcl_Obj holding the new value of the - * variable given by localIndex. If the specified variable doesn't - * exist, or there is a clash in array usage, or an error occurs while - * executing variable traces, then NULL is returned and a message will - * be left in the interpreter's result if leaveErrorMsg is 1. Note - * that the returned object may not be the same one referenced by - * newValuePtr; this is because variable traces may modify the - * variable's value. - * - * Side effects: - * The value of the given variable is set. The reference count is - * decremented for any old value of the variable and incremented for - * its new value. If as a result of a variable trace the new value for - * the variable is not the same one referenced by newValuePtr, then - * newValuePtr's ref count is left unchanged. The ref count for the - * returned object is _not_ incremented to reflect the returned - * reference; if you want to keep a reference to the object you must - * increment its ref count yourself. This procedure does not create - * new variables, but only sets those recognized at compile time. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclSetIndexedScalar(interp, localIndex, newValuePtr, leaveErrorMsg) - Tcl_Interp *interp; /* Command interpreter in which variable is - * to be found. */ - int localIndex; /* Index of variable in procedure's array - * of local variables. */ - Tcl_Obj *newValuePtr; /* New value for variable. */ - int leaveErrorMsg; /* 1 if to leave an error message in - * the interpreter's result on an error. - * Otherwise no error message is left. */ -{ - Interp *iPtr = (Interp *) interp; - CallFrame *varFramePtr = iPtr->varFramePtr; - /* Points to the procedure call frame whose - * variables are currently in use. Same as - * the current procedure's frame, if any, - * unless an "uplevel" is executing. */ - Var *compiledLocals = varFramePtr->compiledLocals; - register Var *varPtr; /* Points to the variable's in-frame Var - * structure. */ - char *varName; /* Name of the local variable. */ - Tcl_Obj *oldValuePtr; - Tcl_Obj *resultPtr = NULL; - -#ifdef TCL_COMPILE_DEBUG - Proc *procPtr = varFramePtr->procPtr; - int localCt = procPtr->numCompiledLocals; - - if (compiledLocals == NULL) { - fprintf(stderr, "\nTclSetIndexedScalar: can't set local %i in frame 0x%x, no compiled locals\n", - localIndex, (unsigned int) varFramePtr); - panic("TclSetIndexedScalar: no compiled locals in frame 0x%x", - (unsigned int) varFramePtr); - } - if ((localIndex < 0) || (localIndex >= localCt)) { - fprintf(stderr, "\nTclSetIndexedScalar: can't set local %i in frame 0x%x with %i locals\n", - localIndex, (unsigned int) varFramePtr, localCt); - panic("TclSetIndexedScalar: bad local index %i in frame 0x%x", - localIndex, (unsigned int) varFramePtr); - } -#endif /* TCL_COMPILE_DEBUG */ - - varPtr = &(compiledLocals[localIndex]); - varName = varPtr->name; - - /* - * If varPtr is a link variable, we have a reference to some variable - * that was created through an "upvar" or "global" command, or we have a - * reference to a variable in an enclosing namespace. Traverse through - * any links until we find the referenced variable. - */ - - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - - /* - * If the variable is in a hashtable and its hPtr field is NULL, then we - * may have an upvar to an array element where the array was deleted - * or an upvar to a namespace variable whose namespace was deleted. - * Generate an error (allowing the variable to be reset would screw up - * our storage allocation and is meaningless anyway). - */ - - if ((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) { - if (leaveErrorMsg) { - if (TclIsVarArrayElement(varPtr)) { - VarErrMsg(interp, varName, NULL, "set", danglingElement); - } else { - VarErrMsg(interp, varName, NULL, "set", danglingVar); - } - } - return NULL; - } - - /* - * It's an error to try to set an array variable itself. - */ - - if (TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { - if (leaveErrorMsg) { - VarErrMsg(interp, varName, NULL, "set", isArray); - } - return NULL; - } - - /* - * Set the variable's new value and discard its old value. We don't - * append with this "set" procedure so the old value isn't needed. - */ - - oldValuePtr = varPtr->value.objPtr; - if (newValuePtr != oldValuePtr) { /* set new value */ - varPtr->value.objPtr = newValuePtr; - Tcl_IncrRefCount(newValuePtr); /* var is another ref to obj */ - if (oldValuePtr != NULL) { - TclDecrRefCount(oldValuePtr); /* discard old value */ - } - } - TclSetVarScalar(varPtr); - TclClearVarUndefined(varPtr); - - /* - * Invoke any write traces for the variable. - */ - - if (varPtr->tracePtr != NULL) { - char *msg = CallTraces(iPtr, /*arrayPtr*/ NULL, varPtr, - varName, (char *) NULL, TCL_TRACE_WRITES); - if (msg != NULL) { - if (leaveErrorMsg) { - VarErrMsg(interp, varName, NULL, "set", msg); - } - goto cleanup; - } - } - - /* - * Return the variable's value unless the variable was changed in some - * gross way by a trace (e.g. it was unset and then recreated as an - * array). If it was changed is a gross way, just return an empty string - * object. - */ - - if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) { - return varPtr->value.objPtr; - } - - resultPtr = Tcl_NewObj(); - - /* - * If the variable doesn't exist anymore and no-one's using it, then - * free up the relevant structures and hash table entries. - */ - - cleanup: - if (TclIsVarUndefined(varPtr)) { - CleanupVar(varPtr, NULL); - } - return resultPtr; -} - -/* - *---------------------------------------------------------------------- - * - * TclSetElementOfIndexedArray -- - * - * Change the Tcl object value of an element in a local array - * variable. The element is named by the object elemPtr while the array - * is specified by its index in the active procedure's array of - * compiler allocated local variables. - * - * Results: - * Returns a pointer to the Tcl_Obj holding the new value of the - * element. If the specified array or element doesn't exist, or there - * is a clash in array usage, or an error occurs while executing - * variable traces, then NULL is returned and a message will be left in - * the interpreter's result if leaveErrorMsg is 1. Note that the - * returned object may not be the same one referenced by newValuePtr; - * this is because variable traces may modify the variable's value. - * - * Side effects: - * The value of the given array element is set. The reference count is - * decremented for any old value of the element and incremented for its - * new value. If as a result of a variable trace the new value for the - * element is not the same one referenced by newValuePtr, then - * newValuePtr's ref count is left unchanged. The ref count for the - * returned object is _not_ incremented to reflect the returned - * reference; if you want to keep a reference to the object you must - * increment its ref count yourself. This procedure will not create new - * array variables, but only sets elements of those arrays recognized - * at compile time. However, if the entry doesn't exist then a new - * variable is created. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr, - leaveErrorMsg) - Tcl_Interp *interp; /* Command interpreter in which the array is - * to be found. */ - int localIndex; /* Index of array variable in procedure's - * array of local variables. */ - Tcl_Obj *elemPtr; /* Points to an object holding the name of - * an element to set in the array. */ - Tcl_Obj *newValuePtr; /* New value for variable. */ - int leaveErrorMsg; /* 1 if to leave an error message in - * the interpreter's result on an error. - * Otherwise no error message is left. */ -{ - Interp *iPtr = (Interp *) interp; - CallFrame *varFramePtr = iPtr->varFramePtr; - /* Points to the procedure call frame whose - * variables are currently in use. Same as - * the current procedure's frame, if any, - * unless an "uplevel" is executing. */ - Var *compiledLocals = varFramePtr->compiledLocals; - Var *arrayPtr; /* Points to the array's in-frame Var - * structure. */ - char *arrayName; /* Name of the local array. */ - char *elem; - Tcl_HashEntry *hPtr; - Var *varPtr = NULL; /* Points to the element's Var structure - * that we return. */ - Tcl_Obj *resultPtr = NULL; - Tcl_Obj *oldValuePtr; - int new; - -#ifdef TCL_COMPILE_DEBUG - Proc *procPtr = varFramePtr->procPtr; - int localCt = procPtr->numCompiledLocals; - - if (compiledLocals == NULL) { - fprintf(stderr, "\nTclSetElementOfIndexedArray: can't set element of local %i in frame 0x%x, no compiled locals\n", - localIndex, (unsigned int) varFramePtr); - panic("TclSetIndexedScalar: no compiled locals in frame 0x%x", - (unsigned int) varFramePtr); - } - if ((localIndex < 0) || (localIndex >= localCt)) { - fprintf(stderr, "\nTclSetIndexedScalar: can't set elememt of local %i in frame 0x%x with %i locals\n", - localIndex, (unsigned int) varFramePtr, localCt); - panic("TclSetElementOfIndexedArray: bad local index %i in frame 0x%x", - localIndex, (unsigned int) varFramePtr); - } -#endif /* TCL_COMPILE_DEBUG */ - - elem = TclGetString(elemPtr); - arrayPtr = &(compiledLocals[localIndex]); - arrayName = arrayPtr->name; - - /* - * If arrayPtr is a link variable, we have a reference to some variable - * that was created through an "upvar" or "global" command, or we have a - * reference to a variable in an enclosing namespace. Traverse through - * any links until we find the referenced variable. - */ - - while (TclIsVarLink(arrayPtr)) { - arrayPtr = arrayPtr->value.linkPtr; - } - - /* - * If the variable is in a hashtable and its hPtr field is NULL, then we - * may have an upvar to an array element where the array was deleted - * or an upvar to a namespace variable whose namespace was deleted. - * Generate an error (allowing the variable to be reset would screw up - * our storage allocation and is meaningless anyway). - */ - - if ((arrayPtr->flags & VAR_IN_HASHTABLE) && (arrayPtr->hPtr == NULL)) { - if (leaveErrorMsg) { - if (TclIsVarArrayElement(arrayPtr)) { - VarErrMsg(interp, arrayName, elem, "set", danglingElement); - } else { - VarErrMsg(interp, arrayName, elem, "set", danglingVar); - } - } - goto errorReturn; - } - - /* - * Make sure we're dealing with an array. - */ - - if (TclIsVarUndefined(arrayPtr) && !TclIsVarArrayElement(arrayPtr)) { - TclSetVarArray(arrayPtr); - arrayPtr->value.tablePtr = - (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitHashTable(arrayPtr->value.tablePtr, TCL_STRING_KEYS); - TclClearVarUndefined(arrayPtr); - } else if (!TclIsVarArray(arrayPtr)) { - if (leaveErrorMsg) { - VarErrMsg(interp, arrayName, elem, "set", needArray); - } - goto errorReturn; - } - - /* - * Look up the element. - */ - - hPtr = Tcl_CreateHashEntry(arrayPtr->value.tablePtr, elem, &new); - if (new) { - if (arrayPtr->searchPtr != NULL) { - DeleteSearches(arrayPtr); - } - varPtr = NewVar(); - Tcl_SetHashValue(hPtr, varPtr); - varPtr->hPtr = hPtr; - varPtr->nsPtr = varFramePtr->nsPtr; - TclSetVarArrayElement(varPtr); - } - varPtr = (Var *) Tcl_GetHashValue(hPtr); - - /* - * It's an error to try to set an array variable itself. - */ - - if (TclIsVarArray(varPtr)) { - if (leaveErrorMsg) { - VarErrMsg(interp, arrayName, elem, "set", isArray); - } - goto errorReturn; - } - - /* - * Set the variable's new value and discard the old one. We don't - * append with this "set" procedure so the old value isn't needed. - */ - - oldValuePtr = varPtr->value.objPtr; - if (newValuePtr != oldValuePtr) { /* set new value */ - varPtr->value.objPtr = newValuePtr; - Tcl_IncrRefCount(newValuePtr); /* var is another ref to obj */ - if (oldValuePtr != NULL) { - TclDecrRefCount(oldValuePtr); /* discard old value */ - } - } - TclSetVarScalar(varPtr); - TclClearVarUndefined(varPtr); - - /* - * Invoke any write traces for the element variable. - */ - - if ((varPtr->tracePtr != NULL) - || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { - char *msg = CallTraces(iPtr, arrayPtr, varPtr, arrayName, elem, - TCL_TRACE_WRITES); - if (msg != NULL) { - if (leaveErrorMsg) { - VarErrMsg(interp, arrayName, elem, "set", msg); - } - goto errorReturn; - } - } - - /* - * Return the element's value unless it was changed in some gross way by - * a trace (e.g. it was unset and then recreated as an array). If it was - * changed is a gross way, just return an empty string object. - */ - - if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) { - return varPtr->value.objPtr; - } - - resultPtr = Tcl_NewObj(); - - /* - * An error. If the variable doesn't exist anymore and no-one's using - * it, then free up the relevant structures and hash table entries. - */ - - errorReturn: - if (varPtr != NULL) { - if (TclIsVarUndefined(varPtr)) { - CleanupVar(varPtr, NULL); /* note: array isn't in hashtable */ - } - } - return resultPtr; -} - -/* - *---------------------------------------------------------------------- - * * TclIncrVar2 -- * * Given a two-part variable name, which may refer either to a scalar @@ -1815,96 +1733,75 @@ TclIncrVar2(interp, part1Ptr, part2Ptr, incrAmount, flags) * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE, * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */ { - register Tcl_Obj *varValuePtr; - Tcl_Obj *resultPtr; - int createdNewObj; /* Set 1 if var's value object is shared - * so we must increment a copy (i.e. copy - * on write). */ - long i; - int result; + Var *varPtr, *arrayPtr; + char *part1, *part2; - varValuePtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags); - if (varValuePtr == NULL) { + part1 = TclGetString(part1Ptr); + part2 = ((part2Ptr == NULL)? NULL : TclGetString(part2Ptr)); + + varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "read", + 0, 1, &arrayPtr); + if (varPtr == NULL) { Tcl_AddObjErrorInfo(interp, "\n (reading value of variable to increment)", -1); return NULL; } - - /* - * Increment the variable's value. If the object is unshared we can - * modify it directly, otherwise we must create a new copy to modify: - * this is "copy on write". Then free the variable's old string - * representation, if any, since it will no longer be valid. - */ - - createdNewObj = 0; - if (Tcl_IsShared(varValuePtr)) { - varValuePtr = Tcl_DuplicateObj(varValuePtr); - createdNewObj = 1; - } - result = Tcl_GetLongFromObj(interp, varValuePtr, &i); - if (result != TCL_OK) { - if (createdNewObj) { - Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */ - } - return NULL; - } - Tcl_SetLongObj(varValuePtr, (i + incrAmount)); - - /* - * Store the variable's new value and run any write traces. - */ - - resultPtr = Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, varValuePtr, flags); - if (resultPtr == NULL) { - return NULL; - } - return resultPtr; + return TclPtrIncrVar(interp, varPtr, arrayPtr, part1, part2, + incrAmount, flags); } /* *---------------------------------------------------------------------- * - * TclIncrIndexedScalar -- + * TclPtrIncrVar -- * - * Increments the Tcl object value of a local scalar variable in the - * active procedure, given its compile-time allocated index in the - * procedure's array of local variables. + * Given the pointers to a variable and possible containing array, + * increment the Tcl object value of the variable by a specified + * amount. * * Results: * Returns a pointer to the Tcl_Obj holding the new value of the - * variable given by localIndex. If the specified variable doesn't - * exist, or there is a clash in array usage, or an error occurs while - * executing variable traces, then NULL is returned and a message will - * be left in the interpreter's result. + * variable. If the specified variable doesn't exist, or there is a + * clash in array usage, or an error occurs while executing variable + * traces, then NULL is returned and a message will be left in + * the interpreter's result. * * Side effects: * The value of the given variable is incremented by the specified - * amount. The ref count for the returned object is _not_ incremented - * to reflect the returned reference; if you want to keep a reference - * to the object you must increment its ref count yourself. + * amount. If either the array or the entry didn't exist then a new + * variable is created. The ref count for the returned object is _not_ + * incremented to reflect the returned reference; if you want to keep a + * reference to the object you must increment its ref count yourself. * *---------------------------------------------------------------------- */ Tcl_Obj * -TclIncrIndexedScalar(interp, localIndex, incrAmount) +TclPtrIncrVar(interp, varPtr, arrayPtr, part1, part2, incrAmount, flags) Tcl_Interp *interp; /* Command interpreter in which variable is * to be found. */ - int localIndex; /* Index of variable in procedure's array - * of local variables. */ - long incrAmount; /* Amount to be added to variable. */ + Var *varPtr; + Var *arrayPtr; + CONST char *part1; /* Points to an object holding the name of + * an array (if part2 is non-NULL) or the + * name of a variable. */ + CONST char *part2; /* If non-null, points to an object holding + * the name of an element in the array + * part1Ptr. */ + CONST long incrAmount; /* Amount to be added to variable. */ + CONST int flags; /* Various flags that tell how to incr value: + * any of TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE, + * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */ { register Tcl_Obj *varValuePtr; - Tcl_Obj *resultPtr; int createdNewObj; /* Set 1 if var's value object is shared * so we must increment a copy (i.e. copy * on write). */ long i; - int result; - varValuePtr = TclGetIndexedScalar(interp, localIndex, - /*leaveErrorMsg*/ 1); + varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags); + if (varValuePtr == NULL) { Tcl_AddObjErrorInfo(interp, "\n (reading value of variable to increment)", -1); @@ -1912,125 +1809,58 @@ TclIncrIndexedScalar(interp, localIndex, incrAmount) } /* - * Reach into the object's representation to extract and increment the - * variable's value. If the object is unshared we can modify it - * directly, otherwise we must create a new copy to modify: this is - * "copy on write". Then free the variable's old string representation, - * if any, since it will no longer be valid. + * Increment the variable's value. If the object is unshared we can + * modify it directly, otherwise we must create a new copy to modify: + * this is "copy on write". Then free the variable's old string + * representation, if any, since it will no longer be valid. */ createdNewObj = 0; if (Tcl_IsShared(varValuePtr)) { - createdNewObj = 1; varValuePtr = Tcl_DuplicateObj(varValuePtr); + createdNewObj = 1; } - result = Tcl_GetLongFromObj(interp, varValuePtr, &i); - if (result != TCL_OK) { +#ifdef TCL_WIDE_INT_IS_LONG + if (Tcl_GetLongFromObj(interp, varValuePtr, &i) != TCL_OK) { if (createdNewObj) { Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */ } return NULL; } Tcl_SetLongObj(varValuePtr, (i + incrAmount)); - - /* - * Store the variable's new value and run any write traces. - */ - - resultPtr = TclSetIndexedScalar(interp, localIndex, varValuePtr, - /*leaveErrorMsg*/ 1); - if (resultPtr == NULL) { - return NULL; - } - return resultPtr; -} - -/* - *---------------------------------------------------------------------- - * - * TclIncrElementOfIndexedArray -- - * - * Increments the Tcl object value of an element in a local array - * variable. The element is named by the object elemPtr while the array - * is specified by its index in the active procedure's array of - * compiler allocated local variables. - * - * Results: - * Returns a pointer to the Tcl_Obj holding the new value of the - * element. If the specified array or element doesn't exist, or there - * is a clash in array usage, or an error occurs while executing - * variable traces, then NULL is returned and a message will be left in - * the interpreter's result. - * - * Side effects: - * The value of the given array element is incremented by the specified - * amount. The ref count for the returned object is _not_ incremented - * to reflect the returned reference; if you want to keep a reference - * to the object you must increment its ref count yourself. If the - * entry doesn't exist then a new variable is created. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclIncrElementOfIndexedArray(interp, localIndex, elemPtr, incrAmount) - Tcl_Interp *interp; /* Command interpreter in which the array is - * to be found. */ - int localIndex; /* Index of array variable in procedure's - * array of local variables. */ - Tcl_Obj *elemPtr; /* Points to an object holding the name of - * an element to increment in the array. */ - long incrAmount; /* Amount to be added to variable. */ -{ - register Tcl_Obj *varValuePtr; - Tcl_Obj *resultPtr; - int createdNewObj; /* Set 1 if var's value object is shared - * so we must increment a copy (i.e. copy - * on write). */ - long i; - int result; - - varValuePtr = TclGetElementOfIndexedArray(interp, localIndex, elemPtr, - /*leaveErrorMsg*/ 1); - if (varValuePtr == NULL) { - Tcl_AddObjErrorInfo(interp, - "\n (reading value of variable to increment)", -1); - return NULL; - } - - /* - * Reach into the object's representation to extract and increment the - * variable's value. If the object is unshared we can modify it - * directly, otherwise we must create a new copy to modify: this is - * "copy on write". Then free the variable's old string representation, - * if any, since it will no longer be valid. - */ - - createdNewObj = 0; - if (Tcl_IsShared(varValuePtr)) { - createdNewObj = 1; - varValuePtr = Tcl_DuplicateObj(varValuePtr); - } - result = Tcl_GetLongFromObj(interp, varValuePtr, &i); - if (result != TCL_OK) { - if (createdNewObj) { - Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */ +#else + if (varValuePtr->typePtr == &tclWideIntType) { + Tcl_WideInt wide = varValuePtr->internalRep.wideValue; + Tcl_SetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount)); + } else if (varValuePtr->typePtr == &tclIntType) { + i = varValuePtr->internalRep.longValue; + Tcl_SetIntObj(varValuePtr, i + incrAmount); + } else { + /* + * Not an integer or wide internal-rep... + */ + Tcl_WideInt wide; + if (Tcl_GetWideIntFromObj(interp, varValuePtr, &wide) != TCL_OK) { + if (createdNewObj) { + Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */ + } + return NULL; + } + if (wide <= Tcl_LongAsWide(LONG_MAX) + && wide >= Tcl_LongAsWide(LONG_MIN)) { + Tcl_SetLongObj(varValuePtr, Tcl_WideAsLong(wide) + incrAmount); + } else { + Tcl_SetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount)); } - return NULL; } - Tcl_SetLongObj(varValuePtr, (i + incrAmount)); - +#endif + /* * Store the variable's new value and run any write traces. */ - resultPtr = TclSetElementOfIndexedArray(interp, localIndex, elemPtr, - varValuePtr, - /*leaveErrorMsg*/ 1); - if (resultPtr == NULL) { - return NULL; - } - return resultPtr; + return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, + varValuePtr, flags); } /* @@ -2057,7 +1887,7 @@ int Tcl_UnsetVar(interp, varName, flags) Tcl_Interp *interp; /* Command interpreter in which varName is * to be looked up. */ - char *varName; /* Name of a variable in interp. May be + CONST char *varName; /* Name of a variable in interp. May be * either a scalar name or an array name * or an element in an array. */ int flags; /* OR-ed combination of any of @@ -2092,8 +1922,51 @@ int Tcl_UnsetVar2(interp, part1, part2, flags) Tcl_Interp *interp; /* Command interpreter in which varName is * to be looked up. */ - char *part1; /* Name of variable or array. */ - char *part2; /* Name of element within array or NULL. */ + CONST char *part1; /* Name of variable or array. */ + CONST char *part2; /* Name of element within array or NULL. */ + int flags; /* OR-ed combination of any of + * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, + * TCL_LEAVE_ERR_MSG. */ +{ + int result; + Tcl_Obj *part1Ptr; + + part1Ptr = Tcl_NewStringObj(part1, -1); + Tcl_IncrRefCount(part1Ptr); + result = TclObjUnsetVar2(interp, part1Ptr, part2, flags); + TclDecrRefCount(part1Ptr); + + return result; +} + + +/* + *---------------------------------------------------------------------- + * + * TclObjUnsetVar2 -- + * + * Delete a variable, given a 2-object name. + * + * Results: + * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR + * if the variable can't be unset. In the event of an error, + * if the TCL_LEAVE_ERR_MSG flag is set then an error message + * is left in the interp's result. + * + * Side effects: + * If part1ptr and part2Ptr indicate a local or global variable in interp, + * it is deleted. If part1Ptr is an array name and part2Ptr is NULL, then + * the whole array is deleted. + * + *---------------------------------------------------------------------- + */ + +int +TclObjUnsetVar2(interp, part1Ptr, part2, flags) + Tcl_Interp *interp; /* Command interpreter in which varName is + * to be looked up. */ + Tcl_Obj *part1Ptr; /* Name of variable or array. */ + CONST char *part2; /* Name of element within array or NULL. */ int flags; /* OR-ed combination of any of * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * TCL_LEAVE_ERR_MSG. */ @@ -2105,12 +1978,15 @@ Tcl_UnsetVar2(interp, part1, part2, flags) ActiveVarTrace *activePtr; Tcl_Obj *objPtr; int result; + char *part1; - varPtr = TclLookupVar(interp, part1, part2, flags, "unset", + part1 = TclGetString(part1Ptr); + varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "unset", /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); if (varPtr == NULL) { return TCL_ERROR; } + result = (TclIsVarUndefined(varPtr)? TCL_ERROR : TCL_OK); if ((arrayPtr != NULL) && (arrayPtr->searchPtr != NULL)) { @@ -2141,7 +2017,7 @@ Tcl_UnsetVar2(interp, part1, part2, flags) * Call trace procedures for the variable being deleted. Then delete * its traces. Be sure to abort any other traces for the variable * that are still pending. Special tricks: - * 1. We need to increment varPtr's refCount around this: CallTraces + * 1. We need to increment varPtr's refCount around this: CallVarTraces * will use dummyVar so it won't increment varPtr's refCount itself. * 2. Turn off the VAR_TRACE_ACTIVE flag in dummyVar: we want to * call unset traces even if other traces are pending. @@ -2151,14 +2027,15 @@ Tcl_UnsetVar2(interp, part1, part2, flags) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { varPtr->refCount++; dummyVar.flags &= ~VAR_TRACE_ACTIVE; - (void) CallTraces(iPtr, arrayPtr, &dummyVar, part1, part2, - (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS); + CallVarTraces(iPtr, arrayPtr, &dummyVar, part1, part2, + (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) + | TCL_TRACE_UNSETS, /* leaveErrMsg */ 0); while (dummyVar.tracePtr != NULL) { VarTrace *tracePtr = dummyVar.tracePtr; dummyVar.tracePtr = tracePtr->nextPtr; - ckfree((char *) tracePtr); + Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); } - for (activePtr = iPtr->activeTracePtr; activePtr != NULL; + for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; activePtr = activePtr->nextPtr) { if (activePtr->varPtr == varPtr) { activePtr->nextTracePtr = NULL; @@ -2190,7 +2067,8 @@ Tcl_UnsetVar2(interp, part1, part2, flags) */ varPtr->refCount++; DeleteArray(iPtr, part1, dummyVarPtr, - (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS); + (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) + | TCL_TRACE_UNSETS); /* Decr ref count */ varPtr->refCount--; } @@ -2256,7 +2134,7 @@ int Tcl_TraceVar(interp, varName, flags, proc, clientData) Tcl_Interp *interp; /* Interpreter in which variable is * to be traced. */ - char *varName; /* Name of variable; may end with "(index)" + CONST char *varName; /* Name of variable; may end with "(index)" * to signify an array reference. */ int flags; /* OR-ed collection of bits, including any * of TCL_TRACE_READS, TCL_TRACE_WRITES, @@ -2295,8 +2173,8 @@ int Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData) Tcl_Interp *interp; /* Interpreter in which variable is * to be traced. */ - char *part1; /* Name of scalar variable or array. */ - char *part2; /* Name of element within array; NULL means + CONST char *part1; /* Name of scalar variable or array. */ + CONST char *part2; /* Name of element within array; NULL means * trace applies to scalar variable or array * as-a-whole. */ int flags; /* OR-ed collection of bits, including any @@ -2309,25 +2187,46 @@ Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData) { Var *varPtr, *arrayPtr; register VarTrace *tracePtr; - - varPtr = TclLookupVar(interp, part1, part2, (flags | TCL_LEAVE_ERR_MSG), + int flagMask; + + /* + * We strip 'flags' down to just the parts which are relevant to + * TclLookupVar, to avoid conflicts between trace flags and + * internal namespace flags such as 'FIND_ONLY_NS'. This can + * now occur since we have trace flags with values 0x1000 and higher. + */ + flagMask = TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY; + varPtr = TclLookupVar(interp, part1, part2, + (flags & flagMask) | TCL_LEAVE_ERR_MSG, "trace", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); if (varPtr == NULL) { return TCL_ERROR; } /* + * Check for a nonsense flag combination. Note that this is a + * panic() because there should be no code path that ever sets + * both flags. + */ + if ((flags&TCL_TRACE_RESULT_DYNAMIC) && (flags&TCL_TRACE_RESULT_OBJECT)) { + panic("bad result flag combination"); + } + + /* * Set up trace information. */ + flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | + TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT; +#ifndef TCL_REMOVE_OBSOLETE_TRACES + flagMask |= TCL_TRACE_OLD_STYLE; +#endif tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace)); - tracePtr->traceProc = proc; - tracePtr->clientData = clientData; - tracePtr->flags = - flags & (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | - TCL_TRACE_ARRAY); - tracePtr->nextPtr = varPtr->tracePtr; - varPtr->tracePtr = tracePtr; + tracePtr->traceProc = proc; + tracePtr->clientData = clientData; + tracePtr->flags = flags & flagMask; + tracePtr->nextPtr = varPtr->tracePtr; + varPtr->tracePtr = tracePtr; return TCL_OK; } @@ -2352,7 +2251,7 @@ Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData) void Tcl_UntraceVar(interp, varName, flags, proc, clientData) Tcl_Interp *interp; /* Interpreter containing variable. */ - char *varName; /* Name of variable; may end with "(index)" + CONST char *varName; /* Name of variable; may end with "(index)" * to signify an array reference. */ int flags; /* OR-ed collection of bits describing * current trace, including any of @@ -2386,8 +2285,8 @@ Tcl_UntraceVar(interp, varName, flags, proc, clientData) void Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) Tcl_Interp *interp; /* Interpreter containing variable. */ - char *part1; /* Name of variable or array. */ - char *part2; /* Name of element within array; NULL means + CONST char *part1; /* Name of variable or array. */ + CONST char *part2; /* Name of element within array; NULL means * trace applies to scalar variable or array * as-a-whole. */ int flags; /* OR-ed collection of bits describing @@ -2403,17 +2302,31 @@ Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) Var *varPtr, *arrayPtr; Interp *iPtr = (Interp *) interp; ActiveVarTrace *activePtr; - - varPtr = TclLookupVar(interp, part1, part2, - flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY), + int flagMask; + + /* + * Set up a mask to mask out the parts of the flags that we are not + * interested in now. + */ + flagMask = TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY; + varPtr = TclLookupVar(interp, part1, part2, flags & flagMask, /*msg*/ (char *) NULL, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); if (varPtr == NULL) { return; } - flags &= (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | - TCL_TRACE_ARRAY); + + /* + * Set up a mask to mask out the parts of the flags that we are not + * interested in now. + */ + flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | + TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT; +#ifndef TCL_REMOVE_OBSOLETE_TRACES + flagMask |= TCL_TRACE_OLD_STYLE; +#endif + flags &= flagMask; for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ; prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { if (tracePtr == NULL) { @@ -2428,10 +2341,10 @@ Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) /* * The code below makes it possible to delete traces while traces * are active: it makes sure that the deleted trace won't be - * processed by CallTraces. + * processed by CallVarTraces. */ - for (activePtr = iPtr->activeTracePtr; activePtr != NULL; + for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; activePtr = activePtr->nextPtr) { if (activePtr->nextTracePtr == tracePtr) { activePtr->nextTracePtr = tracePtr->nextPtr; @@ -2442,7 +2355,7 @@ Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) } else { prevPtr->nextPtr = tracePtr->nextPtr; } - ckfree((char *) tracePtr); + Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); /* * If this is the last trace on the variable, and the variable is @@ -2483,7 +2396,7 @@ Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) ClientData Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData) Tcl_Interp *interp; /* Interpreter containing variable. */ - char *varName; /* Name of variable; may end with "(index)" + CONST char *varName; /* Name of variable; may end with "(index)" * to signify an array reference. */ int flags; /* OR-ed combo or TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY (can be 0). */ @@ -2518,8 +2431,8 @@ Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData) ClientData Tcl_VarTraceInfo2(interp, part1, part2, flags, proc, prevClientData) Tcl_Interp *interp; /* Interpreter containing variable. */ - char *part1; /* Name of variable or array. */ - char *part2; /* Name of element within array; NULL means + CONST char *part1; /* Name of variable or array. */ + CONST char *part2; /* Name of element within array; NULL means * trace applies to scalar variable or array * as-a-whole. */ int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, @@ -2589,18 +2502,45 @@ Tcl_UnsetObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - register int i; + register int i, flags = TCL_LEAVE_ERR_MSG; register char *name; - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "varName ?varName ...?"); + if (objc < 1) { + Tcl_WrongNumArgs(interp, 1, objv, + "?-nocomplain? ?--? ?varName varName ...?"); return TCL_ERROR; + } else if (objc == 1) { + /* + * Do nothing if no arguments supplied, so as to match + * command documentation. + */ + return TCL_OK; } - - for (i = 1; i < objc; i++) { - name = TclGetString(objv[i]); - if (Tcl_UnsetVar2(interp, name, (char *) NULL, - TCL_LEAVE_ERR_MSG) != TCL_OK) { + + /* + * Simple, restrictive argument parsing. The only options are -- + * and -nocomplain (which must come first and be given exactly to + * be an option). + */ + i = 1; + name = TclGetString(objv[i]); + if (name[0] == '-') { + if (strcmp("-nocomplain", name) == 0) { + i++; + if (i == objc) { + return TCL_OK; + } + flags = 0; + name = TclGetString(objv[i]); + } + if (strcmp("--", name) == 0) { + i++; + } + } + + for (; i < objc; i++) { + if ((TclObjUnsetVar2(interp, objv[i], NULL, flags) != TCL_OK) + && (flags == TCL_LEAVE_ERR_MSG)) { return TCL_ERROR; } } @@ -2632,6 +2572,9 @@ Tcl_AppendObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { + Var *varPtr, *arrayPtr; + char *part1; + register Tcl_Obj *varValuePtr = NULL; /* Initialized to avoid compiler * warning. */ @@ -2641,15 +2584,29 @@ Tcl_AppendObjCmd(dummy, interp, objc, objv) Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?"); return TCL_ERROR; } + if (objc == 2) { varValuePtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); if (varValuePtr == NULL) { return TCL_ERROR; } } else { - for (i = 2; i < objc; i++) { - varValuePtr = Tcl_ObjSetVar2(interp, objv[1], (Tcl_Obj *) NULL, - objv[i], (TCL_APPEND_VALUE | TCL_LEAVE_ERR_MSG)); + varPtr = TclObjLookupVar(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG, + "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); + part1 = TclGetString(objv[1]); + if (varPtr == NULL) { + return TCL_ERROR; + } + for (i = 2; i < objc; i++) { + /* + * Note that we do not need to increase the refCount of + * the Var pointers: should a trace delete the variable, + * the return value of TclPtrSetVar will be NULL, and we + * will not access the variable again. + */ + + varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1, NULL, + objv[i], (TCL_APPEND_VALUE | TCL_LEAVE_ERR_MSG)); if (varValuePtr == NULL) { return TCL_ERROR; } @@ -2688,25 +2645,26 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) register List *listRepPtr; register Tcl_Obj **elemPtrs; int numElems, numRequired, createdNewObj, createVar, i, j; + Var *varPtr, *arrayPtr; + char *part1; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?"); return TCL_ERROR; } if (objc == 2) { - newValuePtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL, - (TCL_LEAVE_ERR_MSG)); + newValuePtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL, 0); if (newValuePtr == NULL) { /* * The variable doesn't exist yet. Just create it with an empty * initial value. */ - Tcl_Obj *nullObjPtr = Tcl_NewObj(); - newValuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL, - nullObjPtr, TCL_LEAVE_ERR_MSG); + varValuePtr = Tcl_NewObj(); + newValuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL, varValuePtr, + TCL_LEAVE_ERR_MSG); if (newValuePtr == NULL) { - Tcl_DecrRefCount(nullObjPtr); /* free unneeded object */ + Tcl_DecrRefCount(varValuePtr); /* free unneeded object */ return TCL_ERROR; } } @@ -2723,27 +2681,41 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) createdNewObj = 0; createVar = 1; - varValuePtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0); + + /* + * Use the TCL_TRACE_READS flag to ensure that if we have an + * array with no elements set yet, but with a read trace on it, + * we will create the variable and get read traces triggered. + * Note that you have to protect the variable pointers around + * the TclPtrGetVar call to insure that they remain valid + * even if the variable was undefined and unused. + */ + + varPtr = TclObjLookupVar(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG, + "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); + if (varPtr == NULL) { + return TCL_ERROR; + } + varPtr->refCount++; + if (arrayPtr != NULL) { + arrayPtr->refCount++; + } + part1 = TclGetString(objv[1]); + varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, NULL, + (TCL_TRACE_READS | TCL_LEAVE_ERR_MSG)); + varPtr->refCount--; + if (arrayPtr != NULL) { + arrayPtr->refCount--; + } + if (varValuePtr == NULL) { /* * We couldn't read the old value: either the var doesn't yet - * exist or it's an array element. If it's new, we will try to + * exist or it's an array element. If it's new, we will try to * create it with Tcl_ObjSetVar2 below. */ - char *p, *varName; - int nameBytes, i; - - varName = Tcl_GetStringFromObj(objv[1], &nameBytes); - for (i = 0, p = varName; i < nameBytes; i++, p++) { - if (*p == '(') { - p = (varName + nameBytes-1); - if (*p == ')') { /* last char is ')' => array ref */ - createVar = 0; - } - break; - } - } + createVar = (TclIsVarUndefined(varPtr)); varValuePtr = Tcl_NewObj(); createdNewObj = 1; } else if (Tcl_IsShared(varValuePtr)) { @@ -2764,7 +2736,7 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) return result; } } - listRepPtr = (List *) varValuePtr->internalRep.otherValuePtr; + listRepPtr = (List *) varValuePtr->internalRep.twoPtrValue.ptr1; elemPtrs = listRepPtr->elements; numElems = listRepPtr->elemCount; @@ -2810,8 +2782,8 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) * was new and we didn't create the variable. */ - newValuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL, varValuePtr, - TCL_LEAVE_ERR_MSG); + newValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1, NULL, + varValuePtr, TCL_LEAVE_ERR_MSG); if (newValuePtr == NULL) { if (createdNewObj && !createVar) { Tcl_DecrRefCount(varValuePtr); /* free unneeded obj */ @@ -2861,18 +2833,18 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) enum {ARRAY_ANYMORE, ARRAY_DONESEARCH, ARRAY_EXISTS, ARRAY_GET, ARRAY_NAMES, ARRAY_NEXTELEMENT, ARRAY_SET, ARRAY_SIZE, - ARRAY_STARTSEARCH, ARRAY_UNSET}; - static char *arrayOptions[] = { + ARRAY_STARTSEARCH, ARRAY_STATISTICS, ARRAY_UNSET}; + static CONST char *arrayOptions[] = { "anymore", "donesearch", "exists", "get", "names", "nextelement", - "set", "size", "startsearch", "unset", (char *) NULL + "set", "size", "startsearch", "statistics", "unset", (char *) NULL }; Interp *iPtr = (Interp *) interp; Var *varPtr, *arrayPtr; Tcl_HashEntry *hPtr; - Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); + Tcl_Obj *resultPtr, *varNamePtr; int notArray; - char *varName, *msg; + char *varName; int index, result; @@ -2887,38 +2859,50 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) } /* - * Locate the array variable (and it better be an array). + * Locate the array variable */ - varName = TclGetString(objv[2]); - varPtr = TclLookupVar(interp, varName, (char *) NULL, /*flags*/ 0, + varNamePtr = objv[2]; + varName = TclGetString(varNamePtr); + varPtr = TclObjLookupVar(interp, varNamePtr, NULL, /*flags*/ 0, /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - notArray = 0; - if ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)) { - notArray = 1; - } - /* * Special array trace used to keep the env array in sync for * array names, array get, etc. */ - if (varPtr != NULL && varPtr->tracePtr != NULL) { - msg = CallTraces(iPtr, arrayPtr, varPtr, varName, NULL, + if (varPtr != NULL && varPtr->tracePtr != NULL + && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { + if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, varName, NULL, (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY)); - if (msg != NULL) { - VarErrMsg(interp, varName, NULL, "trace array", msg); + TCL_TRACE_ARRAY), /* leaveErrMsg */ 1)) { return TCL_ERROR; } } + /* + * Verify that it is indeed an array variable. This test comes after + * the traces - the variable may actually become an array as an effect + * of said traces. + */ + + notArray = 0; + if ((varPtr == NULL) || !TclIsVarArray(varPtr) + || TclIsVarUndefined(varPtr)) { + notArray = 1; + } + + /* + * We have to wait to get the resultPtr until here because + * CallVarTraces can affect the result. + */ + + resultPtr = Tcl_GetObjResult(interp); + switch (index) { case ARRAY_ANYMORE: { ArraySearch *searchPtr; - char *searchId; if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, @@ -2928,8 +2912,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) if (notArray) { goto error; } - searchId = Tcl_GetString(objv[3]); - searchPtr = ParseSearchId(interp, varPtr, varName, searchId); + searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]); if (searchPtr == NULL) { return TCL_ERROR; } @@ -2953,7 +2936,6 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) } case ARRAY_DONESEARCH: { ArraySearch *searchPtr, *prevPtr; - char *searchId; if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, @@ -2963,8 +2945,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) if (notArray) { goto error; } - searchId = Tcl_GetString(objv[3]); - searchPtr = ParseSearchId(interp, varPtr, varName, searchId); + searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]); if (searchPtr == NULL) { return TCL_ERROR; } @@ -2995,7 +2976,8 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) Var *varPtr2; char *pattern = NULL; char *name; - Tcl_Obj *namePtr, *valuePtr; + Tcl_Obj *namePtr, *valuePtr, *nameLstPtr, *tmpResPtr, **namePtrPtr; + int i, count; if ((objc != 3) && (objc != 4)) { Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?"); @@ -3007,6 +2989,14 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) if (objc == 4) { pattern = TclGetString(objv[3]); } + + /* + * Store the array names in a new object. + */ + + nameLstPtr = Tcl_NewObj(); + Tcl_IncrRefCount(nameLstPtr); + for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { varPtr2 = (Var *) Tcl_GetHashValue(hPtr); @@ -3019,27 +3009,75 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) } namePtr = Tcl_NewStringObj(name, -1); - result = Tcl_ListObjAppendElement(interp, resultPtr, + result = Tcl_ListObjAppendElement(interp, nameLstPtr, namePtr); if (result != TCL_OK) { Tcl_DecrRefCount(namePtr); /* free unneeded name obj */ + Tcl_DecrRefCount(nameLstPtr); return result; } + } + + /* + * Make sure the Var structure of the array is not removed by + * a trace while we're working. + */ + + varPtr->refCount++; + + /* + * Get the array values corresponding to each element name + */ + tmpResPtr = Tcl_NewObj(); + result = Tcl_ListObjGetElements(interp, nameLstPtr, + &count, &namePtrPtr); + if (result != TCL_OK) { + goto errorInArrayGet; + } + + for (i = 0; i < count; i++) { + namePtr = *namePtrPtr++; valuePtr = Tcl_ObjGetVar2(interp, objv[2], namePtr, TCL_LEAVE_ERR_MSG); if (valuePtr == NULL) { - Tcl_DecrRefCount(namePtr); /* free unneeded name obj */ - return result; + /* + * Some trace played a trick on us; we need to diagnose to + * adapt our behaviour: was the array element unset, or did + * the modification modify the complete array? + */ + + if (TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { + /* + * The array itself looks OK, the variable was + * undefined: forget it. + */ + + continue; + } else { + result = TCL_ERROR; + goto errorInArrayGet; + } } - result = Tcl_ListObjAppendElement(interp, resultPtr, - valuePtr); + result = Tcl_ListObjAppendElement(interp, tmpResPtr, namePtr); if (result != TCL_OK) { - Tcl_DecrRefCount(namePtr); /* free unneeded name obj */ - return result; + goto errorInArrayGet; + } + result = Tcl_ListObjAppendElement(interp, tmpResPtr, valuePtr); + if (result != TCL_OK) { + goto errorInArrayGet; } } + varPtr->refCount--; + Tcl_SetObjResult(interp, tmpResPtr); + Tcl_DecrRefCount(nameLstPtr); break; + + errorInArrayGet: + varPtr->refCount--; + Tcl_DecrRefCount(nameLstPtr); + Tcl_DecrRefCount(tmpResPtr); /* free unneeded temp result obj */ + return result; } case ARRAY_NAMES: { Tcl_HashSearch search; @@ -3047,9 +3085,17 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) char *pattern = NULL; char *name; Tcl_Obj *namePtr; + int mode, matched = 0; + static CONST char *options[] = { + "-exact", "-glob", "-regexp", (char *) NULL + }; + enum options { OPT_EXACT, OPT_GLOB, OPT_REGEXP }; + + mode = OPT_GLOB; - if ((objc != 3) && (objc != 4)) { - Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?"); + if ((objc < 3) && (objc > 5)) { + Tcl_WrongNumArgs(interp, 2, objv, + "arrayName ?mode? ?pattern?"); return TCL_ERROR; } if (notArray) { @@ -3057,7 +3103,13 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) } if (objc == 4) { pattern = Tcl_GetString(objv[3]); - } + } else if (objc == 5) { + pattern = Tcl_GetString(objv[4]); + if (Tcl_GetIndexFromObj(interp, objv[3], options, "option", + 0, &mode) != TCL_OK) { + return TCL_ERROR; + } + } for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { varPtr2 = (Var *) Tcl_GetHashValue(hPtr); @@ -3065,8 +3117,25 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) continue; } name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); - if ((objc == 4) && !Tcl_StringMatch(name, pattern)) { - continue; /* element name doesn't match pattern */ + if (objc > 3) { + switch ((enum options) mode) { + case OPT_EXACT: + matched = (strcmp(name, pattern) == 0); + break; + case OPT_GLOB: + matched = Tcl_StringMatch(name, pattern); + break; + case OPT_REGEXP: + matched = Tcl_RegExpMatch(interp, name, + pattern); + if (matched < 0) { + return TCL_ERROR; + } + break; + } + if (matched == 0) { + continue; + } } namePtr = Tcl_NewStringObj(name, -1); @@ -3080,7 +3149,6 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) } case ARRAY_NEXTELEMENT: { ArraySearch *searchPtr; - char *searchId; Tcl_HashEntry *hPtr; if (objc != 4) { @@ -3091,8 +3159,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) if (notArray) { goto error; } - searchId = Tcl_GetString(objv[3]); - searchPtr = ParseSearchId(interp, varPtr, varName, searchId); + searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]); if (searchPtr == NULL) { return TCL_ERROR; } @@ -3178,7 +3245,27 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) varPtr->searchPtr = searchPtr; break; } - case ARRAY_UNSET: { + + case ARRAY_STATISTICS: { + CONST char *stats; + + if (notArray) { + goto error; + } + + stats = Tcl_HashStats(varPtr->value.tablePtr); + if (stats != NULL) { + Tcl_SetStringObj(Tcl_GetObjResult(interp), stats, -1); + ckfree((void *)stats); + } else { + Tcl_SetResult(interp, "error reading array statistics", + TCL_STATIC); + return TCL_ERROR; + } + break; + } + + case ARRAY_UNSET: { Tcl_HashSearch search; Var *varPtr2; char *pattern = NULL; @@ -3195,7 +3282,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) /* * When no pattern is given, just unset the whole array */ - if (Tcl_UnsetVar2(interp, varName, (char *) NULL, 0) + if (TclObjUnsetVar2(interp, varNamePtr, NULL, 0) != TCL_OK) { return TCL_ERROR; } @@ -3210,7 +3297,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) } name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); if (Tcl_StringMatch(name, pattern) && - (Tcl_UnsetVar2(interp, varName, name, 0) + (TclObjUnsetVar2(interp, varNamePtr, name, 0) != TCL_OK)) { return TCL_ERROR; } @@ -3254,26 +3341,26 @@ TclArraySet(interp, arrayNameObj, arrayElemObj) { Var *varPtr, *arrayPtr; Tcl_Obj **elemPtrs; - int result, elemLen, i; + int result, elemLen, i, nameLen; char *varName, *p; - varName = TclGetString(arrayNameObj); - for (p = varName; *p ; p++) { - if (*p == '(') { - do { - p++; - } while (*p != '\0'); - p--; - if (*p == ')') { + varName = Tcl_GetStringFromObj(arrayNameObj, &nameLen); + p = varName + nameLen - 1; + if (*p == ')') { + while (--p >= varName) { + if (*p == '(') { VarErrMsg(interp, varName, NULL, "set", needArray); return TCL_ERROR; } - break; } } - varPtr = TclLookupVar(interp, varName, (char *) NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); + varPtr = TclObjLookupVar(interp, arrayNameObj, NULL, + /*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "set", /*createPart1*/ 1, + /*createPart2*/ 0, &arrayPtr); + if (varPtr == NULL) { + return TCL_ERROR; + } if (arrayElemObj != NULL) { result = Tcl_ListObjGetElements(interp, arrayElemObj, @@ -3288,9 +3375,19 @@ TclArraySet(interp, arrayNameObj, arrayElemObj) return TCL_ERROR; } if (elemLen > 0) { + /* + * We needn't worry about traces invalidating arrayPtr: + * should that be the case, TclPtrSetVar will return NULL + * so that we break out of the loop and return an error. + */ + for (i = 0; i < elemLen; i += 2) { - if (Tcl_ObjSetVar2(interp, arrayNameObj, elemPtrs[i], - elemPtrs[i+1], TCL_LEAVE_ERR_MSG) == NULL) { + char *part2 = TclGetString(elemPtrs[i]); + Var *elemVarPtr = TclLookupArrayElement(interp, varName, + part2, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr); + if ((elemVarPtr == NULL) || + (TclPtrSetVar(interp, elemVarPtr, varPtr, varName, + part2, elemPtrs[i+1], TCL_LEAVE_ERR_MSG) == NULL)) { result = TCL_ERROR; break; } @@ -3320,22 +3417,6 @@ TclArraySet(interp, arrayNameObj, arrayElemObj) VarErrMsg(interp, varName, (char *)NULL, "array set", needArray); return TCL_ERROR; } - } else { - /* - * Create variable for new array. - */ - - varPtr = TclLookupVar(interp, varName, (char *) NULL, - TCL_LEAVE_ERR_MSG, "set", - /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr); - - /* - * Still couldn't do it - this can occur if a non-existent - * namespace was specified - */ - if (varPtr == NULL) { - return TCL_ERROR; - } } TclSetVarArray(varPtr); TclClearVarUndefined(varPtr); @@ -3348,7 +3429,7 @@ TclArraySet(interp, arrayNameObj, arrayElemObj) /* *---------------------------------------------------------------------- * - * MakeUpvar -- + * ObjMakeUpvar -- * * This procedure does all of the work of the "global" and "upvar" * commands. @@ -3366,158 +3447,101 @@ TclArraySet(interp, arrayNameObj, arrayElemObj) */ static int -MakeUpvar(iPtr, framePtr, otherP1, otherP2, otherFlags, myName, myFlags) - Interp *iPtr; /* Interpreter containing variables. Used - * for error messages, too. */ +ObjMakeUpvar(interp, framePtr, otherP1Ptr, otherP2, otherFlags, myName, myFlags, index) + Tcl_Interp *interp; /* Interpreter containing variables. Used + * for error messages, too. */ CallFrame *framePtr; /* Call frame containing "other" variable. * NULL means use global :: context. */ - char *otherP1, *otherP2; /* Two-part name of variable in framePtr. */ - int otherFlags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: + Tcl_Obj *otherP1Ptr; + CONST char *otherP2; /* Two-part name of variable in framePtr. */ + CONST int otherFlags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: * indicates scope of "other" variable. */ - char *myName; /* Name of variable which will refer to + CONST char *myName; /* Name of variable which will refer to * otherP1/otherP2. Must be a scalar. */ - int myFlags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: + CONST int myFlags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: * indicates scope of myName. */ + int index; /* If the variable to be linked is an indexed + * scalar, this is its index. Otherwise, -1. */ { - Tcl_HashEntry *hPtr; + Interp *iPtr = (Interp *) interp; Var *otherPtr, *varPtr, *arrayPtr; CallFrame *varFramePtr; - CallFrame *savedFramePtr = NULL; /* Init. to avoid compiler warning. */ - Tcl_HashTable *tablePtr; - Namespace *nsPtr, *altNsPtr, *dummyNsPtr; - char *tail; - int new; + CONST char *errMsg; /* * Find "other" in "framePtr". If not looking up other in just the * current namespace, temporarily replace the current var frame - * pointer in the interpreter in order to use TclLookupVar. + * pointer in the interpreter in order to use TclObjLookupVar. */ + varFramePtr = iPtr->varFramePtr; if (!(otherFlags & TCL_NAMESPACE_ONLY)) { - savedFramePtr = iPtr->varFramePtr; iPtr->varFramePtr = framePtr; } - otherPtr = TclLookupVar((Tcl_Interp *) iPtr, otherP1, otherP2, + otherPtr = TclObjLookupVar(interp, otherP1Ptr, otherP2, (otherFlags | TCL_LEAVE_ERR_MSG), "access", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); if (!(otherFlags & TCL_NAMESPACE_ONLY)) { - iPtr->varFramePtr = savedFramePtr; + iPtr->varFramePtr = varFramePtr; } if (otherPtr == NULL) { return TCL_ERROR; } - /* - * Now create a hashtable entry for "myName". Create it as either a - * namespace variable or as a local variable in a procedure call - * frame. Interpret myName as a namespace variable if: - * 1) so requested by a TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY flag, - * 2) there is no active frame (we're at the global :: scope), - * 3) the active frame was pushed to define the namespace context - * for a "namespace eval" or "namespace inscope" command, - * 4) the name has namespace qualifiers ("::"s). - * If creating myName in the active procedure, look first in the - * frame's array of compiler-allocated local variables, then in its - * hashtable for runtime-created local variables. Create that - * procedure's local variable hashtable if necessary. - */ - - varFramePtr = iPtr->varFramePtr; - if ((myFlags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) - || (varFramePtr == NULL) - || !varFramePtr->isProcCallFrame - || (strstr(myName, "::") != NULL)) { - TclGetNamespaceForQualName((Tcl_Interp *) iPtr, myName, - (Namespace *) NULL, myFlags, &nsPtr, &altNsPtr, &dummyNsPtr, &tail); - - if (nsPtr == NULL) { - nsPtr = altNsPtr; - } - if (nsPtr == NULL) { - Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"", - myName, "\": unknown namespace", (char *) NULL); - return TCL_ERROR; - } - + if (index >= 0) { + if (!varFramePtr->isProcCallFrame) { + panic("ObjMakeUpVar called with an index outside from a proc.\n"); + } + varPtr = &(varFramePtr->compiledLocals[index]); + } else { /* * Check that we are not trying to create a namespace var linked to * a local variable in a procedure. If we allowed this, the local * variable in the shorter-lived procedure frame could go away * leaving the namespace var's reference invalid. */ - - if ((otherP2 ? arrayPtr->nsPtr : otherPtr->nsPtr) == NULL) { + + if (((otherP2 ? arrayPtr->nsPtr : otherPtr->nsPtr) == NULL) + && ((myFlags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) + || (varFramePtr == NULL) + || !varFramePtr->isProcCallFrame + || (strstr(myName, "::") != NULL))) { Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"", - myName, "\": upvar won't create namespace variable that refers to procedure variable", - (char *) NULL); - return TCL_ERROR; - } + myName, "\": upvar won't create namespace variable that ", + "refers to procedure variable", (char *) NULL); + return TCL_ERROR; + } - hPtr = Tcl_CreateHashEntry(&nsPtr->varTable, tail, &new); - if (new) { - varPtr = NewVar(); - Tcl_SetHashValue(hPtr, varPtr); - varPtr->hPtr = hPtr; - varPtr->nsPtr = nsPtr; - } else { - varPtr = (Var *) Tcl_GetHashValue(hPtr); + /* + * Lookup and eventually create the new variable. + */ + + varPtr = TclLookupSimpleVar(interp, myName, myFlags, /*create*/ 1, + &errMsg, &index); + if (varPtr == NULL) { + VarErrMsg(interp, myName, NULL, "create", errMsg); + return TCL_ERROR; } - } else { /* look in the call frame */ - Proc *procPtr = varFramePtr->procPtr; - int localCt = procPtr->numCompiledLocals; - CompiledLocal *localPtr = procPtr->firstLocalPtr; - Var *localVarPtr = varFramePtr->compiledLocals; - int nameLen = strlen(myName); - int i; + } - varPtr = NULL; - for (i = 0; i < localCt; i++) { - if (!TclIsVarTemporary(localPtr)) { - char *localName = localVarPtr->name; - if ((myName[0] == localName[0]) - && (nameLen == localPtr->nameLength) - && (strcmp(myName, localName) == 0)) { - varPtr = localVarPtr; - new = 0; - break; - } - } - localVarPtr++; - localPtr = localPtr->nextPtr; - } - if (varPtr == NULL) { /* look in frame's local var hashtable */ - tablePtr = varFramePtr->varTablePtr; - if (tablePtr == NULL) { - tablePtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS); - varFramePtr->varTablePtr = tablePtr; - } - hPtr = Tcl_CreateHashEntry(tablePtr, myName, &new); - if (new) { - varPtr = NewVar(); - Tcl_SetHashValue(hPtr, varPtr); - varPtr->hPtr = hPtr; - varPtr->nsPtr = varFramePtr->nsPtr; - } else { - varPtr = (Var *) Tcl_GetHashValue(hPtr); - } - } + if (varPtr == otherPtr) { + Tcl_SetResult((Tcl_Interp *) iPtr, + "can't upvar from variable to itself", TCL_STATIC); + return TCL_ERROR; } - if (!new) { + if (varPtr->tracePtr != NULL) { + Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName, + "\" has traces: can't use for upvar", (char *) NULL); + return TCL_ERROR; + } else if (!TclIsVarUndefined(varPtr)) { /* - * The variable already exists. Make sure this variable "varPtr" + * The variable already existed. Make sure this variable "varPtr" * isn't the same as "otherPtr" (avoid circular links). Also, if * it's not an upvar then it's an error. If it is an upvar, then * just disconnect it from the thing it currently refers to. */ - if (varPtr == otherPtr) { - Tcl_SetResult((Tcl_Interp *) iPtr, - "can't upvar from variable to itself", TCL_STATIC); - return TCL_ERROR; - } if (TclIsVarLink(varPtr)) { Var *linkPtr = varPtr->value.linkPtr; if (linkPtr == otherPtr) { @@ -3527,14 +3551,10 @@ MakeUpvar(iPtr, framePtr, otherP1, otherP2, otherFlags, myName, myFlags) if (TclIsVarUndefined(linkPtr)) { CleanupVar(linkPtr, (Var *) NULL); } - } else if (!TclIsVarUndefined(varPtr)) { + } else { Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName, "\" already exists", (char *) NULL); return TCL_ERROR; - } else if (varPtr->tracePtr != NULL) { - Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName, - "\" has traces: can't use for upvar", (char *) NULL); - return TCL_ERROR; } } TclSetVarLink(varPtr); @@ -3569,52 +3589,16 @@ int Tcl_UpVar(interp, frameName, varName, localName, flags) Tcl_Interp *interp; /* Command interpreter in which varName is * to be looked up. */ - char *frameName; /* Name of the frame containing the source + CONST char *frameName; /* Name of the frame containing the source * variable, such as "1" or "#0". */ - char *varName; /* Name of a variable in interp to link to. + CONST char *varName; /* Name of a variable in interp to link to. * May be either a scalar name or an * element in an array. */ - char *localName; /* Name of link variable. */ + CONST char *localName; /* Name of link variable. */ int flags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: * indicates scope of localName. */ { - int result; - CallFrame *framePtr; - register char *p; - - result = TclGetFrame(interp, frameName, &framePtr); - if (result == -1) { - return TCL_ERROR; - } - - /* - * Figure out whether varName is an array reference, then call - * MakeUpvar to do all the real work. - */ - - for (p = varName; *p != '\0'; p++) { - if (*p == '(') { - char *openParen = p; - do { - p++; - } while (*p != '\0'); - p--; - if (*p != ')') { - goto scalar; - } - *openParen = '\0'; - *p = '\0'; - result = MakeUpvar((Interp *) interp, framePtr, varName, - openParen+1, 0, localName, flags); - *openParen = '('; - *p = ')'; - return result; - } - } - - scalar: - return MakeUpvar((Interp *) interp, framePtr, varName, (char *) NULL, - 0, localName, flags); + return Tcl_UpVar2(interp, frameName, varName, NULL, localName, flags); } /* @@ -3642,23 +3626,30 @@ int Tcl_UpVar2(interp, frameName, part1, part2, localName, flags) Tcl_Interp *interp; /* Interpreter containing variables. Used * for error messages too. */ - char *frameName; /* Name of the frame containing the source + CONST char *frameName; /* Name of the frame containing the source * variable, such as "1" or "#0". */ - char *part1, *part2; /* Two parts of source variable name to + CONST char *part1; + CONST char *part2; /* Two parts of source variable name to * link to. */ - char *localName; /* Name of link variable. */ + CONST char *localName; /* Name of link variable. */ int flags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: * indicates scope of localName. */ { int result; CallFrame *framePtr; + Tcl_Obj *part1Ptr; - result = TclGetFrame(interp, frameName, &framePtr); - if (result == -1) { + if (TclGetFrame(interp, frameName, &framePtr) == -1) { return TCL_ERROR; } - return MakeUpvar((Interp *) interp, framePtr, part1, part2, 0, - localName, flags); + + part1Ptr = Tcl_NewStringObj(part1, -1); + Tcl_IncrRefCount(part1Ptr); + result = ObjMakeUpvar(interp, framePtr, part1Ptr, part2, 0, + localName, flags, -1); + TclDecrRefCount(part1Ptr); + + return result; } /* @@ -3779,7 +3770,7 @@ Tcl_GlobalObjCmd(dummy, interp, objc, objv) while ((tail > varName) && ((*tail != ':') || (*(tail-1) != ':'))) { tail--; } - if (*tail == ':') { + if ((*tail == ':') && (tail > varName)) { tail++; } @@ -3787,9 +3778,9 @@ Tcl_GlobalObjCmd(dummy, interp, objc, objv) * Link to the variable "varName" in the global :: namespace. */ - result = MakeUpvar(iPtr, (CallFrame *) NULL, - varName, (char *) NULL, /*otherFlags*/ TCL_GLOBAL_ONLY, - /*myName*/ tail, /*myFlags*/ 0); + result = ObjMakeUpvar(interp, (CallFrame *) NULL, + objPtr, NULL, /*otherFlags*/ TCL_GLOBAL_ONLY, + /*myName*/ tail, /*myFlags*/ 0, -1); if (result != TCL_OK) { return result; } @@ -3844,6 +3835,12 @@ Tcl_VariableObjCmd(dummy, interp, objc, objv) Var *varPtr, *arrayPtr; Tcl_Obj *varValuePtr; int i, result; + Tcl_Obj *varNamePtr; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?name value...? name ?value?"); + return TCL_ERROR; + } for (i = 1; i < objc; i = i+2) { /* @@ -3851,8 +3848,9 @@ Tcl_VariableObjCmd(dummy, interp, objc, objv) * it if necessary. */ - varName = TclGetString(objv[i]); - varPtr = TclLookupVar(interp, varName, (char *) NULL, + varNamePtr = objv[i]; + varName = TclGetString(varNamePtr); + varPtr = TclObjLookupVar(interp, varNamePtr, NULL, (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "define", /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr); @@ -3889,8 +3887,8 @@ Tcl_VariableObjCmd(dummy, interp, objc, objv) */ if (i+1 < objc) { /* a value was specified */ - varValuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, objv[i+1], - (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG)); + varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, varName, NULL, + objv[i+1], (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG)); if (varValuePtr == NULL) { return TCL_ERROR; } @@ -3924,10 +3922,10 @@ Tcl_VariableObjCmd(dummy, interp, objc, objv) * current namespace. */ - result = MakeUpvar(iPtr, (CallFrame *) NULL, - /*otherP1*/ varName, /*otherP2*/ (char *) NULL, + result = ObjMakeUpvar(interp, (CallFrame *) NULL, + /*otherP1*/ varNamePtr, /*otherP2*/ NULL, /*otherFlags*/ TCL_NAMESPACE_ONLY, - /*myName*/ tail, /*myFlags*/ 0); + /*myName*/ tail, /*myFlags*/ 0, -1); if (result != TCL_OK) { return result; } @@ -3961,10 +3959,8 @@ Tcl_UpvarObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - register Interp *iPtr = (Interp *) interp; CallFrame *framePtr; - char *frameSpec, *otherVarName, *myVarName; - register char *p; + char *frameSpec, *localName; int result; if (objc < 3) { @@ -3997,34 +3993,9 @@ Tcl_UpvarObjCmd(dummy, interp, objc, objv) */ for ( ; objc > 0; objc -= 2, objv += 2) { - myVarName = TclGetString(objv[1]); - otherVarName = TclGetString(objv[0]); - for (p = otherVarName; *p != 0; p++) { - if (*p == '(') { - char *openParen = p; - - do { - p++; - } while (*p != '\0'); - p--; - if (*p != ')') { - goto scalar; - } - *openParen = '\0'; - *p = '\0'; - result = MakeUpvar(iPtr, framePtr, - otherVarName, openParen+1, /*otherFlags*/ 0, - myVarName, /*flags*/ 0); - *openParen = '('; - *p = ')'; - goto checkResult; - } - } - scalar: - result = MakeUpvar(iPtr, framePtr, otherVarName, (char *) NULL, 0, - myVarName, /*flags*/ 0); - - checkResult: + localName = TclGetString(objv[1]); + result = ObjMakeUpvar(interp, framePtr, /* othervarName */ objv[0], + NULL, 0, /* myVarName */ localName, /*flags*/ 0, -1); if (result != TCL_OK) { return TCL_ERROR; } @@ -4035,7 +4006,39 @@ Tcl_UpvarObjCmd(dummy, interp, objc, objv) /* *---------------------------------------------------------------------- * - * CallTraces -- + * DisposeTraceResult-- + * + * This procedure is called to dispose of the result returned from + * a trace procedure. The disposal method appropriate to the type + * of result is determined by flags. + * + * Results: + * None. + * + * Side effects: + * The memory allocated for the trace result may be freed. + * + *---------------------------------------------------------------------- + */ + +void +DisposeTraceResult(flags, result) + int flags; /* Indicates type of result to determine + * proper disposal method */ + char *result; /* The result returned from a trace + * procedure to be disposed */ +{ + if (flags & TCL_TRACE_RESULT_DYNAMIC) { + ckfree(result); + } else if (flags & TCL_TRACE_RESULT_OBJECT) { + Tcl_DecrRefCount((Tcl_Obj *) result); + } +} + +/* + *---------------------------------------------------------------------- + * + * CallVarTraces -- * * This procedure is invoked to find and invoke relevant * trace procedures associated with a particular operation on @@ -4043,12 +4046,11 @@ Tcl_UpvarObjCmd(dummy, interp, objc, objv) * variable and on its containing array (where relevant). * * Results: - * The return value is NULL if no trace procedures were invoked, or - * if all the invoked trace procedures returned successfully. - * The return value is non-NULL if a trace procedure returned an - * error (in this case no more trace procedures were invoked after - * the error was returned). In this case the return value is a - * pointer to a static string describing the error. + * Returns TCL_OK to indicate normal operation. Returns TCL_ERROR + * if invocation of a trace procedure indicated an error. When + * TCL_ERROR is returned and leaveErrMsg is true, then the + * ::errorInfo variable of iPtr has information about the error + * appended to it. * * Side effects: * Almost anything can happen, depending on trace; this procedure @@ -4057,26 +4059,33 @@ Tcl_UpvarObjCmd(dummy, interp, objc, objv) *---------------------------------------------------------------------- */ -static char * -CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) +int +CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg) Interp *iPtr; /* Interpreter containing variable. */ register Var *arrayPtr; /* Pointer to array variable that contains * the variable, or NULL if the variable * isn't an element of an array. */ Var *varPtr; /* Variable whose traces are to be * invoked. */ - char *part1, *part2; /* Variable's two-part name. */ + CONST char *part1; + CONST char *part2; /* Variable's two-part name. */ int flags; /* Flags passed to trace procedures: * indicates what's happening to variable, * plus other stuff like TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY, and * TCL_INTERP_DESTROYED. */ + CONST int leaveErrMsg; /* If true, and one of the traces indicates an + * error, then leave an error message and stack + * trace information in *iPTr. */ { register VarTrace *tracePtr; ActiveVarTrace active; - char *result, *openParen, *p; + char *result; + CONST char *openParen, *p; Tcl_DString nameCopy; int copiedName; + int code = TCL_OK; + int disposeFlags = 0; /* * If there are already similar trace procedures active for the @@ -4084,10 +4093,13 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) */ if (varPtr->flags & VAR_TRACE_ACTIVE) { - return NULL; + return code; } varPtr->flags |= VAR_TRACE_ACTIVE; varPtr->refCount++; + if (arrayPtr != NULL) { + arrayPtr->refCount++; + } /* * If the variable name hasn't been parsed into array name and @@ -4108,12 +4120,14 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) } while (*p != '\0'); p--; if (*p == ')') { + int offset = (openParen - part1); + char *newPart1; Tcl_DStringInit(&nameCopy); Tcl_DStringAppend(&nameCopy, part1, (p-part1)); - part2 = Tcl_DStringValue(&nameCopy) - + (openParen + 1 - part1); - part2[-1] = 0; - part1 = Tcl_DStringValue(&nameCopy); + newPart1 = Tcl_DStringValue(&nameCopy); + newPart1[offset] = 0; + part1 = newPart1; + part2 = newPart1 + offset + 1; copiedName = 1; } break; @@ -4126,10 +4140,10 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) */ result = NULL; - active.nextPtr = iPtr->activeTracePtr; - iPtr->activeTracePtr = &active; - if (arrayPtr != NULL) { - arrayPtr->refCount++; + active.nextPtr = iPtr->activeVarTracePtr; + iPtr->activeVarTracePtr = &active; + Tcl_Preserve((ClientData) iPtr); + if (arrayPtr != NULL && !(arrayPtr->flags & VAR_TRACE_ACTIVE)) { active.varPtr = arrayPtr; for (tracePtr = arrayPtr->tracePtr; tracePtr != NULL; tracePtr = active.nextTracePtr) { @@ -4137,15 +4151,22 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) if (!(tracePtr->flags & flags)) { continue; } + Tcl_Preserve((ClientData) tracePtr); result = (*tracePtr->traceProc)(tracePtr->clientData, (Tcl_Interp *) iPtr, part1, part2, flags); if (result != NULL) { if (flags & TCL_TRACE_UNSETS) { - result = NULL; + /* Ignore errors in unset traces */ + DisposeTraceResult(tracePtr->flags, result); } else { - goto done; + disposeFlags = tracePtr->flags; + code = TCL_ERROR; } } + Tcl_Release((ClientData) tracePtr); + if (code == TCL_ERROR) { + goto done; + } } } @@ -4163,15 +4184,22 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) if (!(tracePtr->flags & flags)) { continue; } + Tcl_Preserve((ClientData) tracePtr); result = (*tracePtr->traceProc)(tracePtr->clientData, (Tcl_Interp *) iPtr, part1, part2, flags); if (result != NULL) { if (flags & TCL_TRACE_UNSETS) { - result = NULL; + /* Ignore errors in unset traces */ + DisposeTraceResult(tracePtr->flags, result); } else { - goto done; + disposeFlags = tracePtr->flags; + code = TCL_ERROR; } } + Tcl_Release((ClientData) tracePtr); + if (code == TCL_ERROR) { + goto done; + } } /* @@ -4180,6 +4208,33 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) */ done: + if (code == TCL_ERROR) { + if (leaveErrMsg) { + CONST char *type = ""; + switch (flags&(TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_ARRAY)) { + case TCL_TRACE_READS: { + type = "read"; + break; + } + case TCL_TRACE_WRITES: { + type = "set"; + break; + } + case TCL_TRACE_ARRAY: { + type = "trace array"; + break; + } + } + if (disposeFlags & TCL_TRACE_RESULT_OBJECT) { + VarErrMsg((Tcl_Interp *) iPtr, part1, part2, type, + Tcl_GetString((Tcl_Obj *) result)); + } else { + VarErrMsg((Tcl_Interp *) iPtr, part1, part2, type, result); + } + } + DisposeTraceResult(disposeFlags,result); + } + if (arrayPtr != NULL) { arrayPtr->refCount--; } @@ -4188,8 +4243,9 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) } varPtr->flags &= ~VAR_TRACE_ACTIVE; varPtr->refCount--; - iPtr->activeTracePtr = active.nextPtr; - return result; + iPtr->activeVarTracePtr = active.nextPtr; + Tcl_Release((ClientData) iPtr); + return code; } /* @@ -4233,9 +4289,75 @@ NewVar() /* *---------------------------------------------------------------------- * + * 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(interp, objPtr) + Tcl_Interp *interp; + Tcl_Obj *objPtr; +{ + char *string; + char *end; + int id; + size_t offset; + + /* + * Get the string representation. Make it up-to-date if necessary. + */ + + string = Tcl_GetString(objPtr); + + /* + * Parse the id into the three parts separated by dashes. + */ + if ((string[0] != 's') || (string[1] != '-')) { + syntax: + Tcl_AppendResult(interp, "illegal search identifier \"", string, + "\"", (char *) NULL); + return TCL_ERROR; + } + 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; + + if (objPtr->typePtr != NULL && objPtr->typePtr->freeIntRepProc != NULL) { + objPtr->typePtr->freeIntRepProc(objPtr); + } + objPtr->typePtr = &tclArraySearchType; + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *)(((char *)NULL)+id); + objPtr->internalRep.twoPtrValue.ptr2 = (VOID *)(((char *)NULL)+offset); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * ParseSearchId -- * - * This procedure translates from a string to a pointer to an + * This procedure translates from a tcl object to a pointer to an * active array search (if there is one that matches the string). * * Results: @@ -4244,41 +4366,47 @@ NewVar() * the interp's result contains an error message. * * Side effects: - * None. + * The tcl object might have its internal type and representation + * modified. * *---------------------------------------------------------------------- */ static ArraySearch * -ParseSearchId(interp, varPtr, varName, string) +ParseSearchId(interp, varPtr, varName, handleObj) Tcl_Interp *interp; /* Interpreter containing variable. */ - Var *varPtr; /* Array variable search is for. */ - char *varName; /* Name of array variable that search is + CONST Var *varPtr; /* Array variable search is for. */ + CONST char *varName; /* Name of array variable that search is * supposed to be for. */ - char *string; /* String containing id of search. Must have + Tcl_Obj *handleObj; /* Object containing id of search. Must have * form "search-num-var" where "num" is a * decimal number and "var" is a variable * name. */ { - char *end; + register char *string; + register size_t offset; int id; ArraySearch *searchPtr; /* - * Parse the id into the three parts separated by dashes. + * Parse the id. */ - - if ((string[0] != 's') || (string[1] != '-')) { - syntax: - Tcl_AppendResult(interp, "illegal search identifier \"", string, - "\"", (char *) NULL); + if (Tcl_ConvertToType(interp, handleObj, &tclArraySearchType) != TCL_OK) { return NULL; } - id = strtoul(string+2, &end, 10); - if ((end == (string+2)) || (*end != '-')) { - goto syntax; - } - if (strcmp(end+1, varName) != 0) { + /* + * Cast is safe, since always came from an int in the first place. + */ + id = (int)(((char*)handleObj->internalRep.twoPtrValue.ptr1) - + ((char*)NULL)); + string = Tcl_GetString(handleObj); + offset = (((char*)handleObj->internalRep.twoPtrValue.ptr2) - + ((char*)NULL)); + /* + * 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_AppendResult(interp, "search identifier \"", string, "\" isn't for variable \"", varName, "\"", (char *) NULL); return NULL; @@ -4287,6 +4415,10 @@ ParseSearchId(interp, varPtr, varName, string) /* * 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. */ for (searchPtr = varPtr->searchPtr; searchPtr != NULL; @@ -4374,10 +4506,13 @@ TclDeleteVars(iPtr, tablePtr) flags = TCL_TRACE_UNSETS; if (tablePtr == &iPtr->globalNsPtr->varTable) { - flags |= (TCL_INTERP_DESTROYED | TCL_GLOBAL_ONLY); + flags |= TCL_GLOBAL_ONLY; } else if (tablePtr == &currNsPtr->varTable) { flags |= TCL_NAMESPACE_ONLY; } + if (Tcl_InterpDeleted(interp)) { + flags |= TCL_INTERP_DESTROYED; + } for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { @@ -4411,7 +4546,7 @@ TclDeleteVars(iPtr, tablePtr) * free up the variable's space (no need to free the hash entry * here, unless we're dealing with a global variable: the * hash entries will be deleted automatically when the whole - * table is deleted). Note that we give CallTraces the variable's + * table is deleted). Note that we give CallVarTraces the variable's * fully-qualified name so that any called trace procedures can * refer to these variables being deleted. */ @@ -4420,16 +4555,16 @@ TclDeleteVars(iPtr, tablePtr) objPtr = Tcl_NewObj(); Tcl_IncrRefCount(objPtr); /* until done with traces */ Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr); - (void) CallTraces(iPtr, (Var *) NULL, varPtr, - Tcl_GetString(objPtr), (char *) NULL, flags); + CallVarTraces(iPtr, (Var *) NULL, varPtr, Tcl_GetString(objPtr), + NULL, flags, /* leaveErrMsg */ 0); Tcl_DecrRefCount(objPtr); /* free no longer needed obj */ while (varPtr->tracePtr != NULL) { VarTrace *tracePtr = varPtr->tracePtr; varPtr->tracePtr = tracePtr->nextPtr; - ckfree((char *) tracePtr); + Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); } - for (activePtr = iPtr->activeTracePtr; activePtr != NULL; + for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; activePtr = activePtr->nextPtr) { if (activePtr->varPtr == varPtr) { activePtr->nextTracePtr = NULL; @@ -4546,14 +4681,14 @@ TclDeleteCompiledLocalVars(iPtr, framePtr) */ if (varPtr->tracePtr != NULL) { - (void) CallTraces(iPtr, (Var *) NULL, varPtr, - varPtr->name, (char *) NULL, flags); + CallVarTraces(iPtr, (Var *) NULL, varPtr, varPtr->name, NULL, + flags, /* leaveErrMsg */ 0); while (varPtr->tracePtr != NULL) { VarTrace *tracePtr = varPtr->tracePtr; varPtr->tracePtr = tracePtr->nextPtr; - ckfree((char *) tracePtr); + Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); } - for (activePtr = iPtr->activeTracePtr; activePtr != NULL; + for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; activePtr = activePtr->nextPtr) { if (activePtr->varPtr == varPtr) { activePtr->nextTracePtr = NULL; @@ -4607,10 +4742,10 @@ TclDeleteCompiledLocalVars(iPtr, framePtr) static void DeleteArray(iPtr, arrayName, varPtr, flags) Interp *iPtr; /* Interpreter containing array. */ - char *arrayName; /* Name of array (used for trace + CONST char *arrayName; /* Name of array (used for trace * callbacks). */ Var *varPtr; /* Pointer to variable structure. */ - int flags; /* Flags to pass to CallTraces: + int flags; /* Flags to pass to CallVarTraces: * TCL_TRACE_UNSETS and sometimes * TCL_INTERP_DESTROYED, * TCL_NAMESPACE_ONLY, or @@ -4634,14 +4769,15 @@ DeleteArray(iPtr, arrayName, varPtr, flags) elPtr->hPtr = NULL; if (elPtr->tracePtr != NULL) { elPtr->flags &= ~VAR_TRACE_ACTIVE; - (void) CallTraces(iPtr, (Var *) NULL, elPtr, arrayName, - Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), flags); + CallVarTraces(iPtr, (Var *) NULL, elPtr, arrayName, + Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), flags, + /* leaveErrMsg */ 0); while (elPtr->tracePtr != NULL) { VarTrace *tracePtr = elPtr->tracePtr; elPtr->tracePtr = tracePtr->nextPtr; - ckfree((char *) tracePtr); + Tcl_EventuallyFree((ClientData) tracePtr,TCL_DYNAMIC); } - for (activePtr = iPtr->activeTracePtr; activePtr != NULL; + for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; activePtr = activePtr->nextPtr) { if (activePtr->varPtr == elPtr) { activePtr->nextTracePtr = NULL; @@ -4650,6 +4786,19 @@ DeleteArray(iPtr, arrayName, varPtr, flags) } TclSetVarUndefined(elPtr); TclSetVarScalar(elPtr); + + /* + * Even though array elements are not supposed to be namespace + * variables, some combinations of [upvar] and [variable] may + * create such beasts - see [Bug 604239]. This is necessary to + * avoid leaking the corresponding Var struct, and is otherwise + * harmless. + */ + + if (elPtr->flags & VAR_NAMESPACE_VAR) { + elPtr->flags &= ~VAR_NAMESPACE_VAR; + elPtr->refCount--; + } if (elPtr->refCount == 0) { ckfree((char *) elPtr); /* element Vars are VAR_IN_HASHTABLE */ } @@ -4729,10 +4878,11 @@ CleanupVar(varPtr, arrayPtr) static void VarErrMsg(interp, part1, part2, operation, reason) Tcl_Interp *interp; /* Interpreter in which to record message. */ - char *part1, *part2; /* Variable's two-part name. */ - char *operation; /* String describing operation that failed, + CONST char *part1; + CONST char *part2; /* Variable's two-part name. */ + CONST char *operation; /* String describing operation that failed, * e.g. "read", "set", or "unset". */ - char *reason; /* String describing why operation failed. */ + CONST char *reason; /* String describing why operation failed. */ { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "can't ", operation, " \"", part1, @@ -4742,7 +4892,6 @@ VarErrMsg(interp, part1, part2, operation, reason) } Tcl_AppendResult(interp, "\": ", reason, (char *) NULL); } - /* *---------------------------------------------------------------------- @@ -4765,11 +4914,10 @@ VarErrMsg(interp, part1, part2, operation, reason) Var * TclVarTraceExists(interp, varName) Tcl_Interp *interp; /* The interpreter */ - char *varName; /* The variable name */ + CONST char *varName; /* The variable name */ { Var *varPtr; Var *arrayPtr; - char *msg; /* * The choice of "create" flag values is delicate here, and @@ -4782,27 +4930,223 @@ TclVarTraceExists(interp, varName) */ varPtr = TclLookupVar(interp, varName, (char *) NULL, - 0, "access", - /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr); + 0, "access", /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr); + if (varPtr == NULL) { return NULL; } - if ((varPtr != NULL) && - ((varPtr->tracePtr != NULL) - || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL)))) { - msg = CallTraces((Interp *)interp, arrayPtr, varPtr, varName, - (char *) NULL, TCL_TRACE_READS); - if (msg != NULL) { - /* - * If the variable doesn't exist anymore and no-one's using - * it, then free up the relevant structures and hash table entries. - */ - if (TclIsVarUndefined(varPtr)) { - CleanupVar(varPtr, arrayPtr); + if ((varPtr->tracePtr != NULL) + || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { + CallVarTraces((Interp *)interp, arrayPtr, varPtr, varName, NULL, + TCL_TRACE_READS, /* leaveErrMsg */ 0); + } + + /* + * If the variable doesn't exist anymore and no-one's using + * it, then free up the relevant structures and hash table entries. + */ + + if (TclIsVarUndefined(varPtr)) { + CleanupVar(varPtr, arrayPtr); + return NULL; + } + + return varPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Internal functions for variable name object types -- + * + *---------------------------------------------------------------------- + */ + +/* + * localVarName - + * + * INTERNALREP DEFINITION: + * twoPtrValue.ptr1 = pointer to the corresponding Proc + * twoPtrValue.ptr2 = index into locals table +*/ + +static void +FreeLocalVarName(objPtr) + Tcl_Obj *objPtr; +{ + register Proc *procPtr = (Proc *) objPtr->internalRep.twoPtrValue.ptr1; + procPtr->refCount--; + if (procPtr->refCount <= 0) { + TclProcCleanupProc(procPtr); + } +} + +static void +DupLocalVarName(srcPtr, dupPtr) + Tcl_Obj *srcPtr; + Tcl_Obj *dupPtr; +{ + register Proc *procPtr = (Proc *) srcPtr->internalRep.twoPtrValue.ptr1; + + dupPtr->internalRep.twoPtrValue.ptr1 = (VOID *) procPtr; + dupPtr->internalRep.twoPtrValue.ptr2 = srcPtr->internalRep.twoPtrValue.ptr2; + procPtr->refCount++; + dupPtr->typePtr = &tclLocalVarNameType; +} + +static void +UpdateLocalVarName(objPtr) + Tcl_Obj *objPtr; +{ + Proc *procPtr = (Proc *) objPtr->internalRep.twoPtrValue.ptr1; + unsigned int index = (unsigned int) objPtr->internalRep.twoPtrValue.ptr2; + CompiledLocal *localPtr = procPtr->firstLocalPtr; + unsigned int nameLen; + + if (localPtr == NULL) { + goto emptyName; + } + while (index--) { + localPtr = localPtr->nextPtr; + if (localPtr == NULL) { + goto emptyName; + } + } + + nameLen = (unsigned int) localPtr->nameLength; + objPtr->bytes = ckalloc(nameLen + 1); + memcpy(objPtr->bytes, localPtr->name, nameLen + 1); + objPtr->length = nameLen; + return; + + emptyName: + objPtr->bytes = ckalloc(1); + *(objPtr->bytes) = '\0'; + objPtr->length = 0; +} + +/* + * nsVarName - + * + * INTERNALREP DEFINITION: + * twoPtrValue.ptr1: pointer to the namespace containing the + * reference. + * twoPtrValue.ptr2: pointer to the corresponding Var +*/ + +static void +FreeNsVarName(objPtr) + Tcl_Obj *objPtr; +{ + register Var *varPtr = (Var *) objPtr->internalRep.twoPtrValue.ptr2; + + varPtr->refCount--; + if (TclIsVarUndefined(varPtr) && (varPtr->refCount <= 0)) { + if (TclIsVarLink(varPtr)) { + Var *linkPtr = varPtr->value.linkPtr; + linkPtr->refCount--; + if (TclIsVarUndefined(linkPtr) && (linkPtr->refCount <= 0)) { + CleanupVar(linkPtr, (Var *) NULL); } - return NULL; } + CleanupVar(varPtr, NULL); } - return varPtr; +} + +static void +DupNsVarName(srcPtr, dupPtr) + Tcl_Obj *srcPtr; + Tcl_Obj *dupPtr; +{ + Namespace *nsPtr = (Namespace *) srcPtr->internalRep.twoPtrValue.ptr1; + register Var *varPtr = (Var *) srcPtr->internalRep.twoPtrValue.ptr2; + + dupPtr->internalRep.twoPtrValue.ptr1 = (VOID *) nsPtr; + dupPtr->internalRep.twoPtrValue.ptr2 = (VOID *) varPtr; + varPtr->refCount++; + dupPtr->typePtr = &tclNsVarNameType; +} + +/* + * parsedVarName - + * + * INTERNALREP DEFINITION: + * twoPtrValue.ptr1 = pointer to the array name Tcl_Obj + * (NULL if scalar) + * twoPtrValue.ptr2 = pointer to the element name string + * (owned by this Tcl_Obj), or NULL if + * it is a scalar variable + */ + +static void +FreeParsedVarName(objPtr) + Tcl_Obj *objPtr; +{ + register Tcl_Obj *arrayPtr = + (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr1; + register char *elem = (char *) objPtr->internalRep.twoPtrValue.ptr2; + + if (arrayPtr != NULL) { + TclDecrRefCount(arrayPtr); + ckfree(elem); + } +} + +static void +DupParsedVarName(srcPtr, dupPtr) + Tcl_Obj *srcPtr; + Tcl_Obj *dupPtr; +{ + register Tcl_Obj *arrayPtr = + (Tcl_Obj *) srcPtr->internalRep.twoPtrValue.ptr1; + register char *elem = (char *) srcPtr->internalRep.twoPtrValue.ptr2; + char *elemCopy; + unsigned int elemLen; + + if (arrayPtr != NULL) { + Tcl_IncrRefCount(arrayPtr); + elemLen = strlen(elem); + elemCopy = ckalloc(elemLen+1); + memcpy(elemCopy, elem, elemLen); + *(elemCopy + elemLen) = '\0'; + elem = elemCopy; + } + + dupPtr->internalRep.twoPtrValue.ptr1 = (VOID *) arrayPtr; + dupPtr->internalRep.twoPtrValue.ptr2 = (VOID *) elem; + dupPtr->typePtr = &tclParsedVarNameType; +} + +static void +UpdateParsedVarName(objPtr) + Tcl_Obj *objPtr; +{ + Tcl_Obj *arrayPtr = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr1; + char *part2 = (char *) objPtr->internalRep.twoPtrValue.ptr2; + char *part1, *p; + int len1, len2, totalLen; + + if (arrayPtr == NULL) { + /* + * This is a parsed scalar name: what is it + * doing here? + */ + panic("ERROR: scalar parsedVarName without a string rep.\n"); + } + part1 = Tcl_GetStringFromObj(arrayPtr, &len1); + len2 = strlen(part2); + + totalLen = len1 + len2 + 2; + p = ckalloc((unsigned int) totalLen + 1); + objPtr->bytes = p; + objPtr->length = totalLen; + + memcpy(p, part1, (unsigned int) len1); + p += len1; + *p++ = '('; + memcpy(p, part2, (unsigned int) len2); + p += len2; + *p++ = ')'; + *p = '\0'; } |