diff options
Diffstat (limited to 'generic')
124 files changed, 30394 insertions, 19040 deletions
diff --git a/generic/regc_color.c b/generic/regc_color.c index f5d6dfd..92e0aad 100644 --- a/generic/regc_color.c +++ b/generic/regc_color.c @@ -259,7 +259,7 @@ newcolor( return COLORLESS; /* too many colors */ } n = cm->ncds * 2; - if (n < MAX_COLOR + 1) { + if (n > MAX_COLOR + 1) { n = MAX_COLOR + 1; } if (cm->cd == cm->cdspace) { @@ -777,18 +777,19 @@ dumpcolors( } /* - * It's hard to do this more efficiently. + * Unfortunately, it's hard to do this next bit more efficiently. + * + * Spencer's original coding has the loop iterating from CHR_MIN + * to CHR_MAX, but that's utterly unusable for 32-bit chr, or + * even 16-bit. For debugging purposes it seems fine to print + * only chr codes up to 1000 or so. */ - for (c=CHR_MIN ; c<CHR_MAX ; c++) { + for (c=CHR_MIN ; c<1000 ; c++) { if (GETCOLOR(cm, c) == co) { dumpchr(c, f); } } - assert(c == CHR_MAX); - if (GETCOLOR(cm, c) == co) { - dumpchr(c, f); - } fprintf(f, "\n"); } } diff --git a/generic/regc_cvec.c b/generic/regc_cvec.c index 0247521..d450d3e 100644 --- a/generic/regc_cvec.c +++ b/generic/regc_cvec.c @@ -81,6 +81,7 @@ addchr( struct cvec *cv, /* character vector */ pchr c) /* character to add */ { + assert(cv->nchrs < cv->chrspace); cv->chrs[cv->nchrs++] = (chr)c; } diff --git a/generic/regc_lex.c b/generic/regc_lex.c index 132e757..4c8f15f 100644 --- a/generic/regc_lex.c +++ b/generic/regc_lex.c @@ -256,20 +256,33 @@ static const chr brbacks[] = { /* \s within brackets */ CHR('s'), CHR('p'), CHR('a'), CHR('c'), CHR('e'), CHR(':'), CHR(']') }; + +#define PUNCT_CONN \ + CHR('_'), \ + 0x203f /* UNDERTIE */, \ + 0x2040 /* CHARACTER TIE */,\ + 0x2054 /* INVERTED UNDERTIE */,\ + 0xfe33 /* PRESENTATION FORM FOR VERTICAL LOW LINE */, \ + 0xfe34 /* PRESENTATION FORM FOR VERTICAL WAVY LOW LINE */, \ + 0xfe4d /* DASHED LOW LINE */, \ + 0xfe4e /* CENTRELINE LOW LINE */, \ + 0xfe4f /* WAVY LOW LINE */, \ + 0xff3f /* FULLWIDTH LOW LINE */ + static const chr backw[] = { /* \w */ CHR('['), CHR('['), CHR(':'), CHR('a'), CHR('l'), CHR('n'), CHR('u'), CHR('m'), - CHR(':'), CHR(']'), CHR('_'), CHR(']') + CHR(':'), CHR(']'), PUNCT_CONN, CHR(']') }; static const chr backW[] = { /* \W */ CHR('['), CHR('^'), CHR('['), CHR(':'), CHR('a'), CHR('l'), CHR('n'), CHR('u'), CHR('m'), - CHR(':'), CHR(']'), CHR('_'), CHR(']') + CHR(':'), CHR(']'), PUNCT_CONN, CHR(']') }; static const chr brbackw[] = { /* \w within brackets */ CHR('['), CHR(':'), CHR('a'), CHR('l'), CHR('n'), CHR('u'), CHR('m'), - CHR(':'), CHR(']'), CHR('_') + CHR(':'), CHR(']'), PUNCT_CONN }; /* @@ -444,7 +457,7 @@ next( if (ATEOS()) { FAILW(REG_EESCAPE); } - (DISCARD)lexescape(v); + (void)lexescape(v); switch (v->nexttype) { /* not all escapes okay here */ case PLAIN: return 1; @@ -703,7 +716,7 @@ next( } RETV(PLAIN, *v->now++); } - (DISCARD)lexescape(v); + (void)lexescape(v); if (ISERR()) { FAILW(REG_EESCAPE); } @@ -1130,7 +1143,7 @@ skip( /* - newline - return the chr for a newline * This helps confine use of CHR to this source file. - ^ static chr newline(NOPARMS); + ^ static chr newline(void); */ static chr newline(void) @@ -1139,24 +1152,6 @@ newline(void) } /* - - ch - return the chr sequence for regc_locale.c's fake collating element ch - * This helps confine use of CHR to this source file. Beware that the caller - * knows how long the sequence is. - ^ #ifdef REG_DEBUG - ^ static const chr *ch(NOPARMS); - ^ #endif - */ -#ifdef REG_DEBUG -static const chr * -ch(void) -{ - static const chr chstr[] = { CHR('c'), CHR('h'), CHR('\0') }; - - return chstr; -} -#endif - -/* - chrnamed - return the chr known by a given (chr string) name * The code is a bit clumsy, but this routine gets only such specialized * use that it hardly matters. diff --git a/generic/regc_locale.c b/generic/regc_locale.c index e79dff8..002b264 100644 --- a/generic/regc_locale.c +++ b/generic/regc_locale.c @@ -118,7 +118,7 @@ static const struct cname { * Unicode character-class tables. */ -typedef struct crange { +typedef struct { chr start; chr end; } crange; @@ -137,118 +137,144 @@ static const crange alphaRangeTable[] = { {0x41, 0x5a}, {0x61, 0x7a}, {0xc0, 0xd6}, {0xd8, 0xf6}, {0xf8, 0x2c1}, {0x2c6, 0x2d1}, {0x2e0, 0x2e4}, {0x370, 0x374}, {0x37a, 0x37d}, {0x388, 0x38a}, {0x38e, 0x3a1}, {0x3a3, 0x3f5}, - {0x3f7, 0x481}, {0x48a, 0x527}, {0x531, 0x556}, {0x561, 0x587}, - {0x5d0, 0x5ea}, {0x5f0, 0x5f2}, {0x620, 0x64a}, {0x671, 0x6d3}, + {0x3f7, 0x481}, {0x48a, 0x52f}, {0x531, 0x556}, {0x560, 0x588}, + {0x5d0, 0x5ea}, {0x5ef, 0x5f2}, {0x620, 0x64a}, {0x671, 0x6d3}, {0x6fa, 0x6fc}, {0x712, 0x72f}, {0x74d, 0x7a5}, {0x7ca, 0x7ea}, - {0x800, 0x815}, {0x840, 0x858}, {0x8a2, 0x8ac}, {0x904, 0x939}, - {0x958, 0x961}, {0x971, 0x977}, {0x979, 0x97f}, {0x985, 0x98c}, - {0x993, 0x9a8}, {0x9aa, 0x9b0}, {0x9b6, 0x9b9}, {0x9df, 0x9e1}, - {0xa05, 0xa0a}, {0xa13, 0xa28}, {0xa2a, 0xa30}, {0xa59, 0xa5c}, - {0xa72, 0xa74}, {0xa85, 0xa8d}, {0xa8f, 0xa91}, {0xa93, 0xaa8}, - {0xaaa, 0xab0}, {0xab5, 0xab9}, {0xb05, 0xb0c}, {0xb13, 0xb28}, - {0xb2a, 0xb30}, {0xb35, 0xb39}, {0xb5f, 0xb61}, {0xb85, 0xb8a}, - {0xb8e, 0xb90}, {0xb92, 0xb95}, {0xba8, 0xbaa}, {0xbae, 0xbb9}, - {0xc05, 0xc0c}, {0xc0e, 0xc10}, {0xc12, 0xc28}, {0xc2a, 0xc33}, - {0xc35, 0xc39}, {0xc85, 0xc8c}, {0xc8e, 0xc90}, {0xc92, 0xca8}, - {0xcaa, 0xcb3}, {0xcb5, 0xcb9}, {0xd05, 0xd0c}, {0xd0e, 0xd10}, - {0xd12, 0xd3a}, {0xd7a, 0xd7f}, {0xd85, 0xd96}, {0xd9a, 0xdb1}, - {0xdb3, 0xdbb}, {0xdc0, 0xdc6}, {0xe01, 0xe30}, {0xe40, 0xe46}, - {0xe94, 0xe97}, {0xe99, 0xe9f}, {0xea1, 0xea3}, {0xead, 0xeb0}, - {0xec0, 0xec4}, {0xedc, 0xedf}, {0xf40, 0xf47}, {0xf49, 0xf6c}, - {0xf88, 0xf8c}, {0x1000, 0x102a}, {0x1050, 0x1055}, {0x105a, 0x105d}, - {0x106e, 0x1070}, {0x1075, 0x1081}, {0x10a0, 0x10c5}, {0x10d0, 0x10fa}, - {0x10fc, 0x1248}, {0x124a, 0x124d}, {0x1250, 0x1256}, {0x125a, 0x125d}, - {0x1260, 0x1288}, {0x128a, 0x128d}, {0x1290, 0x12b0}, {0x12b2, 0x12b5}, - {0x12b8, 0x12be}, {0x12c2, 0x12c5}, {0x12c8, 0x12d6}, {0x12d8, 0x1310}, - {0x1312, 0x1315}, {0x1318, 0x135a}, {0x1380, 0x138f}, {0x13a0, 0x13f4}, + {0x800, 0x815}, {0x840, 0x858}, {0x860, 0x86a}, {0x8a0, 0x8b4}, + {0x8b6, 0x8bd}, {0x904, 0x939}, {0x958, 0x961}, {0x971, 0x980}, + {0x985, 0x98c}, {0x993, 0x9a8}, {0x9aa, 0x9b0}, {0x9b6, 0x9b9}, + {0x9df, 0x9e1}, {0xa05, 0xa0a}, {0xa13, 0xa28}, {0xa2a, 0xa30}, + {0xa59, 0xa5c}, {0xa72, 0xa74}, {0xa85, 0xa8d}, {0xa8f, 0xa91}, + {0xa93, 0xaa8}, {0xaaa, 0xab0}, {0xab5, 0xab9}, {0xb05, 0xb0c}, + {0xb13, 0xb28}, {0xb2a, 0xb30}, {0xb35, 0xb39}, {0xb5f, 0xb61}, + {0xb85, 0xb8a}, {0xb8e, 0xb90}, {0xb92, 0xb95}, {0xba8, 0xbaa}, + {0xbae, 0xbb9}, {0xc05, 0xc0c}, {0xc0e, 0xc10}, {0xc12, 0xc28}, + {0xc2a, 0xc39}, {0xc58, 0xc5a}, {0xc85, 0xc8c}, {0xc8e, 0xc90}, + {0xc92, 0xca8}, {0xcaa, 0xcb3}, {0xcb5, 0xcb9}, {0xd05, 0xd0c}, + {0xd0e, 0xd10}, {0xd12, 0xd3a}, {0xd54, 0xd56}, {0xd5f, 0xd61}, + {0xd7a, 0xd7f}, {0xd85, 0xd96}, {0xd9a, 0xdb1}, {0xdb3, 0xdbb}, + {0xdc0, 0xdc6}, {0xe01, 0xe30}, {0xe40, 0xe46}, {0xe94, 0xe97}, + {0xe99, 0xe9f}, {0xea1, 0xea3}, {0xead, 0xeb0}, {0xec0, 0xec4}, + {0xedc, 0xedf}, {0xf40, 0xf47}, {0xf49, 0xf6c}, {0xf88, 0xf8c}, + {0x1000, 0x102a}, {0x1050, 0x1055}, {0x105a, 0x105d}, {0x106e, 0x1070}, + {0x1075, 0x1081}, {0x10a0, 0x10c5}, {0x10d0, 0x10fa}, {0x10fc, 0x1248}, + {0x124a, 0x124d}, {0x1250, 0x1256}, {0x125a, 0x125d}, {0x1260, 0x1288}, + {0x128a, 0x128d}, {0x1290, 0x12b0}, {0x12b2, 0x12b5}, {0x12b8, 0x12be}, + {0x12c2, 0x12c5}, {0x12c8, 0x12d6}, {0x12d8, 0x1310}, {0x1312, 0x1315}, + {0x1318, 0x135a}, {0x1380, 0x138f}, {0x13a0, 0x13f5}, {0x13f8, 0x13fd}, {0x1401, 0x166c}, {0x166f, 0x167f}, {0x1681, 0x169a}, {0x16a0, 0x16ea}, - {0x1700, 0x170c}, {0x170e, 0x1711}, {0x1720, 0x1731}, {0x1740, 0x1751}, - {0x1760, 0x176c}, {0x176e, 0x1770}, {0x1780, 0x17b3}, {0x1820, 0x1877}, - {0x1880, 0x18a8}, {0x18b0, 0x18f5}, {0x1900, 0x191c}, {0x1950, 0x196d}, - {0x1970, 0x1974}, {0x1980, 0x19ab}, {0x19c1, 0x19c7}, {0x1a00, 0x1a16}, - {0x1a20, 0x1a54}, {0x1b05, 0x1b33}, {0x1b45, 0x1b4b}, {0x1b83, 0x1ba0}, - {0x1bba, 0x1be5}, {0x1c00, 0x1c23}, {0x1c4d, 0x1c4f}, {0x1c5a, 0x1c7d}, - {0x1ce9, 0x1cec}, {0x1cee, 0x1cf1}, {0x1d00, 0x1dbf}, {0x1e00, 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}, {0x2090, 0x209c}, {0x210a, 0x2113}, - {0x2119, 0x211d}, {0x212a, 0x212d}, {0x212f, 0x2139}, {0x213c, 0x213f}, - {0x2145, 0x2149}, {0x2c00, 0x2c2e}, {0x2c30, 0x2c5e}, {0x2c60, 0x2ce4}, - {0x2ceb, 0x2cee}, {0x2d00, 0x2d25}, {0x2d30, 0x2d67}, {0x2d80, 0x2d96}, - {0x2da0, 0x2da6}, {0x2da8, 0x2dae}, {0x2db0, 0x2db6}, {0x2db8, 0x2dbe}, - {0x2dc0, 0x2dc6}, {0x2dc8, 0x2dce}, {0x2dd0, 0x2dd6}, {0x2dd8, 0x2dde}, - {0x3031, 0x3035}, {0x3041, 0x3096}, {0x309d, 0x309f}, {0x30a1, 0x30fa}, - {0x30fc, 0x30ff}, {0x3105, 0x312d}, {0x3131, 0x318e}, {0x31a0, 0x31ba}, - {0x31f0, 0x31ff}, {0x3400, 0x4db5}, {0x4e00, 0x9fcc}, {0xa000, 0xa48c}, - {0xa4d0, 0xa4fd}, {0xa500, 0xa60c}, {0xa610, 0xa61f}, {0xa640, 0xa66e}, - {0xa67f, 0xa697}, {0xa6a0, 0xa6e5}, {0xa717, 0xa71f}, {0xa722, 0xa788}, - {0xa78b, 0xa78e}, {0xa790, 0xa793}, {0xa7a0, 0xa7aa}, {0xa7f8, 0xa801}, - {0xa803, 0xa805}, {0xa807, 0xa80a}, {0xa80c, 0xa822}, {0xa840, 0xa873}, - {0xa882, 0xa8b3}, {0xa8f2, 0xa8f7}, {0xa90a, 0xa925}, {0xa930, 0xa946}, - {0xa960, 0xa97c}, {0xa984, 0xa9b2}, {0xaa00, 0xaa28}, {0xaa40, 0xaa42}, - {0xaa44, 0xaa4b}, {0xaa60, 0xaa76}, {0xaa80, 0xaaaf}, {0xaab9, 0xaabd}, - {0xaadb, 0xaadd}, {0xaae0, 0xaaea}, {0xaaf2, 0xaaf4}, {0xab01, 0xab06}, - {0xab09, 0xab0e}, {0xab11, 0xab16}, {0xab20, 0xab26}, {0xab28, 0xab2e}, - {0xabc0, 0xabe2}, {0xac00, 0xd7a3}, {0xd7b0, 0xd7c6}, {0xd7cb, 0xd7fb}, + {0x16f1, 0x16f8}, {0x1700, 0x170c}, {0x170e, 0x1711}, {0x1720, 0x1731}, + {0x1740, 0x1751}, {0x1760, 0x176c}, {0x176e, 0x1770}, {0x1780, 0x17b3}, + {0x1820, 0x1878}, {0x1880, 0x1884}, {0x1887, 0x18a8}, {0x18b0, 0x18f5}, + {0x1900, 0x191e}, {0x1950, 0x196d}, {0x1970, 0x1974}, {0x1980, 0x19ab}, + {0x19b0, 0x19c9}, {0x1a00, 0x1a16}, {0x1a20, 0x1a54}, {0x1b05, 0x1b33}, + {0x1b45, 0x1b4b}, {0x1b83, 0x1ba0}, {0x1bba, 0x1be5}, {0x1c00, 0x1c23}, + {0x1c4d, 0x1c4f}, {0x1c5a, 0x1c7d}, {0x1c80, 0x1c88}, {0x1c90, 0x1cba}, + {0x1cbd, 0x1cbf}, {0x1ce9, 0x1cec}, {0x1cee, 0x1cf1}, {0x1d00, 0x1dbf}, + {0x1e00, 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}, {0x2090, 0x209c}, + {0x210a, 0x2113}, {0x2119, 0x211d}, {0x212a, 0x212d}, {0x212f, 0x2139}, + {0x213c, 0x213f}, {0x2145, 0x2149}, {0x2c00, 0x2c2e}, {0x2c30, 0x2c5e}, + {0x2c60, 0x2ce4}, {0x2ceb, 0x2cee}, {0x2d00, 0x2d25}, {0x2d30, 0x2d67}, + {0x2d80, 0x2d96}, {0x2da0, 0x2da6}, {0x2da8, 0x2dae}, {0x2db0, 0x2db6}, + {0x2db8, 0x2dbe}, {0x2dc0, 0x2dc6}, {0x2dc8, 0x2dce}, {0x2dd0, 0x2dd6}, + {0x2dd8, 0x2dde}, {0x3031, 0x3035}, {0x3041, 0x3096}, {0x309d, 0x309f}, + {0x30a1, 0x30fa}, {0x30fc, 0x30ff}, {0x3105, 0x312f}, {0x3131, 0x318e}, + {0x31a0, 0x31ba}, {0x31f0, 0x31ff}, {0x3400, 0x4db5}, {0x4e00, 0x9fef}, + {0xa000, 0xa48c}, {0xa4d0, 0xa4fd}, {0xa500, 0xa60c}, {0xa610, 0xa61f}, + {0xa640, 0xa66e}, {0xa67f, 0xa69d}, {0xa6a0, 0xa6e5}, {0xa717, 0xa71f}, + {0xa722, 0xa788}, {0xa78b, 0xa7b9}, {0xa7f7, 0xa801}, {0xa803, 0xa805}, + {0xa807, 0xa80a}, {0xa80c, 0xa822}, {0xa840, 0xa873}, {0xa882, 0xa8b3}, + {0xa8f2, 0xa8f7}, {0xa90a, 0xa925}, {0xa930, 0xa946}, {0xa960, 0xa97c}, + {0xa984, 0xa9b2}, {0xa9e0, 0xa9e4}, {0xa9e6, 0xa9ef}, {0xa9fa, 0xa9fe}, + {0xaa00, 0xaa28}, {0xaa40, 0xaa42}, {0xaa44, 0xaa4b}, {0xaa60, 0xaa76}, + {0xaa7e, 0xaaaf}, {0xaab9, 0xaabd}, {0xaadb, 0xaadd}, {0xaae0, 0xaaea}, + {0xaaf2, 0xaaf4}, {0xab01, 0xab06}, {0xab09, 0xab0e}, {0xab11, 0xab16}, + {0xab20, 0xab26}, {0xab28, 0xab2e}, {0xab30, 0xab5a}, {0xab5c, 0xab65}, + {0xab70, 0xabe2}, {0xac00, 0xd7a3}, {0xd7b0, 0xd7c6}, {0xd7cb, 0xd7fb}, {0xf900, 0xfa6d}, {0xfa70, 0xfad9}, {0xfb00, 0xfb06}, {0xfb13, 0xfb17}, {0xfb1f, 0xfb28}, {0xfb2a, 0xfb36}, {0xfb38, 0xfb3c}, {0xfb46, 0xfbb1}, {0xfbd3, 0xfd3d}, {0xfd50, 0xfd8f}, {0xfd92, 0xfdc7}, {0xfdf0, 0xfdfb}, {0xfe70, 0xfe74}, {0xfe76, 0xfefc}, {0xff21, 0xff3a}, {0xff41, 0xff5a}, {0xff66, 0xffbe}, {0xffc2, 0xffc7}, {0xffca, 0xffcf}, {0xffd2, 0xffd7}, {0xffda, 0xffdc} -#if TCL_UTF_MAX > 4 +#if CHRBITS > 16 ,{0x10000, 0x1000b}, {0x1000d, 0x10026}, {0x10028, 0x1003a}, {0x1003f, 0x1004d}, {0x10050, 0x1005d}, {0x10080, 0x100fa}, {0x10280, 0x1029c}, {0x102a0, 0x102d0}, - {0x10300, 0x1031e}, {0x10330, 0x10340}, {0x10342, 0x10349}, {0x10380, 0x1039d}, - {0x103a0, 0x103c3}, {0x103c8, 0x103cf}, {0x10400, 0x1049d}, {0x10800, 0x10805}, - {0x1080a, 0x10835}, {0x1083f, 0x10855}, {0x10900, 0x10915}, {0x10920, 0x10939}, - {0x10980, 0x109b7}, {0x10a10, 0x10a13}, {0x10a15, 0x10a17}, {0x10a19, 0x10a33}, - {0x10a60, 0x10a7c}, {0x10b00, 0x10b35}, {0x10b40, 0x10b55}, {0x10b60, 0x10b72}, - {0x10c00, 0x10c48}, {0x11003, 0x11037}, {0x11083, 0x110af}, {0x110d0, 0x110e8}, - {0x11103, 0x11126}, {0x11183, 0x111b2}, {0x111c1, 0x111c4}, {0x11680, 0x116aa}, - {0x12000, 0x1236e}, {0x13000, 0x1342e}, {0x16800, 0x16a38}, {0x16f00, 0x16f44}, - {0x16f93, 0x16f9f}, {0x1d400, 0x1d454}, {0x1d456, 0x1d49c}, {0x1d4a9, 0x1d4ac}, - {0x1d4ae, 0x1d4b9}, {0x1d4bd, 0x1d4c3}, {0x1d4c5, 0x1d505}, {0x1d507, 0x1d50a}, - {0x1d50d, 0x1d514}, {0x1d516, 0x1d51c}, {0x1d51e, 0x1d539}, {0x1d53b, 0x1d53e}, - {0x1d540, 0x1d544}, {0x1d54a, 0x1d550}, {0x1d552, 0x1d6a5}, {0x1d6a8, 0x1d6c0}, - {0x1d6c2, 0x1d6da}, {0x1d6dc, 0x1d6fa}, {0x1d6fc, 0x1d714}, {0x1d716, 0x1d734}, - {0x1d736, 0x1d74e}, {0x1d750, 0x1d76e}, {0x1d770, 0x1d788}, {0x1d78a, 0x1d7a8}, - {0x1d7aa, 0x1d7c2}, {0x1d7c4, 0x1d7cb}, {0x1ee00, 0x1ee03}, {0x1ee05, 0x1ee1f}, - {0x1ee29, 0x1ee32}, {0x1ee34, 0x1ee37}, {0x1ee4d, 0x1ee4f}, {0x1ee67, 0x1ee6a}, - {0x1ee6c, 0x1ee72}, {0x1ee74, 0x1ee77}, {0x1ee79, 0x1ee7c}, {0x1ee80, 0x1ee89}, - {0x1ee8b, 0x1ee9b}, {0x1eea1, 0x1eea3}, {0x1eea5, 0x1eea9}, {0x1eeab, 0x1eebb}, - {0x20000, 0x2a6d6}, {0x2a700, 0x2b734}, {0x2b740, 0x2b81d}, {0x2f800, 0x2fa1d} + {0x10300, 0x1031f}, {0x1032d, 0x10340}, {0x10342, 0x10349}, {0x10350, 0x10375}, + {0x10380, 0x1039d}, {0x103a0, 0x103c3}, {0x103c8, 0x103cf}, {0x10400, 0x1049d}, + {0x104b0, 0x104d3}, {0x104d8, 0x104fb}, {0x10500, 0x10527}, {0x10530, 0x10563}, + {0x10600, 0x10736}, {0x10740, 0x10755}, {0x10760, 0x10767}, {0x10800, 0x10805}, + {0x1080a, 0x10835}, {0x1083f, 0x10855}, {0x10860, 0x10876}, {0x10880, 0x1089e}, + {0x108e0, 0x108f2}, {0x10900, 0x10915}, {0x10920, 0x10939}, {0x10980, 0x109b7}, + {0x10a10, 0x10a13}, {0x10a15, 0x10a17}, {0x10a19, 0x10a35}, {0x10a60, 0x10a7c}, + {0x10a80, 0x10a9c}, {0x10ac0, 0x10ac7}, {0x10ac9, 0x10ae4}, {0x10b00, 0x10b35}, + {0x10b40, 0x10b55}, {0x10b60, 0x10b72}, {0x10b80, 0x10b91}, {0x10c00, 0x10c48}, + {0x10c80, 0x10cb2}, {0x10cc0, 0x10cf2}, {0x10d00, 0x10d23}, {0x10f00, 0x10f1c}, + {0x10f30, 0x10f45}, {0x11003, 0x11037}, {0x11083, 0x110af}, {0x110d0, 0x110e8}, + {0x11103, 0x11126}, {0x11150, 0x11172}, {0x11183, 0x111b2}, {0x111c1, 0x111c4}, + {0x11200, 0x11211}, {0x11213, 0x1122b}, {0x11280, 0x11286}, {0x1128a, 0x1128d}, + {0x1128f, 0x1129d}, {0x1129f, 0x112a8}, {0x112b0, 0x112de}, {0x11305, 0x1130c}, + {0x11313, 0x11328}, {0x1132a, 0x11330}, {0x11335, 0x11339}, {0x1135d, 0x11361}, + {0x11400, 0x11434}, {0x11447, 0x1144a}, {0x11480, 0x114af}, {0x11580, 0x115ae}, + {0x115d8, 0x115db}, {0x11600, 0x1162f}, {0x11680, 0x116aa}, {0x11700, 0x1171a}, + {0x11800, 0x1182b}, {0x118a0, 0x118df}, {0x11a0b, 0x11a32}, {0x11a5c, 0x11a83}, + {0x11a86, 0x11a89}, {0x11ac0, 0x11af8}, {0x11c00, 0x11c08}, {0x11c0a, 0x11c2e}, + {0x11c72, 0x11c8f}, {0x11d00, 0x11d06}, {0x11d0b, 0x11d30}, {0x11d60, 0x11d65}, + {0x11d6a, 0x11d89}, {0x11ee0, 0x11ef2}, {0x12000, 0x12399}, {0x12480, 0x12543}, + {0x13000, 0x1342e}, {0x14400, 0x14646}, {0x16800, 0x16a38}, {0x16a40, 0x16a5e}, + {0x16ad0, 0x16aed}, {0x16b00, 0x16b2f}, {0x16b40, 0x16b43}, {0x16b63, 0x16b77}, + {0x16b7d, 0x16b8f}, {0x16e40, 0x16e7f}, {0x16f00, 0x16f44}, {0x16f93, 0x16f9f}, + {0x17000, 0x187f1}, {0x18800, 0x18af2}, {0x1b000, 0x1b11e}, {0x1b170, 0x1b2fb}, + {0x1bc00, 0x1bc6a}, {0x1bc70, 0x1bc7c}, {0x1bc80, 0x1bc88}, {0x1bc90, 0x1bc99}, + {0x1d400, 0x1d454}, {0x1d456, 0x1d49c}, {0x1d4a9, 0x1d4ac}, {0x1d4ae, 0x1d4b9}, + {0x1d4bd, 0x1d4c3}, {0x1d4c5, 0x1d505}, {0x1d507, 0x1d50a}, {0x1d50d, 0x1d514}, + {0x1d516, 0x1d51c}, {0x1d51e, 0x1d539}, {0x1d53b, 0x1d53e}, {0x1d540, 0x1d544}, + {0x1d54a, 0x1d550}, {0x1d552, 0x1d6a5}, {0x1d6a8, 0x1d6c0}, {0x1d6c2, 0x1d6da}, + {0x1d6dc, 0x1d6fa}, {0x1d6fc, 0x1d714}, {0x1d716, 0x1d734}, {0x1d736, 0x1d74e}, + {0x1d750, 0x1d76e}, {0x1d770, 0x1d788}, {0x1d78a, 0x1d7a8}, {0x1d7aa, 0x1d7c2}, + {0x1d7c4, 0x1d7cb}, {0x1e800, 0x1e8c4}, {0x1e900, 0x1e943}, {0x1ee00, 0x1ee03}, + {0x1ee05, 0x1ee1f}, {0x1ee29, 0x1ee32}, {0x1ee34, 0x1ee37}, {0x1ee4d, 0x1ee4f}, + {0x1ee67, 0x1ee6a}, {0x1ee6c, 0x1ee72}, {0x1ee74, 0x1ee77}, {0x1ee79, 0x1ee7c}, + {0x1ee80, 0x1ee89}, {0x1ee8b, 0x1ee9b}, {0x1eea1, 0x1eea3}, {0x1eea5, 0x1eea9}, + {0x1eeab, 0x1eebb}, {0x20000, 0x2a6d6}, {0x2a700, 0x2b734}, {0x2b740, 0x2b81d}, + {0x2b820, 0x2cea1}, {0x2ceb0, 0x2ebe0}, {0x2f800, 0x2fa1d} #endif }; #define NUM_ALPHA_RANGE (sizeof(alphaRangeTable)/sizeof(crange)) static const chr alphaCharTable[] = { - 0xaa, 0xb5, 0xba, 0x2ec, 0x2ee, 0x376, 0x377, 0x386, 0x38c, - 0x559, 0x66e, 0x66f, 0x6d5, 0x6e5, 0x6e6, 0x6ee, 0x6ef, 0x6ff, - 0x710, 0x7b1, 0x7f4, 0x7f5, 0x7fa, 0x81a, 0x824, 0x828, 0x8a0, + 0xaa, 0xb5, 0xba, 0x2ec, 0x2ee, 0x376, 0x377, 0x37f, 0x386, + 0x38c, 0x559, 0x66e, 0x66f, 0x6d5, 0x6e5, 0x6e6, 0x6ee, 0x6ef, + 0x6ff, 0x710, 0x7b1, 0x7f4, 0x7f5, 0x7fa, 0x81a, 0x824, 0x828, 0x93d, 0x950, 0x98f, 0x990, 0x9b2, 0x9bd, 0x9ce, 0x9dc, 0x9dd, - 0x9f0, 0x9f1, 0xa0f, 0xa10, 0xa32, 0xa33, 0xa35, 0xa36, 0xa38, - 0xa39, 0xa5e, 0xab2, 0xab3, 0xabd, 0xad0, 0xae0, 0xae1, 0xb0f, - 0xb10, 0xb32, 0xb33, 0xb3d, 0xb5c, 0xb5d, 0xb71, 0xb83, 0xb99, - 0xb9a, 0xb9c, 0xb9e, 0xb9f, 0xba3, 0xba4, 0xbd0, 0xc3d, 0xc58, - 0xc59, 0xc60, 0xc61, 0xcbd, 0xcde, 0xce0, 0xce1, 0xcf1, 0xcf2, - 0xd3d, 0xd4e, 0xd60, 0xd61, 0xdbd, 0xe32, 0xe33, 0xe81, 0xe82, - 0xe84, 0xe87, 0xe88, 0xe8a, 0xe8d, 0xea5, 0xea7, 0xeaa, 0xeab, - 0xeb2, 0xeb3, 0xebd, 0xec6, 0xf00, 0x103f, 0x1061, 0x1065, 0x1066, - 0x108e, 0x10c7, 0x10cd, 0x1258, 0x12c0, 0x17d7, 0x17dc, 0x18aa, 0x1aa7, - 0x1bae, 0x1baf, 0x1cf5, 0x1cf6, 0x1f59, 0x1f5b, 0x1f5d, 0x1fbe, 0x2071, - 0x207f, 0x2102, 0x2107, 0x2115, 0x2124, 0x2126, 0x2128, 0x214e, 0x2183, - 0x2184, 0x2cf2, 0x2cf3, 0x2d27, 0x2d2d, 0x2d6f, 0x2e2f, 0x3005, 0x3006, - 0x303b, 0x303c, 0xa62a, 0xa62b, 0xa8fb, 0xa9cf, 0xaa7a, 0xaab1, 0xaab5, - 0xaab6, 0xaac0, 0xaac2, 0xfb1d, 0xfb3e, 0xfb40, 0xfb41, 0xfb43, 0xfb44 -#if TCL_UTF_MAX > 4 - ,0x1003c, 0x1003d, 0x10808, 0x10837, 0x10838, 0x1083c, 0x109be, 0x109bf, 0x10a00, - 0x16f50, 0x1b000, 0x1b001, 0x1d49e, 0x1d49f, 0x1d4a2, 0x1d4a5, 0x1d4a6, 0x1d4bb, - 0x1d546, 0x1ee21, 0x1ee22, 0x1ee24, 0x1ee27, 0x1ee39, 0x1ee3b, 0x1ee42, 0x1ee47, - 0x1ee49, 0x1ee4b, 0x1ee51, 0x1ee52, 0x1ee54, 0x1ee57, 0x1ee59, 0x1ee5b, 0x1ee5d, - 0x1ee5f, 0x1ee61, 0x1ee62, 0x1ee64, 0x1ee7e + 0x9f0, 0x9f1, 0x9fc, 0xa0f, 0xa10, 0xa32, 0xa33, 0xa35, 0xa36, + 0xa38, 0xa39, 0xa5e, 0xab2, 0xab3, 0xabd, 0xad0, 0xae0, 0xae1, + 0xaf9, 0xb0f, 0xb10, 0xb32, 0xb33, 0xb3d, 0xb5c, 0xb5d, 0xb71, + 0xb83, 0xb99, 0xb9a, 0xb9c, 0xb9e, 0xb9f, 0xba3, 0xba4, 0xbd0, + 0xc3d, 0xc60, 0xc61, 0xc80, 0xcbd, 0xcde, 0xce0, 0xce1, 0xcf1, + 0xcf2, 0xd3d, 0xd4e, 0xdbd, 0xe32, 0xe33, 0xe81, 0xe82, 0xe84, + 0xe87, 0xe88, 0xe8a, 0xe8d, 0xea5, 0xea7, 0xeaa, 0xeab, 0xeb2, + 0xeb3, 0xebd, 0xec6, 0xf00, 0x103f, 0x1061, 0x1065, 0x1066, 0x108e, + 0x10c7, 0x10cd, 0x1258, 0x12c0, 0x17d7, 0x17dc, 0x18aa, 0x1aa7, 0x1bae, + 0x1baf, 0x1cf5, 0x1cf6, 0x1f59, 0x1f5b, 0x1f5d, 0x1fbe, 0x2071, 0x207f, + 0x2102, 0x2107, 0x2115, 0x2124, 0x2126, 0x2128, 0x214e, 0x2183, 0x2184, + 0x2cf2, 0x2cf3, 0x2d27, 0x2d2d, 0x2d6f, 0x2e2f, 0x3005, 0x3006, 0x303b, + 0x303c, 0xa62a, 0xa62b, 0xa8fb, 0xa8fd, 0xa8fe, 0xa9cf, 0xaa7a, 0xaab1, + 0xaab5, 0xaab6, 0xaac0, 0xaac2, 0xfb1d, 0xfb3e, 0xfb40, 0xfb41, 0xfb43, + 0xfb44 +#if CHRBITS > 16 + ,0x1003c, 0x1003d, 0x10808, 0x10837, 0x10838, 0x1083c, 0x108f4, 0x108f5, 0x109be, + 0x109bf, 0x10a00, 0x10f27, 0x11144, 0x11176, 0x111da, 0x111dc, 0x11288, 0x1130f, + 0x11310, 0x11332, 0x11333, 0x1133d, 0x11350, 0x114c4, 0x114c5, 0x114c7, 0x11644, + 0x118ff, 0x11a00, 0x11a3a, 0x11a50, 0x11a9d, 0x11c40, 0x11d08, 0x11d09, 0x11d46, + 0x11d67, 0x11d68, 0x11d98, 0x16f50, 0x16fe0, 0x16fe1, 0x1d49e, 0x1d49f, 0x1d4a2, + 0x1d4a5, 0x1d4a6, 0x1d4bb, 0x1d546, 0x1ee21, 0x1ee22, 0x1ee24, 0x1ee27, 0x1ee39, + 0x1ee3b, 0x1ee42, 0x1ee47, 0x1ee49, 0x1ee4b, 0x1ee51, 0x1ee52, 0x1ee54, 0x1ee57, + 0x1ee59, 0x1ee5b, 0x1ee5d, 0x1ee5f, 0x1ee61, 0x1ee62, 0x1ee64, 0x1ee7e #endif }; @@ -259,20 +285,21 @@ static const chr alphaCharTable[] = { */ static const crange controlRangeTable[] = { - {0x0, 0x1f}, {0x7f, 0x9f}, {0x600, 0x604}, {0x200b, 0x200f}, - {0x202a, 0x202e}, {0x2060, 0x2064}, {0x206a, 0x206f}, {0xe000, 0xf8ff}, + {0x0, 0x1f}, {0x7f, 0x9f}, {0x600, 0x605}, {0x200b, 0x200f}, + {0x202a, 0x202e}, {0x2060, 0x2064}, {0x2066, 0x206f}, {0xe000, 0xf8ff}, {0xfff9, 0xfffb} -#if TCL_UTF_MAX > 4 - ,{0x1d173, 0x1d17a}, {0xe0020, 0xe007f}, {0xf0000, 0xffffd}, {0x100000, 0x10fffd} +#if CHRBITS > 16 + ,{0x1bca0, 0x1bca3}, {0x1d173, 0x1d17a}, {0xe0020, 0xe007f}, {0xf0000, 0xffffd}, + {0x100000, 0x10fffd} #endif }; #define NUM_CONTROL_RANGE (sizeof(controlRangeTable)/sizeof(crange)) static const chr controlCharTable[] = { - 0xad, 0x6dd, 0x70f, 0xfeff -#if TCL_UTF_MAX > 4 - ,0x110bd, 0xe0001 + 0xad, 0x61c, 0x6dd, 0x70f, 0x8e2, 0x180e, 0xfeff +#if CHRBITS > 16 + ,0x110bd, 0x110cd, 0xe0001 #endif }; @@ -286,15 +313,19 @@ static const crange digitRangeTable[] = { {0x30, 0x39}, {0x660, 0x669}, {0x6f0, 0x6f9}, {0x7c0, 0x7c9}, {0x966, 0x96f}, {0x9e6, 0x9ef}, {0xa66, 0xa6f}, {0xae6, 0xaef}, {0xb66, 0xb6f}, {0xbe6, 0xbef}, {0xc66, 0xc6f}, {0xce6, 0xcef}, - {0xd66, 0xd6f}, {0xe50, 0xe59}, {0xed0, 0xed9}, {0xf20, 0xf29}, - {0x1040, 0x1049}, {0x1090, 0x1099}, {0x17e0, 0x17e9}, {0x1810, 0x1819}, - {0x1946, 0x194f}, {0x19d0, 0x19d9}, {0x1a80, 0x1a89}, {0x1a90, 0x1a99}, - {0x1b50, 0x1b59}, {0x1bb0, 0x1bb9}, {0x1c40, 0x1c49}, {0x1c50, 0x1c59}, - {0xa620, 0xa629}, {0xa8d0, 0xa8d9}, {0xa900, 0xa909}, {0xa9d0, 0xa9d9}, - {0xaa50, 0xaa59}, {0xabf0, 0xabf9}, {0xff10, 0xff19} -#if TCL_UTF_MAX > 4 - ,{0x104a0, 0x104a9}, {0x11066, 0x1106f}, {0x110f0, 0x110f9}, {0x11136, 0x1113f}, - {0x111d0, 0x111d9}, {0x116c0, 0x116c9}, {0x1d7ce, 0x1d7ff} + {0xd66, 0xd6f}, {0xde6, 0xdef}, {0xe50, 0xe59}, {0xed0, 0xed9}, + {0xf20, 0xf29}, {0x1040, 0x1049}, {0x1090, 0x1099}, {0x17e0, 0x17e9}, + {0x1810, 0x1819}, {0x1946, 0x194f}, {0x19d0, 0x19d9}, {0x1a80, 0x1a89}, + {0x1a90, 0x1a99}, {0x1b50, 0x1b59}, {0x1bb0, 0x1bb9}, {0x1c40, 0x1c49}, + {0x1c50, 0x1c59}, {0xa620, 0xa629}, {0xa8d0, 0xa8d9}, {0xa900, 0xa909}, + {0xa9d0, 0xa9d9}, {0xa9f0, 0xa9f9}, {0xaa50, 0xaa59}, {0xabf0, 0xabf9}, + {0xff10, 0xff19} +#if CHRBITS > 16 + ,{0x104a0, 0x104a9}, {0x10d30, 0x10d39}, {0x11066, 0x1106f}, {0x110f0, 0x110f9}, + {0x11136, 0x1113f}, {0x111d0, 0x111d9}, {0x112f0, 0x112f9}, {0x11450, 0x11459}, + {0x114d0, 0x114d9}, {0x11650, 0x11659}, {0x116c0, 0x116c9}, {0x11730, 0x11739}, + {0x118e0, 0x118e9}, {0x11c50, 0x11c59}, {0x11d50, 0x11d59}, {0x11da0, 0x11da9}, + {0x16a60, 0x16a69}, {0x16b50, 0x16b59}, {0x1d7ce, 0x1d7ff}, {0x1e950, 0x1e959} #endif }; @@ -316,15 +347,21 @@ static const crange punctRangeTable[] = { {0x17d8, 0x17da}, {0x1800, 0x180a}, {0x1aa0, 0x1aa6}, {0x1aa8, 0x1aad}, {0x1b5a, 0x1b60}, {0x1bfc, 0x1bff}, {0x1c3b, 0x1c3f}, {0x1cc0, 0x1cc7}, {0x2010, 0x2027}, {0x2030, 0x2043}, {0x2045, 0x2051}, {0x2053, 0x205e}, - {0x2768, 0x2775}, {0x27e6, 0x27ef}, {0x2983, 0x2998}, {0x29d8, 0x29db}, - {0x2cf9, 0x2cfc}, {0x2e00, 0x2e2e}, {0x2e30, 0x2e3b}, {0x3001, 0x3003}, - {0x3008, 0x3011}, {0x3014, 0x301f}, {0xa60d, 0xa60f}, {0xa6f2, 0xa6f7}, - {0xa874, 0xa877}, {0xa8f8, 0xa8fa}, {0xa9c1, 0xa9cd}, {0xaa5c, 0xaa5f}, - {0xfe10, 0xfe19}, {0xfe30, 0xfe52}, {0xfe54, 0xfe61}, {0xff01, 0xff03}, - {0xff05, 0xff0a}, {0xff0c, 0xff0f}, {0xff3b, 0xff3d}, {0xff5f, 0xff65} -#if TCL_UTF_MAX > 4 - ,{0x10100, 0x10102}, {0x10a50, 0x10a58}, {0x10b39, 0x10b3f}, {0x11047, 0x1104d}, - {0x110be, 0x110c1}, {0x11140, 0x11143}, {0x111c5, 0x111c8}, {0x12470, 0x12473} + {0x2308, 0x230b}, {0x2768, 0x2775}, {0x27e6, 0x27ef}, {0x2983, 0x2998}, + {0x29d8, 0x29db}, {0x2cf9, 0x2cfc}, {0x2e00, 0x2e2e}, {0x2e30, 0x2e4e}, + {0x3001, 0x3003}, {0x3008, 0x3011}, {0x3014, 0x301f}, {0xa60d, 0xa60f}, + {0xa6f2, 0xa6f7}, {0xa874, 0xa877}, {0xa8f8, 0xa8fa}, {0xa9c1, 0xa9cd}, + {0xaa5c, 0xaa5f}, {0xfe10, 0xfe19}, {0xfe30, 0xfe52}, {0xfe54, 0xfe61}, + {0xff01, 0xff03}, {0xff05, 0xff0a}, {0xff0c, 0xff0f}, {0xff3b, 0xff3d}, + {0xff5f, 0xff65} +#if CHRBITS > 16 + ,{0x10100, 0x10102}, {0x10a50, 0x10a58}, {0x10af0, 0x10af6}, {0x10b39, 0x10b3f}, + {0x10b99, 0x10b9c}, {0x10f55, 0x10f59}, {0x11047, 0x1104d}, {0x110be, 0x110c1}, + {0x11140, 0x11143}, {0x111c5, 0x111c8}, {0x111dd, 0x111df}, {0x11238, 0x1123d}, + {0x1144b, 0x1144f}, {0x115c1, 0x115d7}, {0x11641, 0x11643}, {0x11660, 0x1166c}, + {0x1173c, 0x1173e}, {0x11a3f, 0x11a46}, {0x11a9a, 0x11a9c}, {0x11a9e, 0x11aa2}, + {0x11c41, 0x11c45}, {0x12470, 0x12474}, {0x16b37, 0x16b3b}, {0x16e97, 0x16e9a}, + {0x1da87, 0x1da8b} #endif }; @@ -335,16 +372,20 @@ static const chr punctCharTable[] = { 0xab, 0xb6, 0xb7, 0xbb, 0xbf, 0x37e, 0x387, 0x589, 0x58a, 0x5be, 0x5c0, 0x5c3, 0x5c6, 0x5f3, 0x5f4, 0x609, 0x60a, 0x60c, 0x60d, 0x61b, 0x61e, 0x61f, 0x6d4, 0x85e, 0x964, 0x965, 0x970, - 0xaf0, 0xdf4, 0xe4f, 0xe5a, 0xe5b, 0xf14, 0xf85, 0xfd9, 0xfda, - 0x10fb, 0x1400, 0x166d, 0x166e, 0x169b, 0x169c, 0x1735, 0x1736, 0x1944, - 0x1945, 0x1a1e, 0x1a1f, 0x1c7e, 0x1c7f, 0x1cd3, 0x207d, 0x207e, 0x208d, - 0x208e, 0x2329, 0x232a, 0x27c5, 0x27c6, 0x29fc, 0x29fd, 0x2cfe, 0x2cff, - 0x2d70, 0x3030, 0x303d, 0x30a0, 0x30fb, 0xa4fe, 0xa4ff, 0xa673, 0xa67e, - 0xa8ce, 0xa8cf, 0xa92e, 0xa92f, 0xa95f, 0xa9de, 0xa9df, 0xaade, 0xaadf, - 0xaaf0, 0xaaf1, 0xabeb, 0xfd3e, 0xfd3f, 0xfe63, 0xfe68, 0xfe6a, 0xfe6b, - 0xff1a, 0xff1b, 0xff1f, 0xff20, 0xff3f, 0xff5b, 0xff5d -#if TCL_UTF_MAX > 4 - ,0x1039f, 0x103d0, 0x10857, 0x1091f, 0x1093f, 0x10a7f, 0x110bb, 0x110bc + 0x9fd, 0xa76, 0xaf0, 0xc84, 0xdf4, 0xe4f, 0xe5a, 0xe5b, 0xf14, + 0xf85, 0xfd9, 0xfda, 0x10fb, 0x1400, 0x166d, 0x166e, 0x169b, 0x169c, + 0x1735, 0x1736, 0x1944, 0x1945, 0x1a1e, 0x1a1f, 0x1c7e, 0x1c7f, 0x1cd3, + 0x207d, 0x207e, 0x208d, 0x208e, 0x2329, 0x232a, 0x27c5, 0x27c6, 0x29fc, + 0x29fd, 0x2cfe, 0x2cff, 0x2d70, 0x3030, 0x303d, 0x30a0, 0x30fb, 0xa4fe, + 0xa4ff, 0xa673, 0xa67e, 0xa8ce, 0xa8cf, 0xa8fc, 0xa92e, 0xa92f, 0xa95f, + 0xa9de, 0xa9df, 0xaade, 0xaadf, 0xaaf0, 0xaaf1, 0xabeb, 0xfd3e, 0xfd3f, + 0xfe63, 0xfe68, 0xfe6a, 0xfe6b, 0xff1a, 0xff1b, 0xff1f, 0xff20, 0xff3f, + 0xff5b, 0xff5d +#if CHRBITS > 16 + ,0x1039f, 0x103d0, 0x1056f, 0x10857, 0x1091f, 0x1093f, 0x10a7f, 0x110bb, 0x110bc, + 0x11174, 0x11175, 0x111cd, 0x111db, 0x112a9, 0x1145b, 0x1145d, 0x114c6, 0x1183b, + 0x11c70, 0x11c71, 0x11ef7, 0x11ef8, 0x16a6e, 0x16a6f, 0x16af5, 0x16b44, 0x1bc9f, + 0x1e95e, 0x1e95f #endif }; @@ -375,22 +416,25 @@ static const crange lowerRangeTable[] = { {0x61, 0x7a}, {0xdf, 0xf6}, {0xf8, 0xff}, {0x17e, 0x180}, {0x199, 0x19b}, {0x1bd, 0x1bf}, {0x233, 0x239}, {0x24f, 0x293}, {0x295, 0x2af}, {0x37b, 0x37d}, {0x3ac, 0x3ce}, {0x3d5, 0x3d7}, - {0x3ef, 0x3f3}, {0x430, 0x45f}, {0x561, 0x587}, {0x1d00, 0x1d2b}, + {0x3ef, 0x3f3}, {0x430, 0x45f}, {0x560, 0x588}, {0x10d0, 0x10fa}, + {0x10fd, 0x10ff}, {0x13f8, 0x13fd}, {0x1c80, 0x1c88}, {0x1d00, 0x1d2b}, {0x1d6b, 0x1d77}, {0x1d79, 0x1d9a}, {0x1e95, 0x1e9d}, {0x1eff, 0x1f07}, {0x1f10, 0x1f15}, {0x1f20, 0x1f27}, {0x1f30, 0x1f37}, {0x1f40, 0x1f45}, {0x1f50, 0x1f57}, {0x1f60, 0x1f67}, {0x1f70, 0x1f7d}, {0x1f80, 0x1f87}, {0x1f90, 0x1f97}, {0x1fa0, 0x1fa7}, {0x1fb0, 0x1fb4}, {0x1fc2, 0x1fc4}, {0x1fd0, 0x1fd3}, {0x1fe0, 0x1fe7}, {0x1ff2, 0x1ff4}, {0x2146, 0x2149}, {0x2c30, 0x2c5e}, {0x2c76, 0x2c7b}, {0x2d00, 0x2d25}, {0xa72f, 0xa731}, - {0xa771, 0xa778}, {0xfb00, 0xfb06}, {0xfb13, 0xfb17}, {0xff41, 0xff5a} -#if TCL_UTF_MAX > 4 - ,{0x10428, 0x1044f}, {0x1d41a, 0x1d433}, {0x1d44e, 0x1d454}, {0x1d456, 0x1d467}, + {0xa771, 0xa778}, {0xa793, 0xa795}, {0xab30, 0xab5a}, {0xab60, 0xab65}, + {0xab70, 0xabbf}, {0xfb00, 0xfb06}, {0xfb13, 0xfb17}, {0xff41, 0xff5a} +#if CHRBITS > 16 + ,{0x10428, 0x1044f}, {0x104d8, 0x104fb}, {0x10cc0, 0x10cf2}, {0x118c0, 0x118df}, + {0x16e60, 0x16e7f}, {0x1d41a, 0x1d433}, {0x1d44e, 0x1d454}, {0x1d456, 0x1d467}, {0x1d482, 0x1d49b}, {0x1d4b6, 0x1d4b9}, {0x1d4bd, 0x1d4c3}, {0x1d4c5, 0x1d4cf}, {0x1d4ea, 0x1d503}, {0x1d51e, 0x1d537}, {0x1d552, 0x1d56b}, {0x1d586, 0x1d59f}, {0x1d5ba, 0x1d5d3}, {0x1d5ee, 0x1d607}, {0x1d622, 0x1d63b}, {0x1d656, 0x1d66f}, {0x1d68a, 0x1d6a5}, {0x1d6c2, 0x1d6da}, {0x1d6dc, 0x1d6e1}, {0x1d6fc, 0x1d714}, {0x1d716, 0x1d71b}, {0x1d736, 0x1d74e}, {0x1d750, 0x1d755}, {0x1d770, 0x1d788}, - {0x1d78a, 0x1d78f}, {0x1d7aa, 0x1d7c2}, {0x1d7c4, 0x1d7c9} + {0x1d78a, 0x1d78f}, {0x1d7aa, 0x1d7c2}, {0x1d7c4, 0x1d7c9}, {0x1e922, 0x1e943} #endif }; @@ -426,40 +470,42 @@ static const chr lowerCharTable[] = { 0x4f1, 0x4f3, 0x4f5, 0x4f7, 0x4f9, 0x4fb, 0x4fd, 0x4ff, 0x501, 0x503, 0x505, 0x507, 0x509, 0x50b, 0x50d, 0x50f, 0x511, 0x513, 0x515, 0x517, 0x519, 0x51b, 0x51d, 0x51f, 0x521, 0x523, 0x525, - 0x527, 0x1e01, 0x1e03, 0x1e05, 0x1e07, 0x1e09, 0x1e0b, 0x1e0d, 0x1e0f, - 0x1e11, 0x1e13, 0x1e15, 0x1e17, 0x1e19, 0x1e1b, 0x1e1d, 0x1e1f, 0x1e21, - 0x1e23, 0x1e25, 0x1e27, 0x1e29, 0x1e2b, 0x1e2d, 0x1e2f, 0x1e31, 0x1e33, - 0x1e35, 0x1e37, 0x1e39, 0x1e3b, 0x1e3d, 0x1e3f, 0x1e41, 0x1e43, 0x1e45, - 0x1e47, 0x1e49, 0x1e4b, 0x1e4d, 0x1e4f, 0x1e51, 0x1e53, 0x1e55, 0x1e57, - 0x1e59, 0x1e5b, 0x1e5d, 0x1e5f, 0x1e61, 0x1e63, 0x1e65, 0x1e67, 0x1e69, - 0x1e6b, 0x1e6d, 0x1e6f, 0x1e71, 0x1e73, 0x1e75, 0x1e77, 0x1e79, 0x1e7b, - 0x1e7d, 0x1e7f, 0x1e81, 0x1e83, 0x1e85, 0x1e87, 0x1e89, 0x1e8b, 0x1e8d, - 0x1e8f, 0x1e91, 0x1e93, 0x1e9f, 0x1ea1, 0x1ea3, 0x1ea5, 0x1ea7, 0x1ea9, - 0x1eab, 0x1ead, 0x1eaf, 0x1eb1, 0x1eb3, 0x1eb5, 0x1eb7, 0x1eb9, 0x1ebb, - 0x1ebd, 0x1ebf, 0x1ec1, 0x1ec3, 0x1ec5, 0x1ec7, 0x1ec9, 0x1ecb, 0x1ecd, - 0x1ecf, 0x1ed1, 0x1ed3, 0x1ed5, 0x1ed7, 0x1ed9, 0x1edb, 0x1edd, 0x1edf, - 0x1ee1, 0x1ee3, 0x1ee5, 0x1ee7, 0x1ee9, 0x1eeb, 0x1eed, 0x1eef, 0x1ef1, - 0x1ef3, 0x1ef5, 0x1ef7, 0x1ef9, 0x1efb, 0x1efd, 0x1fb6, 0x1fb7, 0x1fbe, - 0x1fc6, 0x1fc7, 0x1fd6, 0x1fd7, 0x1ff6, 0x1ff7, 0x210a, 0x210e, 0x210f, - 0x2113, 0x212f, 0x2134, 0x2139, 0x213c, 0x213d, 0x214e, 0x2184, 0x2c61, - 0x2c65, 0x2c66, 0x2c68, 0x2c6a, 0x2c6c, 0x2c71, 0x2c73, 0x2c74, 0x2c81, - 0x2c83, 0x2c85, 0x2c87, 0x2c89, 0x2c8b, 0x2c8d, 0x2c8f, 0x2c91, 0x2c93, - 0x2c95, 0x2c97, 0x2c99, 0x2c9b, 0x2c9d, 0x2c9f, 0x2ca1, 0x2ca3, 0x2ca5, - 0x2ca7, 0x2ca9, 0x2cab, 0x2cad, 0x2caf, 0x2cb1, 0x2cb3, 0x2cb5, 0x2cb7, - 0x2cb9, 0x2cbb, 0x2cbd, 0x2cbf, 0x2cc1, 0x2cc3, 0x2cc5, 0x2cc7, 0x2cc9, - 0x2ccb, 0x2ccd, 0x2ccf, 0x2cd1, 0x2cd3, 0x2cd5, 0x2cd7, 0x2cd9, 0x2cdb, - 0x2cdd, 0x2cdf, 0x2ce1, 0x2ce3, 0x2ce4, 0x2cec, 0x2cee, 0x2cf3, 0x2d27, - 0x2d2d, 0xa641, 0xa643, 0xa645, 0xa647, 0xa649, 0xa64b, 0xa64d, 0xa64f, - 0xa651, 0xa653, 0xa655, 0xa657, 0xa659, 0xa65b, 0xa65d, 0xa65f, 0xa661, - 0xa663, 0xa665, 0xa667, 0xa669, 0xa66b, 0xa66d, 0xa681, 0xa683, 0xa685, - 0xa687, 0xa689, 0xa68b, 0xa68d, 0xa68f, 0xa691, 0xa693, 0xa695, 0xa697, - 0xa723, 0xa725, 0xa727, 0xa729, 0xa72b, 0xa72d, 0xa733, 0xa735, 0xa737, - 0xa739, 0xa73b, 0xa73d, 0xa73f, 0xa741, 0xa743, 0xa745, 0xa747, 0xa749, - 0xa74b, 0xa74d, 0xa74f, 0xa751, 0xa753, 0xa755, 0xa757, 0xa759, 0xa75b, - 0xa75d, 0xa75f, 0xa761, 0xa763, 0xa765, 0xa767, 0xa769, 0xa76b, 0xa76d, - 0xa76f, 0xa77a, 0xa77c, 0xa77f, 0xa781, 0xa783, 0xa785, 0xa787, 0xa78c, - 0xa78e, 0xa791, 0xa793, 0xa7a1, 0xa7a3, 0xa7a5, 0xa7a7, 0xa7a9, 0xa7fa -#if TCL_UTF_MAX > 4 + 0x527, 0x529, 0x52b, 0x52d, 0x52f, 0x1e01, 0x1e03, 0x1e05, 0x1e07, + 0x1e09, 0x1e0b, 0x1e0d, 0x1e0f, 0x1e11, 0x1e13, 0x1e15, 0x1e17, 0x1e19, + 0x1e1b, 0x1e1d, 0x1e1f, 0x1e21, 0x1e23, 0x1e25, 0x1e27, 0x1e29, 0x1e2b, + 0x1e2d, 0x1e2f, 0x1e31, 0x1e33, 0x1e35, 0x1e37, 0x1e39, 0x1e3b, 0x1e3d, + 0x1e3f, 0x1e41, 0x1e43, 0x1e45, 0x1e47, 0x1e49, 0x1e4b, 0x1e4d, 0x1e4f, + 0x1e51, 0x1e53, 0x1e55, 0x1e57, 0x1e59, 0x1e5b, 0x1e5d, 0x1e5f, 0x1e61, + 0x1e63, 0x1e65, 0x1e67, 0x1e69, 0x1e6b, 0x1e6d, 0x1e6f, 0x1e71, 0x1e73, + 0x1e75, 0x1e77, 0x1e79, 0x1e7b, 0x1e7d, 0x1e7f, 0x1e81, 0x1e83, 0x1e85, + 0x1e87, 0x1e89, 0x1e8b, 0x1e8d, 0x1e8f, 0x1e91, 0x1e93, 0x1e9f, 0x1ea1, + 0x1ea3, 0x1ea5, 0x1ea7, 0x1ea9, 0x1eab, 0x1ead, 0x1eaf, 0x1eb1, 0x1eb3, + 0x1eb5, 0x1eb7, 0x1eb9, 0x1ebb, 0x1ebd, 0x1ebf, 0x1ec1, 0x1ec3, 0x1ec5, + 0x1ec7, 0x1ec9, 0x1ecb, 0x1ecd, 0x1ecf, 0x1ed1, 0x1ed3, 0x1ed5, 0x1ed7, + 0x1ed9, 0x1edb, 0x1edd, 0x1edf, 0x1ee1, 0x1ee3, 0x1ee5, 0x1ee7, 0x1ee9, + 0x1eeb, 0x1eed, 0x1eef, 0x1ef1, 0x1ef3, 0x1ef5, 0x1ef7, 0x1ef9, 0x1efb, + 0x1efd, 0x1fb6, 0x1fb7, 0x1fbe, 0x1fc6, 0x1fc7, 0x1fd6, 0x1fd7, 0x1ff6, + 0x1ff7, 0x210a, 0x210e, 0x210f, 0x2113, 0x212f, 0x2134, 0x2139, 0x213c, + 0x213d, 0x214e, 0x2184, 0x2c61, 0x2c65, 0x2c66, 0x2c68, 0x2c6a, 0x2c6c, + 0x2c71, 0x2c73, 0x2c74, 0x2c81, 0x2c83, 0x2c85, 0x2c87, 0x2c89, 0x2c8b, + 0x2c8d, 0x2c8f, 0x2c91, 0x2c93, 0x2c95, 0x2c97, 0x2c99, 0x2c9b, 0x2c9d, + 0x2c9f, 0x2ca1, 0x2ca3, 0x2ca5, 0x2ca7, 0x2ca9, 0x2cab, 0x2cad, 0x2caf, + 0x2cb1, 0x2cb3, 0x2cb5, 0x2cb7, 0x2cb9, 0x2cbb, 0x2cbd, 0x2cbf, 0x2cc1, + 0x2cc3, 0x2cc5, 0x2cc7, 0x2cc9, 0x2ccb, 0x2ccd, 0x2ccf, 0x2cd1, 0x2cd3, + 0x2cd5, 0x2cd7, 0x2cd9, 0x2cdb, 0x2cdd, 0x2cdf, 0x2ce1, 0x2ce3, 0x2ce4, + 0x2cec, 0x2cee, 0x2cf3, 0x2d27, 0x2d2d, 0xa641, 0xa643, 0xa645, 0xa647, + 0xa649, 0xa64b, 0xa64d, 0xa64f, 0xa651, 0xa653, 0xa655, 0xa657, 0xa659, + 0xa65b, 0xa65d, 0xa65f, 0xa661, 0xa663, 0xa665, 0xa667, 0xa669, 0xa66b, + 0xa66d, 0xa681, 0xa683, 0xa685, 0xa687, 0xa689, 0xa68b, 0xa68d, 0xa68f, + 0xa691, 0xa693, 0xa695, 0xa697, 0xa699, 0xa69b, 0xa723, 0xa725, 0xa727, + 0xa729, 0xa72b, 0xa72d, 0xa733, 0xa735, 0xa737, 0xa739, 0xa73b, 0xa73d, + 0xa73f, 0xa741, 0xa743, 0xa745, 0xa747, 0xa749, 0xa74b, 0xa74d, 0xa74f, + 0xa751, 0xa753, 0xa755, 0xa757, 0xa759, 0xa75b, 0xa75d, 0xa75f, 0xa761, + 0xa763, 0xa765, 0xa767, 0xa769, 0xa76b, 0xa76d, 0xa76f, 0xa77a, 0xa77c, + 0xa77f, 0xa781, 0xa783, 0xa785, 0xa787, 0xa78c, 0xa78e, 0xa791, 0xa797, + 0xa799, 0xa79b, 0xa79d, 0xa79f, 0xa7a1, 0xa7a3, 0xa7a5, 0xa7a7, 0xa7a9, + 0xa7af, 0xa7b5, 0xa7b7, 0xa7b9, 0xa7fa +#if CHRBITS > 16 ,0x1d4bb, 0x1d7cb #endif }; @@ -475,19 +521,22 @@ static const crange upperRangeTable[] = { {0x18e, 0x191}, {0x196, 0x198}, {0x1b1, 0x1b3}, {0x1f6, 0x1f8}, {0x243, 0x246}, {0x388, 0x38a}, {0x391, 0x3a1}, {0x3a3, 0x3ab}, {0x3d2, 0x3d4}, {0x3fd, 0x42f}, {0x531, 0x556}, {0x10a0, 0x10c5}, - {0x1f08, 0x1f0f}, {0x1f18, 0x1f1d}, {0x1f28, 0x1f2f}, {0x1f38, 0x1f3f}, - {0x1f48, 0x1f4d}, {0x1f68, 0x1f6f}, {0x1fb8, 0x1fbb}, {0x1fc8, 0x1fcb}, - {0x1fd8, 0x1fdb}, {0x1fe8, 0x1fec}, {0x1ff8, 0x1ffb}, {0x210b, 0x210d}, - {0x2110, 0x2112}, {0x2119, 0x211d}, {0x212a, 0x212d}, {0x2130, 0x2133}, - {0x2c00, 0x2c2e}, {0x2c62, 0x2c64}, {0x2c6d, 0x2c70}, {0x2c7e, 0x2c80}, - {0xff21, 0xff3a} -#if TCL_UTF_MAX > 4 - ,{0x10400, 0x10427}, {0x1d400, 0x1d419}, {0x1d434, 0x1d44d}, {0x1d468, 0x1d481}, + {0x13a0, 0x13f5}, {0x1c90, 0x1cba}, {0x1cbd, 0x1cbf}, {0x1f08, 0x1f0f}, + {0x1f18, 0x1f1d}, {0x1f28, 0x1f2f}, {0x1f38, 0x1f3f}, {0x1f48, 0x1f4d}, + {0x1f68, 0x1f6f}, {0x1fb8, 0x1fbb}, {0x1fc8, 0x1fcb}, {0x1fd8, 0x1fdb}, + {0x1fe8, 0x1fec}, {0x1ff8, 0x1ffb}, {0x210b, 0x210d}, {0x2110, 0x2112}, + {0x2119, 0x211d}, {0x212a, 0x212d}, {0x2130, 0x2133}, {0x2c00, 0x2c2e}, + {0x2c62, 0x2c64}, {0x2c6d, 0x2c70}, {0x2c7e, 0x2c80}, {0xa7aa, 0xa7ae}, + {0xa7b0, 0xa7b4}, {0xff21, 0xff3a} +#if CHRBITS > 16 + ,{0x10400, 0x10427}, {0x104b0, 0x104d3}, {0x10c80, 0x10cb2}, {0x118a0, 0x118bf}, + {0x16e40, 0x16e5f}, {0x1d400, 0x1d419}, {0x1d434, 0x1d44d}, {0x1d468, 0x1d481}, {0x1d4a9, 0x1d4ac}, {0x1d4ae, 0x1d4b5}, {0x1d4d0, 0x1d4e9}, {0x1d507, 0x1d50a}, {0x1d50d, 0x1d514}, {0x1d516, 0x1d51c}, {0x1d53b, 0x1d53e}, {0x1d540, 0x1d544}, {0x1d54a, 0x1d550}, {0x1d56c, 0x1d585}, {0x1d5a0, 0x1d5b9}, {0x1d5d4, 0x1d5ed}, {0x1d608, 0x1d621}, {0x1d63c, 0x1d655}, {0x1d670, 0x1d689}, {0x1d6a8, 0x1d6c0}, - {0x1d6e2, 0x1d6fa}, {0x1d71c, 0x1d734}, {0x1d756, 0x1d76e}, {0x1d790, 0x1d7a8} + {0x1d6e2, 0x1d6fa}, {0x1d71c, 0x1d734}, {0x1d756, 0x1d76e}, {0x1d790, 0x1d7a8}, + {0x1e900, 0x1e921} #endif }; @@ -510,53 +559,55 @@ static const chr upperCharTable[] = { 0x20c, 0x20e, 0x210, 0x212, 0x214, 0x216, 0x218, 0x21a, 0x21c, 0x21e, 0x220, 0x222, 0x224, 0x226, 0x228, 0x22a, 0x22c, 0x22e, 0x230, 0x232, 0x23a, 0x23b, 0x23d, 0x23e, 0x241, 0x248, 0x24a, - 0x24c, 0x24e, 0x370, 0x372, 0x376, 0x386, 0x38c, 0x38e, 0x38f, - 0x3cf, 0x3d8, 0x3da, 0x3dc, 0x3de, 0x3e0, 0x3e2, 0x3e4, 0x3e6, - 0x3e8, 0x3ea, 0x3ec, 0x3ee, 0x3f4, 0x3f7, 0x3f9, 0x3fa, 0x460, - 0x462, 0x464, 0x466, 0x468, 0x46a, 0x46c, 0x46e, 0x470, 0x472, - 0x474, 0x476, 0x478, 0x47a, 0x47c, 0x47e, 0x480, 0x48a, 0x48c, - 0x48e, 0x490, 0x492, 0x494, 0x496, 0x498, 0x49a, 0x49c, 0x49e, - 0x4a0, 0x4a2, 0x4a4, 0x4a6, 0x4a8, 0x4aa, 0x4ac, 0x4ae, 0x4b0, - 0x4b2, 0x4b4, 0x4b6, 0x4b8, 0x4ba, 0x4bc, 0x4be, 0x4c0, 0x4c1, - 0x4c3, 0x4c5, 0x4c7, 0x4c9, 0x4cb, 0x4cd, 0x4d0, 0x4d2, 0x4d4, - 0x4d6, 0x4d8, 0x4da, 0x4dc, 0x4de, 0x4e0, 0x4e2, 0x4e4, 0x4e6, - 0x4e8, 0x4ea, 0x4ec, 0x4ee, 0x4f0, 0x4f2, 0x4f4, 0x4f6, 0x4f8, - 0x4fa, 0x4fc, 0x4fe, 0x500, 0x502, 0x504, 0x506, 0x508, 0x50a, - 0x50c, 0x50e, 0x510, 0x512, 0x514, 0x516, 0x518, 0x51a, 0x51c, - 0x51e, 0x520, 0x522, 0x524, 0x526, 0x10c7, 0x10cd, 0x1e00, 0x1e02, - 0x1e04, 0x1e06, 0x1e08, 0x1e0a, 0x1e0c, 0x1e0e, 0x1e10, 0x1e12, 0x1e14, - 0x1e16, 0x1e18, 0x1e1a, 0x1e1c, 0x1e1e, 0x1e20, 0x1e22, 0x1e24, 0x1e26, - 0x1e28, 0x1e2a, 0x1e2c, 0x1e2e, 0x1e30, 0x1e32, 0x1e34, 0x1e36, 0x1e38, - 0x1e3a, 0x1e3c, 0x1e3e, 0x1e40, 0x1e42, 0x1e44, 0x1e46, 0x1e48, 0x1e4a, - 0x1e4c, 0x1e4e, 0x1e50, 0x1e52, 0x1e54, 0x1e56, 0x1e58, 0x1e5a, 0x1e5c, - 0x1e5e, 0x1e60, 0x1e62, 0x1e64, 0x1e66, 0x1e68, 0x1e6a, 0x1e6c, 0x1e6e, - 0x1e70, 0x1e72, 0x1e74, 0x1e76, 0x1e78, 0x1e7a, 0x1e7c, 0x1e7e, 0x1e80, - 0x1e82, 0x1e84, 0x1e86, 0x1e88, 0x1e8a, 0x1e8c, 0x1e8e, 0x1e90, 0x1e92, - 0x1e94, 0x1e9e, 0x1ea0, 0x1ea2, 0x1ea4, 0x1ea6, 0x1ea8, 0x1eaa, 0x1eac, - 0x1eae, 0x1eb0, 0x1eb2, 0x1eb4, 0x1eb6, 0x1eb8, 0x1eba, 0x1ebc, 0x1ebe, - 0x1ec0, 0x1ec2, 0x1ec4, 0x1ec6, 0x1ec8, 0x1eca, 0x1ecc, 0x1ece, 0x1ed0, - 0x1ed2, 0x1ed4, 0x1ed6, 0x1ed8, 0x1eda, 0x1edc, 0x1ede, 0x1ee0, 0x1ee2, - 0x1ee4, 0x1ee6, 0x1ee8, 0x1eea, 0x1eec, 0x1eee, 0x1ef0, 0x1ef2, 0x1ef4, - 0x1ef6, 0x1ef8, 0x1efa, 0x1efc, 0x1efe, 0x1f59, 0x1f5b, 0x1f5d, 0x1f5f, - 0x2102, 0x2107, 0x2115, 0x2124, 0x2126, 0x2128, 0x213e, 0x213f, 0x2145, - 0x2183, 0x2c60, 0x2c67, 0x2c69, 0x2c6b, 0x2c72, 0x2c75, 0x2c82, 0x2c84, - 0x2c86, 0x2c88, 0x2c8a, 0x2c8c, 0x2c8e, 0x2c90, 0x2c92, 0x2c94, 0x2c96, - 0x2c98, 0x2c9a, 0x2c9c, 0x2c9e, 0x2ca0, 0x2ca2, 0x2ca4, 0x2ca6, 0x2ca8, - 0x2caa, 0x2cac, 0x2cae, 0x2cb0, 0x2cb2, 0x2cb4, 0x2cb6, 0x2cb8, 0x2cba, - 0x2cbc, 0x2cbe, 0x2cc0, 0x2cc2, 0x2cc4, 0x2cc6, 0x2cc8, 0x2cca, 0x2ccc, - 0x2cce, 0x2cd0, 0x2cd2, 0x2cd4, 0x2cd6, 0x2cd8, 0x2cda, 0x2cdc, 0x2cde, - 0x2ce0, 0x2ce2, 0x2ceb, 0x2ced, 0x2cf2, 0xa640, 0xa642, 0xa644, 0xa646, - 0xa648, 0xa64a, 0xa64c, 0xa64e, 0xa650, 0xa652, 0xa654, 0xa656, 0xa658, - 0xa65a, 0xa65c, 0xa65e, 0xa660, 0xa662, 0xa664, 0xa666, 0xa668, 0xa66a, - 0xa66c, 0xa680, 0xa682, 0xa684, 0xa686, 0xa688, 0xa68a, 0xa68c, 0xa68e, - 0xa690, 0xa692, 0xa694, 0xa696, 0xa722, 0xa724, 0xa726, 0xa728, 0xa72a, - 0xa72c, 0xa72e, 0xa732, 0xa734, 0xa736, 0xa738, 0xa73a, 0xa73c, 0xa73e, - 0xa740, 0xa742, 0xa744, 0xa746, 0xa748, 0xa74a, 0xa74c, 0xa74e, 0xa750, - 0xa752, 0xa754, 0xa756, 0xa758, 0xa75a, 0xa75c, 0xa75e, 0xa760, 0xa762, - 0xa764, 0xa766, 0xa768, 0xa76a, 0xa76c, 0xa76e, 0xa779, 0xa77b, 0xa77d, - 0xa77e, 0xa780, 0xa782, 0xa784, 0xa786, 0xa78b, 0xa78d, 0xa790, 0xa792, - 0xa7a0, 0xa7a2, 0xa7a4, 0xa7a6, 0xa7a8, 0xa7aa -#if TCL_UTF_MAX > 4 + 0x24c, 0x24e, 0x370, 0x372, 0x376, 0x37f, 0x386, 0x38c, 0x38e, + 0x38f, 0x3cf, 0x3d8, 0x3da, 0x3dc, 0x3de, 0x3e0, 0x3e2, 0x3e4, + 0x3e6, 0x3e8, 0x3ea, 0x3ec, 0x3ee, 0x3f4, 0x3f7, 0x3f9, 0x3fa, + 0x460, 0x462, 0x464, 0x466, 0x468, 0x46a, 0x46c, 0x46e, 0x470, + 0x472, 0x474, 0x476, 0x478, 0x47a, 0x47c, 0x47e, 0x480, 0x48a, + 0x48c, 0x48e, 0x490, 0x492, 0x494, 0x496, 0x498, 0x49a, 0x49c, + 0x49e, 0x4a0, 0x4a2, 0x4a4, 0x4a6, 0x4a8, 0x4aa, 0x4ac, 0x4ae, + 0x4b0, 0x4b2, 0x4b4, 0x4b6, 0x4b8, 0x4ba, 0x4bc, 0x4be, 0x4c0, + 0x4c1, 0x4c3, 0x4c5, 0x4c7, 0x4c9, 0x4cb, 0x4cd, 0x4d0, 0x4d2, + 0x4d4, 0x4d6, 0x4d8, 0x4da, 0x4dc, 0x4de, 0x4e0, 0x4e2, 0x4e4, + 0x4e6, 0x4e8, 0x4ea, 0x4ec, 0x4ee, 0x4f0, 0x4f2, 0x4f4, 0x4f6, + 0x4f8, 0x4fa, 0x4fc, 0x4fe, 0x500, 0x502, 0x504, 0x506, 0x508, + 0x50a, 0x50c, 0x50e, 0x510, 0x512, 0x514, 0x516, 0x518, 0x51a, + 0x51c, 0x51e, 0x520, 0x522, 0x524, 0x526, 0x528, 0x52a, 0x52c, + 0x52e, 0x10c7, 0x10cd, 0x1e00, 0x1e02, 0x1e04, 0x1e06, 0x1e08, 0x1e0a, + 0x1e0c, 0x1e0e, 0x1e10, 0x1e12, 0x1e14, 0x1e16, 0x1e18, 0x1e1a, 0x1e1c, + 0x1e1e, 0x1e20, 0x1e22, 0x1e24, 0x1e26, 0x1e28, 0x1e2a, 0x1e2c, 0x1e2e, + 0x1e30, 0x1e32, 0x1e34, 0x1e36, 0x1e38, 0x1e3a, 0x1e3c, 0x1e3e, 0x1e40, + 0x1e42, 0x1e44, 0x1e46, 0x1e48, 0x1e4a, 0x1e4c, 0x1e4e, 0x1e50, 0x1e52, + 0x1e54, 0x1e56, 0x1e58, 0x1e5a, 0x1e5c, 0x1e5e, 0x1e60, 0x1e62, 0x1e64, + 0x1e66, 0x1e68, 0x1e6a, 0x1e6c, 0x1e6e, 0x1e70, 0x1e72, 0x1e74, 0x1e76, + 0x1e78, 0x1e7a, 0x1e7c, 0x1e7e, 0x1e80, 0x1e82, 0x1e84, 0x1e86, 0x1e88, + 0x1e8a, 0x1e8c, 0x1e8e, 0x1e90, 0x1e92, 0x1e94, 0x1e9e, 0x1ea0, 0x1ea2, + 0x1ea4, 0x1ea6, 0x1ea8, 0x1eaa, 0x1eac, 0x1eae, 0x1eb0, 0x1eb2, 0x1eb4, + 0x1eb6, 0x1eb8, 0x1eba, 0x1ebc, 0x1ebe, 0x1ec0, 0x1ec2, 0x1ec4, 0x1ec6, + 0x1ec8, 0x1eca, 0x1ecc, 0x1ece, 0x1ed0, 0x1ed2, 0x1ed4, 0x1ed6, 0x1ed8, + 0x1eda, 0x1edc, 0x1ede, 0x1ee0, 0x1ee2, 0x1ee4, 0x1ee6, 0x1ee8, 0x1eea, + 0x1eec, 0x1eee, 0x1ef0, 0x1ef2, 0x1ef4, 0x1ef6, 0x1ef8, 0x1efa, 0x1efc, + 0x1efe, 0x1f59, 0x1f5b, 0x1f5d, 0x1f5f, 0x2102, 0x2107, 0x2115, 0x2124, + 0x2126, 0x2128, 0x213e, 0x213f, 0x2145, 0x2183, 0x2c60, 0x2c67, 0x2c69, + 0x2c6b, 0x2c72, 0x2c75, 0x2c82, 0x2c84, 0x2c86, 0x2c88, 0x2c8a, 0x2c8c, + 0x2c8e, 0x2c90, 0x2c92, 0x2c94, 0x2c96, 0x2c98, 0x2c9a, 0x2c9c, 0x2c9e, + 0x2ca0, 0x2ca2, 0x2ca4, 0x2ca6, 0x2ca8, 0x2caa, 0x2cac, 0x2cae, 0x2cb0, + 0x2cb2, 0x2cb4, 0x2cb6, 0x2cb8, 0x2cba, 0x2cbc, 0x2cbe, 0x2cc0, 0x2cc2, + 0x2cc4, 0x2cc6, 0x2cc8, 0x2cca, 0x2ccc, 0x2cce, 0x2cd0, 0x2cd2, 0x2cd4, + 0x2cd6, 0x2cd8, 0x2cda, 0x2cdc, 0x2cde, 0x2ce0, 0x2ce2, 0x2ceb, 0x2ced, + 0x2cf2, 0xa640, 0xa642, 0xa644, 0xa646, 0xa648, 0xa64a, 0xa64c, 0xa64e, + 0xa650, 0xa652, 0xa654, 0xa656, 0xa658, 0xa65a, 0xa65c, 0xa65e, 0xa660, + 0xa662, 0xa664, 0xa666, 0xa668, 0xa66a, 0xa66c, 0xa680, 0xa682, 0xa684, + 0xa686, 0xa688, 0xa68a, 0xa68c, 0xa68e, 0xa690, 0xa692, 0xa694, 0xa696, + 0xa698, 0xa69a, 0xa722, 0xa724, 0xa726, 0xa728, 0xa72a, 0xa72c, 0xa72e, + 0xa732, 0xa734, 0xa736, 0xa738, 0xa73a, 0xa73c, 0xa73e, 0xa740, 0xa742, + 0xa744, 0xa746, 0xa748, 0xa74a, 0xa74c, 0xa74e, 0xa750, 0xa752, 0xa754, + 0xa756, 0xa758, 0xa75a, 0xa75c, 0xa75e, 0xa760, 0xa762, 0xa764, 0xa766, + 0xa768, 0xa76a, 0xa76c, 0xa76e, 0xa779, 0xa77b, 0xa77d, 0xa77e, 0xa780, + 0xa782, 0xa784, 0xa786, 0xa78b, 0xa78d, 0xa790, 0xa792, 0xa796, 0xa798, + 0xa79a, 0xa79c, 0xa79e, 0xa7a0, 0xa7a2, 0xa7a4, 0xa7a6, 0xa7a8, 0xa7b6, + 0xa7b8 +#if CHRBITS > 16 ,0x1d49c, 0x1d49e, 0x1d49f, 0x1d4a2, 0x1d4a5, 0x1d4a6, 0x1d504, 0x1d505, 0x1d538, 0x1d539, 0x1d546, 0x1d7ca #endif @@ -569,141 +620,171 @@ static const chr upperCharTable[] = { */ static const crange graphRangeTable[] = { - {0x21, 0x7e}, {0xa1, 0xac}, {0xae, 0x377}, {0x37a, 0x37e}, - {0x384, 0x38a}, {0x38e, 0x3a1}, {0x3a3, 0x527}, {0x531, 0x556}, - {0x559, 0x55f}, {0x561, 0x587}, {0x591, 0x5c7}, {0x5d0, 0x5ea}, - {0x5f0, 0x5f4}, {0x606, 0x61b}, {0x61e, 0x6dc}, {0x6de, 0x70d}, - {0x710, 0x74a}, {0x74d, 0x7b1}, {0x7c0, 0x7fa}, {0x800, 0x82d}, - {0x830, 0x83e}, {0x840, 0x85b}, {0x8a2, 0x8ac}, {0x8e4, 0x8fe}, - {0x900, 0x977}, {0x979, 0x97f}, {0x981, 0x983}, {0x985, 0x98c}, + {0x21, 0x7e}, {0xa1, 0xac}, {0xae, 0x377}, {0x37a, 0x37f}, + {0x384, 0x38a}, {0x38e, 0x3a1}, {0x3a3, 0x52f}, {0x531, 0x556}, + {0x559, 0x58a}, {0x58d, 0x58f}, {0x591, 0x5c7}, {0x5d0, 0x5ea}, + {0x5ef, 0x5f4}, {0x606, 0x61b}, {0x61e, 0x6dc}, {0x6de, 0x70d}, + {0x710, 0x74a}, {0x74d, 0x7b1}, {0x7c0, 0x7fa}, {0x7fd, 0x82d}, + {0x830, 0x83e}, {0x840, 0x85b}, {0x860, 0x86a}, {0x8a0, 0x8b4}, + {0x8b6, 0x8bd}, {0x8d3, 0x8e1}, {0x8e3, 0x983}, {0x985, 0x98c}, {0x993, 0x9a8}, {0x9aa, 0x9b0}, {0x9b6, 0x9b9}, {0x9bc, 0x9c4}, - {0x9cb, 0x9ce}, {0x9df, 0x9e3}, {0x9e6, 0x9fb}, {0xa01, 0xa03}, + {0x9cb, 0x9ce}, {0x9df, 0x9e3}, {0x9e6, 0x9fe}, {0xa01, 0xa03}, {0xa05, 0xa0a}, {0xa13, 0xa28}, {0xa2a, 0xa30}, {0xa3e, 0xa42}, - {0xa4b, 0xa4d}, {0xa59, 0xa5c}, {0xa66, 0xa75}, {0xa81, 0xa83}, + {0xa4b, 0xa4d}, {0xa59, 0xa5c}, {0xa66, 0xa76}, {0xa81, 0xa83}, {0xa85, 0xa8d}, {0xa8f, 0xa91}, {0xa93, 0xaa8}, {0xaaa, 0xab0}, {0xab5, 0xab9}, {0xabc, 0xac5}, {0xac7, 0xac9}, {0xacb, 0xacd}, - {0xae0, 0xae3}, {0xae6, 0xaf1}, {0xb01, 0xb03}, {0xb05, 0xb0c}, - {0xb13, 0xb28}, {0xb2a, 0xb30}, {0xb35, 0xb39}, {0xb3c, 0xb44}, - {0xb4b, 0xb4d}, {0xb5f, 0xb63}, {0xb66, 0xb77}, {0xb85, 0xb8a}, - {0xb8e, 0xb90}, {0xb92, 0xb95}, {0xba8, 0xbaa}, {0xbae, 0xbb9}, - {0xbbe, 0xbc2}, {0xbc6, 0xbc8}, {0xbca, 0xbcd}, {0xbe6, 0xbfa}, - {0xc01, 0xc03}, {0xc05, 0xc0c}, {0xc0e, 0xc10}, {0xc12, 0xc28}, - {0xc2a, 0xc33}, {0xc35, 0xc39}, {0xc3d, 0xc44}, {0xc46, 0xc48}, - {0xc4a, 0xc4d}, {0xc60, 0xc63}, {0xc66, 0xc6f}, {0xc78, 0xc7f}, - {0xc85, 0xc8c}, {0xc8e, 0xc90}, {0xc92, 0xca8}, {0xcaa, 0xcb3}, - {0xcb5, 0xcb9}, {0xcbc, 0xcc4}, {0xcc6, 0xcc8}, {0xcca, 0xccd}, - {0xce0, 0xce3}, {0xce6, 0xcef}, {0xd05, 0xd0c}, {0xd0e, 0xd10}, - {0xd12, 0xd3a}, {0xd3d, 0xd44}, {0xd46, 0xd48}, {0xd4a, 0xd4e}, - {0xd60, 0xd63}, {0xd66, 0xd75}, {0xd79, 0xd7f}, {0xd85, 0xd96}, - {0xd9a, 0xdb1}, {0xdb3, 0xdbb}, {0xdc0, 0xdc6}, {0xdcf, 0xdd4}, - {0xdd8, 0xddf}, {0xdf2, 0xdf4}, {0xe01, 0xe3a}, {0xe3f, 0xe5b}, - {0xe94, 0xe97}, {0xe99, 0xe9f}, {0xea1, 0xea3}, {0xead, 0xeb9}, - {0xebb, 0xebd}, {0xec0, 0xec4}, {0xec8, 0xecd}, {0xed0, 0xed9}, - {0xedc, 0xedf}, {0xf00, 0xf47}, {0xf49, 0xf6c}, {0xf71, 0xf97}, - {0xf99, 0xfbc}, {0xfbe, 0xfcc}, {0xfce, 0xfda}, {0x1000, 0x10c5}, - {0x10d0, 0x1248}, {0x124a, 0x124d}, {0x1250, 0x1256}, {0x125a, 0x125d}, - {0x1260, 0x1288}, {0x128a, 0x128d}, {0x1290, 0x12b0}, {0x12b2, 0x12b5}, - {0x12b8, 0x12be}, {0x12c2, 0x12c5}, {0x12c8, 0x12d6}, {0x12d8, 0x1310}, - {0x1312, 0x1315}, {0x1318, 0x135a}, {0x135d, 0x137c}, {0x1380, 0x1399}, - {0x13a0, 0x13f4}, {0x1400, 0x167f}, {0x1681, 0x169c}, {0x16a0, 0x16f0}, + {0xae0, 0xae3}, {0xae6, 0xaf1}, {0xaf9, 0xaff}, {0xb01, 0xb03}, + {0xb05, 0xb0c}, {0xb13, 0xb28}, {0xb2a, 0xb30}, {0xb35, 0xb39}, + {0xb3c, 0xb44}, {0xb4b, 0xb4d}, {0xb5f, 0xb63}, {0xb66, 0xb77}, + {0xb85, 0xb8a}, {0xb8e, 0xb90}, {0xb92, 0xb95}, {0xba8, 0xbaa}, + {0xbae, 0xbb9}, {0xbbe, 0xbc2}, {0xbc6, 0xbc8}, {0xbca, 0xbcd}, + {0xbe6, 0xbfa}, {0xc00, 0xc0c}, {0xc0e, 0xc10}, {0xc12, 0xc28}, + {0xc2a, 0xc39}, {0xc3d, 0xc44}, {0xc46, 0xc48}, {0xc4a, 0xc4d}, + {0xc58, 0xc5a}, {0xc60, 0xc63}, {0xc66, 0xc6f}, {0xc78, 0xc8c}, + {0xc8e, 0xc90}, {0xc92, 0xca8}, {0xcaa, 0xcb3}, {0xcb5, 0xcb9}, + {0xcbc, 0xcc4}, {0xcc6, 0xcc8}, {0xcca, 0xccd}, {0xce0, 0xce3}, + {0xce6, 0xcef}, {0xd00, 0xd03}, {0xd05, 0xd0c}, {0xd0e, 0xd10}, + {0xd12, 0xd44}, {0xd46, 0xd48}, {0xd4a, 0xd4f}, {0xd54, 0xd63}, + {0xd66, 0xd7f}, {0xd85, 0xd96}, {0xd9a, 0xdb1}, {0xdb3, 0xdbb}, + {0xdc0, 0xdc6}, {0xdcf, 0xdd4}, {0xdd8, 0xddf}, {0xde6, 0xdef}, + {0xdf2, 0xdf4}, {0xe01, 0xe3a}, {0xe3f, 0xe5b}, {0xe94, 0xe97}, + {0xe99, 0xe9f}, {0xea1, 0xea3}, {0xead, 0xeb9}, {0xebb, 0xebd}, + {0xec0, 0xec4}, {0xec8, 0xecd}, {0xed0, 0xed9}, {0xedc, 0xedf}, + {0xf00, 0xf47}, {0xf49, 0xf6c}, {0xf71, 0xf97}, {0xf99, 0xfbc}, + {0xfbe, 0xfcc}, {0xfce, 0xfda}, {0x1000, 0x10c5}, {0x10d0, 0x1248}, + {0x124a, 0x124d}, {0x1250, 0x1256}, {0x125a, 0x125d}, {0x1260, 0x1288}, + {0x128a, 0x128d}, {0x1290, 0x12b0}, {0x12b2, 0x12b5}, {0x12b8, 0x12be}, + {0x12c2, 0x12c5}, {0x12c8, 0x12d6}, {0x12d8, 0x1310}, {0x1312, 0x1315}, + {0x1318, 0x135a}, {0x135d, 0x137c}, {0x1380, 0x1399}, {0x13a0, 0x13f5}, + {0x13f8, 0x13fd}, {0x1400, 0x167f}, {0x1681, 0x169c}, {0x16a0, 0x16f8}, {0x1700, 0x170c}, {0x170e, 0x1714}, {0x1720, 0x1736}, {0x1740, 0x1753}, {0x1760, 0x176c}, {0x176e, 0x1770}, {0x1780, 0x17dd}, {0x17e0, 0x17e9}, - {0x17f0, 0x17f9}, {0x1800, 0x180d}, {0x1810, 0x1819}, {0x1820, 0x1877}, - {0x1880, 0x18aa}, {0x18b0, 0x18f5}, {0x1900, 0x191c}, {0x1920, 0x192b}, + {0x17f0, 0x17f9}, {0x1800, 0x180d}, {0x1810, 0x1819}, {0x1820, 0x1878}, + {0x1880, 0x18aa}, {0x18b0, 0x18f5}, {0x1900, 0x191e}, {0x1920, 0x192b}, {0x1930, 0x193b}, {0x1944, 0x196d}, {0x1970, 0x1974}, {0x1980, 0x19ab}, {0x19b0, 0x19c9}, {0x19d0, 0x19da}, {0x19de, 0x1a1b}, {0x1a1e, 0x1a5e}, {0x1a60, 0x1a7c}, {0x1a7f, 0x1a89}, {0x1a90, 0x1a99}, {0x1aa0, 0x1aad}, - {0x1b00, 0x1b4b}, {0x1b50, 0x1b7c}, {0x1b80, 0x1bf3}, {0x1bfc, 0x1c37}, - {0x1c3b, 0x1c49}, {0x1c4d, 0x1c7f}, {0x1cc0, 0x1cc7}, {0x1cd0, 0x1cf6}, - {0x1d00, 0x1de6}, {0x1dfc, 0x1f15}, {0x1f18, 0x1f1d}, {0x1f20, 0x1f45}, - {0x1f48, 0x1f4d}, {0x1f50, 0x1f57}, {0x1f5f, 0x1f7d}, {0x1f80, 0x1fb4}, - {0x1fb6, 0x1fc4}, {0x1fc6, 0x1fd3}, {0x1fd6, 0x1fdb}, {0x1fdd, 0x1fef}, - {0x1ff2, 0x1ff4}, {0x1ff6, 0x1ffe}, {0x2010, 0x2027}, {0x2030, 0x205e}, - {0x2074, 0x208e}, {0x2090, 0x209c}, {0x20a0, 0x20ba}, {0x20d0, 0x20f0}, - {0x2100, 0x2189}, {0x2190, 0x23f3}, {0x2400, 0x2426}, {0x2440, 0x244a}, - {0x2460, 0x26ff}, {0x2701, 0x2b4c}, {0x2b50, 0x2b59}, {0x2c00, 0x2c2e}, - {0x2c30, 0x2c5e}, {0x2c60, 0x2cf3}, {0x2cf9, 0x2d25}, {0x2d30, 0x2d67}, - {0x2d7f, 0x2d96}, {0x2da0, 0x2da6}, {0x2da8, 0x2dae}, {0x2db0, 0x2db6}, - {0x2db8, 0x2dbe}, {0x2dc0, 0x2dc6}, {0x2dc8, 0x2dce}, {0x2dd0, 0x2dd6}, - {0x2dd8, 0x2dde}, {0x2de0, 0x2e3b}, {0x2e80, 0x2e99}, {0x2e9b, 0x2ef3}, - {0x2f00, 0x2fd5}, {0x2ff0, 0x2ffb}, {0x3001, 0x303f}, {0x3041, 0x3096}, - {0x3099, 0x30ff}, {0x3105, 0x312d}, {0x3131, 0x318e}, {0x3190, 0x31ba}, - {0x31c0, 0x31e3}, {0x31f0, 0x321e}, {0x3220, 0x32fe}, {0x3300, 0x4db5}, - {0x4dc0, 0x9fcc}, {0xa000, 0xa48c}, {0xa490, 0xa4c6}, {0xa4d0, 0xa62b}, - {0xa640, 0xa697}, {0xa69f, 0xa6f7}, {0xa700, 0xa78e}, {0xa790, 0xa793}, - {0xa7a0, 0xa7aa}, {0xa7f8, 0xa82b}, {0xa830, 0xa839}, {0xa840, 0xa877}, - {0xa880, 0xa8c4}, {0xa8ce, 0xa8d9}, {0xa8e0, 0xa8fb}, {0xa900, 0xa953}, - {0xa95f, 0xa97c}, {0xa980, 0xa9cd}, {0xa9cf, 0xa9d9}, {0xaa00, 0xaa36}, - {0xaa40, 0xaa4d}, {0xaa50, 0xaa59}, {0xaa5c, 0xaa7b}, {0xaa80, 0xaac2}, - {0xaadb, 0xaaf6}, {0xab01, 0xab06}, {0xab09, 0xab0e}, {0xab11, 0xab16}, - {0xab20, 0xab26}, {0xab28, 0xab2e}, {0xabc0, 0xabed}, {0xabf0, 0xabf9}, - {0xac00, 0xd7a3}, {0xd7b0, 0xd7c6}, {0xd7cb, 0xd7fb}, {0xf900, 0xfa6d}, - {0xfa70, 0xfad9}, {0xfb00, 0xfb06}, {0xfb13, 0xfb17}, {0xfb1d, 0xfb36}, - {0xfb38, 0xfb3c}, {0xfb46, 0xfbc1}, {0xfbd3, 0xfd3f}, {0xfd50, 0xfd8f}, - {0xfd92, 0xfdc7}, {0xfdf0, 0xfdfd}, {0xfe00, 0xfe19}, {0xfe20, 0xfe26}, - {0xfe30, 0xfe52}, {0xfe54, 0xfe66}, {0xfe68, 0xfe6b}, {0xfe70, 0xfe74}, - {0xfe76, 0xfefc}, {0xff01, 0xffbe}, {0xffc2, 0xffc7}, {0xffca, 0xffcf}, - {0xffd2, 0xffd7}, {0xffda, 0xffdc}, {0xffe0, 0xffe6}, {0xffe8, 0xffee} -#if TCL_UTF_MAX > 4 + {0x1ab0, 0x1abe}, {0x1b00, 0x1b4b}, {0x1b50, 0x1b7c}, {0x1b80, 0x1bf3}, + {0x1bfc, 0x1c37}, {0x1c3b, 0x1c49}, {0x1c4d, 0x1c88}, {0x1c90, 0x1cba}, + {0x1cbd, 0x1cc7}, {0x1cd0, 0x1cf9}, {0x1d00, 0x1df9}, {0x1dfb, 0x1f15}, + {0x1f18, 0x1f1d}, {0x1f20, 0x1f45}, {0x1f48, 0x1f4d}, {0x1f50, 0x1f57}, + {0x1f5f, 0x1f7d}, {0x1f80, 0x1fb4}, {0x1fb6, 0x1fc4}, {0x1fc6, 0x1fd3}, + {0x1fd6, 0x1fdb}, {0x1fdd, 0x1fef}, {0x1ff2, 0x1ff4}, {0x1ff6, 0x1ffe}, + {0x2010, 0x2027}, {0x2030, 0x205e}, {0x2074, 0x208e}, {0x2090, 0x209c}, + {0x20a0, 0x20bf}, {0x20d0, 0x20f0}, {0x2100, 0x218b}, {0x2190, 0x2426}, + {0x2440, 0x244a}, {0x2460, 0x2b73}, {0x2b76, 0x2b95}, {0x2b98, 0x2bc8}, + {0x2bca, 0x2bfe}, {0x2c00, 0x2c2e}, {0x2c30, 0x2c5e}, {0x2c60, 0x2cf3}, + {0x2cf9, 0x2d25}, {0x2d30, 0x2d67}, {0x2d7f, 0x2d96}, {0x2da0, 0x2da6}, + {0x2da8, 0x2dae}, {0x2db0, 0x2db6}, {0x2db8, 0x2dbe}, {0x2dc0, 0x2dc6}, + {0x2dc8, 0x2dce}, {0x2dd0, 0x2dd6}, {0x2dd8, 0x2dde}, {0x2de0, 0x2e4e}, + {0x2e80, 0x2e99}, {0x2e9b, 0x2ef3}, {0x2f00, 0x2fd5}, {0x2ff0, 0x2ffb}, + {0x3001, 0x303f}, {0x3041, 0x3096}, {0x3099, 0x30ff}, {0x3105, 0x312f}, + {0x3131, 0x318e}, {0x3190, 0x31ba}, {0x31c0, 0x31e3}, {0x31f0, 0x321e}, + {0x3220, 0x32fe}, {0x3300, 0x4db5}, {0x4dc0, 0x9fef}, {0xa000, 0xa48c}, + {0xa490, 0xa4c6}, {0xa4d0, 0xa62b}, {0xa640, 0xa6f7}, {0xa700, 0xa7b9}, + {0xa7f7, 0xa82b}, {0xa830, 0xa839}, {0xa840, 0xa877}, {0xa880, 0xa8c5}, + {0xa8ce, 0xa8d9}, {0xa8e0, 0xa953}, {0xa95f, 0xa97c}, {0xa980, 0xa9cd}, + {0xa9cf, 0xa9d9}, {0xa9de, 0xa9fe}, {0xaa00, 0xaa36}, {0xaa40, 0xaa4d}, + {0xaa50, 0xaa59}, {0xaa5c, 0xaac2}, {0xaadb, 0xaaf6}, {0xab01, 0xab06}, + {0xab09, 0xab0e}, {0xab11, 0xab16}, {0xab20, 0xab26}, {0xab28, 0xab2e}, + {0xab30, 0xab65}, {0xab70, 0xabed}, {0xabf0, 0xabf9}, {0xac00, 0xd7a3}, + {0xd7b0, 0xd7c6}, {0xd7cb, 0xd7fb}, {0xf900, 0xfa6d}, {0xfa70, 0xfad9}, + {0xfb00, 0xfb06}, {0xfb13, 0xfb17}, {0xfb1d, 0xfb36}, {0xfb38, 0xfb3c}, + {0xfb46, 0xfbc1}, {0xfbd3, 0xfd3f}, {0xfd50, 0xfd8f}, {0xfd92, 0xfdc7}, + {0xfdf0, 0xfdfd}, {0xfe00, 0xfe19}, {0xfe20, 0xfe52}, {0xfe54, 0xfe66}, + {0xfe68, 0xfe6b}, {0xfe70, 0xfe74}, {0xfe76, 0xfefc}, {0xff01, 0xffbe}, + {0xffc2, 0xffc7}, {0xffca, 0xffcf}, {0xffd2, 0xffd7}, {0xffda, 0xffdc}, + {0xffe0, 0xffe6}, {0xffe8, 0xffee} +#if CHRBITS > 16 ,{0x10000, 0x1000b}, {0x1000d, 0x10026}, {0x10028, 0x1003a}, {0x1003f, 0x1004d}, {0x10050, 0x1005d}, {0x10080, 0x100fa}, {0x10100, 0x10102}, {0x10107, 0x10133}, - {0x10137, 0x1018a}, {0x10190, 0x1019b}, {0x101d0, 0x101fd}, {0x10280, 0x1029c}, - {0x102a0, 0x102d0}, {0x10300, 0x1031e}, {0x10320, 0x10323}, {0x10330, 0x1034a}, - {0x10380, 0x1039d}, {0x1039f, 0x103c3}, {0x103c8, 0x103d5}, {0x10400, 0x1049d}, - {0x104a0, 0x104a9}, {0x10800, 0x10805}, {0x1080a, 0x10835}, {0x1083f, 0x10855}, - {0x10857, 0x1085f}, {0x10900, 0x1091b}, {0x1091f, 0x10939}, {0x10980, 0x109b7}, - {0x10a00, 0x10a03}, {0x10a0c, 0x10a13}, {0x10a15, 0x10a17}, {0x10a19, 0x10a33}, - {0x10a38, 0x10a3a}, {0x10a3f, 0x10a47}, {0x10a50, 0x10a58}, {0x10a60, 0x10a7f}, - {0x10b00, 0x10b35}, {0x10b39, 0x10b55}, {0x10b58, 0x10b72}, {0x10b78, 0x10b7f}, - {0x10c00, 0x10c48}, {0x10e60, 0x10e7e}, {0x11000, 0x1104d}, {0x11052, 0x1106f}, - {0x11080, 0x110bc}, {0x110be, 0x110c1}, {0x110d0, 0x110e8}, {0x110f0, 0x110f9}, - {0x11100, 0x11134}, {0x11136, 0x11143}, {0x11180, 0x111c8}, {0x111d0, 0x111d9}, - {0x11680, 0x116b7}, {0x116c0, 0x116c9}, {0x12000, 0x1236e}, {0x12400, 0x12462}, - {0x12470, 0x12473}, {0x13000, 0x1342e}, {0x16800, 0x16a38}, {0x16f00, 0x16f44}, - {0x16f50, 0x16f7e}, {0x16f8f, 0x16f9f}, {0x1d000, 0x1d0f5}, {0x1d100, 0x1d126}, - {0x1d129, 0x1d172}, {0x1d17b, 0x1d1dd}, {0x1d200, 0x1d245}, {0x1d300, 0x1d356}, - {0x1d360, 0x1d371}, {0x1d400, 0x1d454}, {0x1d456, 0x1d49c}, {0x1d4a9, 0x1d4ac}, + {0x10137, 0x1018e}, {0x10190, 0x1019b}, {0x101d0, 0x101fd}, {0x10280, 0x1029c}, + {0x102a0, 0x102d0}, {0x102e0, 0x102fb}, {0x10300, 0x10323}, {0x1032d, 0x1034a}, + {0x10350, 0x1037a}, {0x10380, 0x1039d}, {0x1039f, 0x103c3}, {0x103c8, 0x103d5}, + {0x10400, 0x1049d}, {0x104a0, 0x104a9}, {0x104b0, 0x104d3}, {0x104d8, 0x104fb}, + {0x10500, 0x10527}, {0x10530, 0x10563}, {0x10600, 0x10736}, {0x10740, 0x10755}, + {0x10760, 0x10767}, {0x10800, 0x10805}, {0x1080a, 0x10835}, {0x1083f, 0x10855}, + {0x10857, 0x1089e}, {0x108a7, 0x108af}, {0x108e0, 0x108f2}, {0x108fb, 0x1091b}, + {0x1091f, 0x10939}, {0x10980, 0x109b7}, {0x109bc, 0x109cf}, {0x109d2, 0x10a03}, + {0x10a0c, 0x10a13}, {0x10a15, 0x10a17}, {0x10a19, 0x10a35}, {0x10a38, 0x10a3a}, + {0x10a3f, 0x10a48}, {0x10a50, 0x10a58}, {0x10a60, 0x10a9f}, {0x10ac0, 0x10ae6}, + {0x10aeb, 0x10af6}, {0x10b00, 0x10b35}, {0x10b39, 0x10b55}, {0x10b58, 0x10b72}, + {0x10b78, 0x10b91}, {0x10b99, 0x10b9c}, {0x10ba9, 0x10baf}, {0x10c00, 0x10c48}, + {0x10c80, 0x10cb2}, {0x10cc0, 0x10cf2}, {0x10cfa, 0x10d27}, {0x10d30, 0x10d39}, + {0x10e60, 0x10e7e}, {0x10f00, 0x10f27}, {0x10f30, 0x10f59}, {0x11000, 0x1104d}, + {0x11052, 0x1106f}, {0x1107f, 0x110bc}, {0x110be, 0x110c1}, {0x110d0, 0x110e8}, + {0x110f0, 0x110f9}, {0x11100, 0x11134}, {0x11136, 0x11146}, {0x11150, 0x11176}, + {0x11180, 0x111cd}, {0x111d0, 0x111df}, {0x111e1, 0x111f4}, {0x11200, 0x11211}, + {0x11213, 0x1123e}, {0x11280, 0x11286}, {0x1128a, 0x1128d}, {0x1128f, 0x1129d}, + {0x1129f, 0x112a9}, {0x112b0, 0x112ea}, {0x112f0, 0x112f9}, {0x11300, 0x11303}, + {0x11305, 0x1130c}, {0x11313, 0x11328}, {0x1132a, 0x11330}, {0x11335, 0x11339}, + {0x1133b, 0x11344}, {0x1134b, 0x1134d}, {0x1135d, 0x11363}, {0x11366, 0x1136c}, + {0x11370, 0x11374}, {0x11400, 0x11459}, {0x11480, 0x114c7}, {0x114d0, 0x114d9}, + {0x11580, 0x115b5}, {0x115b8, 0x115dd}, {0x11600, 0x11644}, {0x11650, 0x11659}, + {0x11660, 0x1166c}, {0x11680, 0x116b7}, {0x116c0, 0x116c9}, {0x11700, 0x1171a}, + {0x1171d, 0x1172b}, {0x11730, 0x1173f}, {0x11800, 0x1183b}, {0x118a0, 0x118f2}, + {0x11a00, 0x11a47}, {0x11a50, 0x11a83}, {0x11a86, 0x11aa2}, {0x11ac0, 0x11af8}, + {0x11c00, 0x11c08}, {0x11c0a, 0x11c36}, {0x11c38, 0x11c45}, {0x11c50, 0x11c6c}, + {0x11c70, 0x11c8f}, {0x11c92, 0x11ca7}, {0x11ca9, 0x11cb6}, {0x11d00, 0x11d06}, + {0x11d0b, 0x11d36}, {0x11d3f, 0x11d47}, {0x11d50, 0x11d59}, {0x11d60, 0x11d65}, + {0x11d6a, 0x11d8e}, {0x11d93, 0x11d98}, {0x11da0, 0x11da9}, {0x11ee0, 0x11ef8}, + {0x12000, 0x12399}, {0x12400, 0x1246e}, {0x12470, 0x12474}, {0x12480, 0x12543}, + {0x13000, 0x1342e}, {0x14400, 0x14646}, {0x16800, 0x16a38}, {0x16a40, 0x16a5e}, + {0x16a60, 0x16a69}, {0x16ad0, 0x16aed}, {0x16af0, 0x16af5}, {0x16b00, 0x16b45}, + {0x16b50, 0x16b59}, {0x16b5b, 0x16b61}, {0x16b63, 0x16b77}, {0x16b7d, 0x16b8f}, + {0x16e40, 0x16e9a}, {0x16f00, 0x16f44}, {0x16f50, 0x16f7e}, {0x16f8f, 0x16f9f}, + {0x17000, 0x187f1}, {0x18800, 0x18af2}, {0x1b000, 0x1b11e}, {0x1b170, 0x1b2fb}, + {0x1bc00, 0x1bc6a}, {0x1bc70, 0x1bc7c}, {0x1bc80, 0x1bc88}, {0x1bc90, 0x1bc99}, + {0x1bc9c, 0x1bc9f}, {0x1d000, 0x1d0f5}, {0x1d100, 0x1d126}, {0x1d129, 0x1d172}, + {0x1d17b, 0x1d1e8}, {0x1d200, 0x1d245}, {0x1d2e0, 0x1d2f3}, {0x1d300, 0x1d356}, + {0x1d360, 0x1d378}, {0x1d400, 0x1d454}, {0x1d456, 0x1d49c}, {0x1d4a9, 0x1d4ac}, {0x1d4ae, 0x1d4b9}, {0x1d4bd, 0x1d4c3}, {0x1d4c5, 0x1d505}, {0x1d507, 0x1d50a}, {0x1d50d, 0x1d514}, {0x1d516, 0x1d51c}, {0x1d51e, 0x1d539}, {0x1d53b, 0x1d53e}, {0x1d540, 0x1d544}, {0x1d54a, 0x1d550}, {0x1d552, 0x1d6a5}, {0x1d6a8, 0x1d7cb}, - {0x1d7ce, 0x1d7ff}, {0x1ee00, 0x1ee03}, {0x1ee05, 0x1ee1f}, {0x1ee29, 0x1ee32}, - {0x1ee34, 0x1ee37}, {0x1ee4d, 0x1ee4f}, {0x1ee67, 0x1ee6a}, {0x1ee6c, 0x1ee72}, - {0x1ee74, 0x1ee77}, {0x1ee79, 0x1ee7c}, {0x1ee80, 0x1ee89}, {0x1ee8b, 0x1ee9b}, - {0x1eea1, 0x1eea3}, {0x1eea5, 0x1eea9}, {0x1eeab, 0x1eebb}, {0x1f000, 0x1f02b}, - {0x1f030, 0x1f093}, {0x1f0a0, 0x1f0ae}, {0x1f0b1, 0x1f0be}, {0x1f0c1, 0x1f0cf}, - {0x1f0d1, 0x1f0df}, {0x1f100, 0x1f10a}, {0x1f110, 0x1f12e}, {0x1f130, 0x1f16b}, - {0x1f170, 0x1f19a}, {0x1f1e6, 0x1f202}, {0x1f210, 0x1f23a}, {0x1f240, 0x1f248}, - {0x1f300, 0x1f320}, {0x1f330, 0x1f335}, {0x1f337, 0x1f37c}, {0x1f380, 0x1f393}, - {0x1f3a0, 0x1f3c4}, {0x1f3c6, 0x1f3ca}, {0x1f3e0, 0x1f3f0}, {0x1f400, 0x1f43e}, - {0x1f442, 0x1f4f7}, {0x1f4f9, 0x1f4fc}, {0x1f500, 0x1f53d}, {0x1f540, 0x1f543}, - {0x1f550, 0x1f567}, {0x1f5fb, 0x1f640}, {0x1f645, 0x1f64f}, {0x1f680, 0x1f6c5}, - {0x1f700, 0x1f773}, {0x20000, 0x2a6d6}, {0x2a700, 0x2b734}, {0x2b740, 0x2b81d}, - {0x2f800, 0x2fa1d}, {0xe0100, 0xe01ef} + {0x1d7ce, 0x1da8b}, {0x1da9b, 0x1da9f}, {0x1daa1, 0x1daaf}, {0x1e000, 0x1e006}, + {0x1e008, 0x1e018}, {0x1e01b, 0x1e021}, {0x1e026, 0x1e02a}, {0x1e800, 0x1e8c4}, + {0x1e8c7, 0x1e8d6}, {0x1e900, 0x1e94a}, {0x1e950, 0x1e959}, {0x1ec71, 0x1ecb4}, + {0x1ee00, 0x1ee03}, {0x1ee05, 0x1ee1f}, {0x1ee29, 0x1ee32}, {0x1ee34, 0x1ee37}, + {0x1ee4d, 0x1ee4f}, {0x1ee67, 0x1ee6a}, {0x1ee6c, 0x1ee72}, {0x1ee74, 0x1ee77}, + {0x1ee79, 0x1ee7c}, {0x1ee80, 0x1ee89}, {0x1ee8b, 0x1ee9b}, {0x1eea1, 0x1eea3}, + {0x1eea5, 0x1eea9}, {0x1eeab, 0x1eebb}, {0x1f000, 0x1f02b}, {0x1f030, 0x1f093}, + {0x1f0a0, 0x1f0ae}, {0x1f0b1, 0x1f0bf}, {0x1f0c1, 0x1f0cf}, {0x1f0d1, 0x1f0f5}, + {0x1f100, 0x1f10c}, {0x1f110, 0x1f16b}, {0x1f170, 0x1f1ac}, {0x1f1e6, 0x1f202}, + {0x1f210, 0x1f23b}, {0x1f240, 0x1f248}, {0x1f260, 0x1f265}, {0x1f300, 0x1f6d4}, + {0x1f6e0, 0x1f6ec}, {0x1f6f0, 0x1f6f9}, {0x1f700, 0x1f773}, {0x1f780, 0x1f7d8}, + {0x1f800, 0x1f80b}, {0x1f810, 0x1f847}, {0x1f850, 0x1f859}, {0x1f860, 0x1f887}, + {0x1f890, 0x1f8ad}, {0x1f900, 0x1f90b}, {0x1f910, 0x1f93e}, {0x1f940, 0x1f970}, + {0x1f973, 0x1f976}, {0x1f97c, 0x1f9a2}, {0x1f9b0, 0x1f9b9}, {0x1f9c0, 0x1f9c2}, + {0x1f9d0, 0x1f9ff}, {0x1fa60, 0x1fa6d}, {0x20000, 0x2a6d6}, {0x2a700, 0x2b734}, + {0x2b740, 0x2b81d}, {0x2b820, 0x2cea1}, {0x2ceb0, 0x2ebe0}, {0x2f800, 0x2fa1d}, + {0xe0100, 0xe01ef} #endif }; #define NUM_GRAPH_RANGE (sizeof(graphRangeTable)/sizeof(crange)) static const chr graphCharTable[] = { - 0x38c, 0x589, 0x58a, 0x58f, 0x85e, 0x8a0, 0x98f, 0x990, 0x9b2, - 0x9c7, 0x9c8, 0x9d7, 0x9dc, 0x9dd, 0xa0f, 0xa10, 0xa32, 0xa33, - 0xa35, 0xa36, 0xa38, 0xa39, 0xa3c, 0xa47, 0xa48, 0xa51, 0xa5e, - 0xab2, 0xab3, 0xad0, 0xb0f, 0xb10, 0xb32, 0xb33, 0xb47, 0xb48, - 0xb56, 0xb57, 0xb5c, 0xb5d, 0xb82, 0xb83, 0xb99, 0xb9a, 0xb9c, - 0xb9e, 0xb9f, 0xba3, 0xba4, 0xbd0, 0xbd7, 0xc55, 0xc56, 0xc58, - 0xc59, 0xc82, 0xc83, 0xcd5, 0xcd6, 0xcde, 0xcf1, 0xcf2, 0xd02, - 0xd03, 0xd57, 0xd82, 0xd83, 0xdbd, 0xdca, 0xdd6, 0xe81, 0xe82, - 0xe84, 0xe87, 0xe88, 0xe8a, 0xe8d, 0xea5, 0xea7, 0xeaa, 0xeab, - 0xec6, 0x10c7, 0x10cd, 0x1258, 0x12c0, 0x1772, 0x1773, 0x1940, 0x1f59, - 0x1f5b, 0x1f5d, 0x2070, 0x2071, 0x2d27, 0x2d2d, 0x2d6f, 0x2d70, 0xa9de, - 0xa9df, 0xfb3e, 0xfb40, 0xfb41, 0xfb43, 0xfb44, 0xfffc, 0xfffd -#if TCL_UTF_MAX > 4 - ,0x1003c, 0x1003d, 0x10808, 0x10837, 0x10838, 0x1083c, 0x1093f, 0x109be, 0x109bf, - 0x10a05, 0x10a06, 0x1b000, 0x1b001, 0x1d49e, 0x1d49f, 0x1d4a2, 0x1d4a5, 0x1d4a6, - 0x1d4bb, 0x1d546, 0x1ee21, 0x1ee22, 0x1ee24, 0x1ee27, 0x1ee39, 0x1ee3b, 0x1ee42, - 0x1ee47, 0x1ee49, 0x1ee4b, 0x1ee51, 0x1ee52, 0x1ee54, 0x1ee57, 0x1ee59, 0x1ee5b, - 0x1ee5d, 0x1ee5f, 0x1ee61, 0x1ee62, 0x1ee64, 0x1ee7e, 0x1eef0, 0x1eef1, 0x1f250, - 0x1f251, 0x1f440 + 0x38c, 0x85e, 0x98f, 0x990, 0x9b2, 0x9c7, 0x9c8, 0x9d7, 0x9dc, + 0x9dd, 0xa0f, 0xa10, 0xa32, 0xa33, 0xa35, 0xa36, 0xa38, 0xa39, + 0xa3c, 0xa47, 0xa48, 0xa51, 0xa5e, 0xab2, 0xab3, 0xad0, 0xb0f, + 0xb10, 0xb32, 0xb33, 0xb47, 0xb48, 0xb56, 0xb57, 0xb5c, 0xb5d, + 0xb82, 0xb83, 0xb99, 0xb9a, 0xb9c, 0xb9e, 0xb9f, 0xba3, 0xba4, + 0xbd0, 0xbd7, 0xc55, 0xc56, 0xcd5, 0xcd6, 0xcde, 0xcf1, 0xcf2, + 0xd82, 0xd83, 0xdbd, 0xdca, 0xdd6, 0xe81, 0xe82, 0xe84, 0xe87, + 0xe88, 0xe8a, 0xe8d, 0xea5, 0xea7, 0xeaa, 0xeab, 0xec6, 0x10c7, + 0x10cd, 0x1258, 0x12c0, 0x1772, 0x1773, 0x1940, 0x1f59, 0x1f5b, 0x1f5d, + 0x2070, 0x2071, 0x2d27, 0x2d2d, 0x2d6f, 0x2d70, 0xfb3e, 0xfb40, 0xfb41, + 0xfb43, 0xfb44, 0xfffc, 0xfffd +#if CHRBITS > 16 + ,0x1003c, 0x1003d, 0x101a0, 0x1056f, 0x10808, 0x10837, 0x10838, 0x1083c, 0x108f4, + 0x108f5, 0x1093f, 0x10a05, 0x10a06, 0x11288, 0x1130f, 0x11310, 0x11332, 0x11333, + 0x11347, 0x11348, 0x11350, 0x11357, 0x1145b, 0x1145d, 0x1145e, 0x118ff, 0x11d08, + 0x11d09, 0x11d3a, 0x11d3c, 0x11d3d, 0x11d67, 0x11d68, 0x11d90, 0x11d91, 0x16a6e, + 0x16a6f, 0x16fe0, 0x16fe1, 0x1d49e, 0x1d49f, 0x1d4a2, 0x1d4a5, 0x1d4a6, 0x1d4bb, + 0x1d546, 0x1e023, 0x1e024, 0x1e95e, 0x1e95f, 0x1ee21, 0x1ee22, 0x1ee24, 0x1ee27, + 0x1ee39, 0x1ee3b, 0x1ee42, 0x1ee47, 0x1ee49, 0x1ee4b, 0x1ee51, 0x1ee52, 0x1ee54, + 0x1ee57, 0x1ee59, 0x1ee5b, 0x1ee5d, 0x1ee5f, 0x1ee61, 0x1ee62, 0x1ee64, 0x1ee7e, + 0x1eef0, 0x1eef1, 0x1f250, 0x1f251, 0x1f97a #endif }; @@ -1159,7 +1240,7 @@ cmp( const chr *x, const chr *y, /* strings to compare */ size_t len) /* exact length of comparison */ { - return memcmp(VS(x), VS(y), len*sizeof(chr)); + return memcmp((void*)(x), (void*)(y), len*sizeof(chr)); } /* diff --git a/generic/regc_nfa.c b/generic/regc_nfa.c index 42489dd..240fcfe 100644 --- a/generic/regc_nfa.c +++ b/generic/regc_nfa.c @@ -34,6 +34,9 @@ #define NISERR() VISERR(nfa->v) #define NERR(e) VERR(nfa->v, (e)) +#define STACK_TOO_DEEP(x) (0) +#define CANCEL_REQUESTED(x) (0) +#define REG_CANCEL 777 /* - newnfa - set up an NFA @@ -49,6 +52,7 @@ newnfa( nfa = (struct nfa *) MALLOC(sizeof(struct nfa)); if (nfa == NULL) { + ERR(REG_ESPACE); return NULL; } @@ -58,7 +62,6 @@ newnfa( nfa->nstates = 0; nfa->cm = cm; nfa->v = v; - nfa->size = 0; nfa->bos[0] = nfa->bos[1] = COLORLESS; nfa->eos[0] = nfa->eos[1] = COLORLESS; nfa->parent = parent; /* Precedes newfstate so parent is valid. */ @@ -86,61 +89,6 @@ newnfa( } /* - - TooManyStates - checks if the max states exceeds the compile-time value - ^ static int TooManyStates(struct nfa *); - */ -static int -TooManyStates( - struct nfa *nfa) -{ - struct nfa *parent = nfa->parent; - size_t sz = nfa->size; - - while (parent != NULL) { - sz = parent->size; - parent = parent->parent; - } - if (sz > REG_MAX_STATES) { - return 1; - } - return 0; -} - -/* - - IncrementSize - increases the tracked size of the NFA and its parents. - ^ static void IncrementSize(struct nfa *); - */ -static void -IncrementSize( - struct nfa *nfa) -{ - struct nfa *parent = nfa->parent; - - nfa->size++; - while (parent != NULL) { - parent->size++; - parent = parent->parent; - } -} - -/* - - DecrementSize - increases the tracked size of the NFA and its parents. - ^ static void DecrementSize(struct nfa *); - */ -static void -DecrementSize( - struct nfa *nfa) -{ - struct nfa *parent = nfa->parent; - - nfa->size--; - while (parent != NULL) { - parent->size--; - parent = parent->parent; - } -} - -/* - freenfa - free an entire NFA ^ static void freenfa(struct nfa *); */ @@ -176,20 +124,20 @@ newstate( { struct state *s; - if (TooManyStates(nfa)) { - /* XXX: add specific error for this */ - NERR(REG_ETOOBIG); - return NULL; - } if (nfa->free != NULL) { s = nfa->free; nfa->free = s->next; } else { + if (nfa->v->spaceused >= REG_MAX_COMPILE_SPACE) { + NERR(REG_ETOOBIG); + return NULL; + } s = (struct state *) MALLOC(sizeof(struct state)); if (s == NULL) { NERR(REG_ESPACE); return NULL; } + nfa->v->spaceused += sizeof(struct state); s->oas.next = NULL; s->free = NULL; s->noas = 0; @@ -213,12 +161,6 @@ newstate( } s->prev = nfa->slast; nfa->slast = s; - - /* - * Track the current size and the parent size. - */ - - IncrementSize(nfa); return s; } @@ -289,7 +231,6 @@ freestate( s->prev = NULL; s->next = nfa->free; /* don't delete it, put it on the free list */ nfa->free = s; - DecrementSize(nfa); } /* @@ -308,11 +249,13 @@ destroystate( for (ab=s->oas.next ; ab!=NULL ; ab=abnext) { abnext = ab->next; FREE(ab); + nfa->v->spaceused -= sizeof(struct arcbatch); } s->ins = NULL; s->outs = NULL; s->next = NULL; FREE(s); + nfa->v->spaceused -= sizeof(struct state); } /* @@ -320,6 +263,10 @@ destroystate( ^ static void newarc(struct nfa *, int, pcolor, struct state *, ^ struct state *); */ +/* + * This function checks to make sure that no duplicate arcs are created. + * In general we never want duplicates. + */ static void newarc( struct nfa *nfa, @@ -332,16 +279,42 @@ newarc( assert(from != NULL && to != NULL); - /* - * Check for duplicates. - */ - - for (a=from->outs ; a!=NULL ; a=a->outchain) { - if (a->to == to && a->co == co && a->type == t) { - return; + /* check for duplicate arc, using whichever chain is shorter */ + if (from->nouts <= to->nins) { + for (a = from->outs; a != NULL; a = a->outchain) { + if (a->to == to && a->co == co && a->type == t) { + return; + } + } + } else { + for (a = to->ins; a != NULL; a = a->inchain) { + if (a->from == from && a->co == co && a->type == t) { + return; + } } } + /* no dup, so create the arc */ + createarc(nfa, t, co, from, to); +} + +/* + * createarc - create a new arc within an NFA + * + * This function must *only* be used after verifying that there is no existing + * identical arc (same type/color/from/to). + */ +static void +createarc( + struct nfa * nfa, + int t, + pcolor co, + struct state * from, + struct state * to) +{ + struct arc *a; + + /* the arc is physically allocated within its from-state */ a = allocarc(nfa, from); if (NISERR()) { return; @@ -354,15 +327,21 @@ newarc( a->from = from; /* - * Put the new arc on the beginning, not the end, of the chains. Not only - * is this easier, it has the very useful side effect that deleting the - * most-recently-added arc is the cheapest case rather than the most - * expensive one. + * Put the new arc on the beginning, not the end, of the chains; it's + * simpler here, and freearc() is the same cost either way. See also the + * logic in moveins() and its cohorts, as well as fixempties(). */ - a->inchain = to->ins; + a->inchainRev = NULL; + if (to->ins) { + to->ins->inchainRev = a; + } to->ins = a; a->outchain = from->outs; + a->outchainRev = NULL; + if (from->outs) { + from->outs->outchainRev = a; + } from->outs = a; from->nouts++; @@ -399,14 +378,19 @@ allocarc( */ if (s->free == NULL) { - struct arcbatch *newAb = (struct arcbatch *) - MALLOC(sizeof(struct arcbatch)); + struct arcbatch *newAb; int i; + if (nfa->v->spaceused >= REG_MAX_COMPILE_SPACE) { + NERR(REG_ETOOBIG); + return NULL; + } + newAb = (struct arcbatch *) MALLOC(sizeof(struct arcbatch)); if (newAb == NULL) { NERR(REG_ESPACE); return NULL; } + nfa->v->spaceused += sizeof(struct arcbatch); newAb->next = s->oas.next; s->oas.next = newAb; @@ -435,7 +419,7 @@ freearc( { struct state *from = victim->from; struct state *to = victim->to; - struct arc *a; + struct arc *predecessor; assert(victim->type != 0); @@ -452,16 +436,17 @@ freearc( */ assert(from != NULL); - assert(from->outs != NULL); - a = from->outs; - if (a == victim) { /* simple case: first in chain */ + predecessor = victim->outchainRev; + if (predecessor == NULL) { + assert(from->outs == victim); from->outs = victim->outchain; } else { - for (; a!=NULL && a->outchain!=victim ; a=a->outchain) { - continue; - } - assert(a != NULL); - a->outchain = victim->outchain; + assert(predecessor->outchain == victim); + predecessor->outchain = victim->outchain; + } + if (victim->outchain != NULL) { + assert(victim->outchain->outchainRev == victim); + victim->outchain->outchainRev = predecessor; } from->nouts--; @@ -470,86 +455,95 @@ freearc( */ assert(to != NULL); - assert(to->ins != NULL); - a = to->ins; - if (a == victim) { /* simple case: first in chain */ + predecessor = victim->inchainRev; + if (predecessor == NULL) { + assert(to->ins == victim); to->ins = victim->inchain; } else { - for (; a->inchain!=victim ; a=a->inchain) { - assert(a->inchain != NULL); - continue; - } - a->inchain = victim->inchain; + assert(predecessor->inchain == victim); + predecessor->inchain = victim->inchain; + } + if (victim->inchain != NULL) { + assert(victim->inchain->inchainRev == victim); + victim->inchain->inchainRev = predecessor; } to->nins--; /* - * Clean up and place on free list. + * Clean up and place on from-state's free list. */ victim->type = 0; victim->from = NULL; /* precautions... */ victim->to = NULL; victim->inchain = NULL; + victim->inchainRev = NULL; victim->outchain = NULL; + victim->outchainRev = NULL; victim->freechain = from->free; from->free = victim; } - + /* - - hasnonemptyout - Does state have a non-EMPTY out arc? - ^ static int hasnonemptyout(struct state *); + * changearctarget - flip an arc to have a different to state + * + * Caller must have verified that there is no pre-existing duplicate arc. + * + * Note that because we store arcs in their from state, we can't easily have + * a similar changearcsource function. */ -static int -hasnonemptyout( - struct state *s) +static void +changearctarget(struct arc * a, struct state * newto) { - struct arc *a; + struct state *oldto = a->to; + struct arc *predecessor; - for (a = s->outs; a != NULL; a = a->outchain) { - if (a->type != EMPTY) { - return 1; - } + assert(oldto != newto); + + /* take it off old target's in-chain */ + assert(oldto != NULL); + predecessor = a->inchainRev; + if (predecessor == NULL) { + assert(oldto->ins == a); + oldto->ins = a->inchain; + } else { + assert(predecessor->inchain == a); + predecessor->inchain = a->inchain; } - return 0; -} - -/* - - nonemptyouts - count non-EMPTY out arcs of a state - ^ static int nonemptyouts(struct state *); - */ -static int -nonemptyouts( - struct state *s) -{ - int n = 0; - struct arc *a; + if (a->inchain != NULL) { + assert(a->inchain->inchainRev == a); + a->inchain->inchainRev = predecessor; + } + oldto->nins--; - for (a = s->outs; a != NULL; a = a->outchain) { - if (a->type != EMPTY) { - n++; - } + a->to = newto; + + /* prepend it to new target's in-chain */ + a->inchain = newto->ins; + a->inchainRev = NULL; + if (newto->ins) { + newto->ins->inchainRev = a; } - return n; + newto->ins = a; + newto->nins++; } /* - - nonemptyins - count non-EMPTY in arcs of a state - ^ static int nonemptyins(struct state *); + - hasnonemptyout - Does state have a non-EMPTY out arc? + ^ static int hasnonemptyout(struct state *); */ static int -nonemptyins( +hasnonemptyout( struct state *s) { - int n = 0; struct arc *a; - for (a = s->ins; a != NULL; a = a->inchain) { + for (a = s->outs; a != NULL; a = a->outchain) { if (a->type != EMPTY) { - n++; + return 1; } } - return n; + return 0; } /* @@ -587,13 +581,181 @@ cparc( { newarc(nfa, oa->type, oa->co, from, to); } + +/* + * sortins - sort the in arcs of a state by from/color/type + */ +static void +sortins( + struct nfa * nfa, + struct state * s) +{ + struct arc **sortarray; + struct arc *a; + int n = s->nins; + int i; + + if (n <= 1) { + return; /* nothing to do */ + } + /* make an array of arc pointers ... */ + sortarray = (struct arc **) MALLOC(n * sizeof(struct arc *)); + if (sortarray == NULL) { + NERR(REG_ESPACE); + return; + } + i = 0; + for (a = s->ins; a != NULL; a = a->inchain) { + sortarray[i++] = a; + } + assert(i == n); + /* ... sort the array */ + qsort(sortarray, n, sizeof(struct arc *), sortins_cmp); + /* ... and rebuild arc list in order */ + /* it seems worth special-casing first and last items to simplify loop */ + a = sortarray[0]; + s->ins = a; + a->inchain = sortarray[1]; + a->inchainRev = NULL; + for (i = 1; i < n - 1; i++) { + a = sortarray[i]; + a->inchain = sortarray[i + 1]; + a->inchainRev = sortarray[i - 1]; + } + a = sortarray[i]; + a->inchain = NULL; + a->inchainRev = sortarray[i - 1]; + FREE(sortarray); +} + +static int +sortins_cmp( + const void *a, + const void *b) +{ + const struct arc *aa = *((const struct arc * const *) a); + const struct arc *bb = *((const struct arc * const *) b); + + /* we check the fields in the order they are most likely to be different */ + if (aa->from->no < bb->from->no) { + return -1; + } + if (aa->from->no > bb->from->no) { + return 1; + } + if (aa->co < bb->co) { + return -1; + } + if (aa->co > bb->co) { + return 1; + } + if (aa->type < bb->type) { + return -1; + } + if (aa->type > bb->type) { + return 1; + } + return 0; +} + +/* + * sortouts - sort the out arcs of a state by to/color/type + */ +static void +sortouts( + struct nfa * nfa, + struct state * s) +{ + struct arc **sortarray; + struct arc *a; + int n = s->nouts; + int i; + + if (n <= 1) { + return; /* nothing to do */ + } + /* make an array of arc pointers ... */ + sortarray = (struct arc **) MALLOC(n * sizeof(struct arc *)); + if (sortarray == NULL) { + NERR(REG_ESPACE); + return; + } + i = 0; + for (a = s->outs; a != NULL; a = a->outchain) { + sortarray[i++] = a; + } + assert(i == n); + /* ... sort the array */ + qsort(sortarray, n, sizeof(struct arc *), sortouts_cmp); + /* ... and rebuild arc list in order */ + /* it seems worth special-casing first and last items to simplify loop */ + a = sortarray[0]; + s->outs = a; + a->outchain = sortarray[1]; + a->outchainRev = NULL; + for (i = 1; i < n - 1; i++) { + a = sortarray[i]; + a->outchain = sortarray[i + 1]; + a->outchainRev = sortarray[i - 1]; + } + a = sortarray[i]; + a->outchain = NULL; + a->outchainRev = sortarray[i - 1]; + FREE(sortarray); +} + +static int +sortouts_cmp( + const void *a, + const void *b) +{ + const struct arc *aa = *((const struct arc * const *) a); + const struct arc *bb = *((const struct arc * const *) b); + + /* we check the fields in the order they are most likely to be different */ + if (aa->to->no < bb->to->no) { + return -1; + } + if (aa->to->no > bb->to->no) { + return 1; + } + if (aa->co < bb->co) { + return -1; + } + if (aa->co > bb->co) { + return 1; + } + if (aa->type < bb->type) { + return -1; + } + if (aa->type > bb->type) { + return 1; + } + return 0; +} + +/* + * Common decision logic about whether to use arc-by-arc operations or + * sort/merge. If there's just a few source arcs we cannot recoup the + * cost of sorting the destination arc list, no matter how large it is. + * Otherwise, limit the number of arc-by-arc comparisons to about 1000 + * (a somewhat arbitrary choice, but the breakeven point would probably + * be machine dependent anyway). + */ +#define BULK_ARC_OP_USE_SORT(nsrcarcs, ndestarcs) \ + ((nsrcarcs) < 4 ? 0 : ((nsrcarcs) > 32 || (ndestarcs) > 32)) /* - moveins - move all in arcs of a state to another state * You might think this could be done better by just updating the - * existing arcs, and you would be right if it weren't for the desire + * existing arcs, and you would be right if it weren't for the need * for duplicate suppression, which makes it easier to just make new * ones to exploit the suppression built into newarc. + * + * However, if we have a whole lot of arcs to deal with, retail duplicate + * checks become too slow. In that case we proceed by sorting and merging + * the arc lists, and then we can indeed just update the arcs in-place. + * ^ static void moveins(struct nfa *, struct state *, struct state *); */ static void @@ -602,38 +764,253 @@ moveins( struct state *oldState, struct state *newState) { - struct arc *a; - assert(oldState != newState); - while ((a = oldState->ins) != NULL) { - cparc(nfa, a, a->from, newState); - freearc(nfa, a); + if (!BULK_ARC_OP_USE_SORT(oldState->nins, newState->nins)) { + /* With not too many arcs, just do them one at a time */ + struct arc *a; + + while ((a = oldState->ins) != NULL) { + cparc(nfa, a, a->from, newState); + freearc(nfa, a); + } + } else { + /* + * With many arcs, use a sort-merge approach. Note changearctarget() + * will put the arc onto the front of newState's chain, so it does not + * break our walk through the sorted part of the chain. + */ + struct arc *oa; + struct arc *na; + + /* + * Because we bypass newarc() in this code path, we'd better include a + * cancel check. + */ + if (CANCEL_REQUESTED(nfa->v->re)) { + NERR(REG_CANCEL); + return; + } + + sortins(nfa, oldState); + sortins(nfa, newState); + if (NISERR()) { + return; /* might have failed to sort */ + } + oa = oldState->ins; + na = newState->ins; + while (oa != NULL && na != NULL) { + struct arc *a = oa; + + switch (sortins_cmp(&oa, &na)) { + case -1: + /* newState does not have anything matching oa */ + oa = oa->inchain; + + /* + * Rather than doing createarc+freearc, we can just unlink + * and relink the existing arc struct. + */ + changearctarget(a, newState); + break; + case 0: + /* match, advance in both lists */ + oa = oa->inchain; + na = na->inchain; + /* ... and drop duplicate arc from oldState */ + freearc(nfa, a); + break; + case +1: + /* advance only na; oa might have a match later */ + na = na->inchain; + break; + default: + assert(NOTREACHED); + } + } + while (oa != NULL) { + /* newState does not have anything matching oa */ + struct arc *a = oa; + + oa = oa->inchain; + changearctarget(a, newState); + } } + assert(oldState->nins == 0); assert(oldState->ins == NULL); } /* - copyins - copy in arcs of a state to another state - * Either all arcs, or only non-empty ones as determined by all value. - ^ static VOID copyins(struct nfa *, struct state *, struct state *, int); + ^ static void copyins(struct nfa *, struct state *, struct state *, int); */ static void copyins( struct nfa *nfa, struct state *oldState, - struct state *newState, - int all) + struct state *newState) { - struct arc *a; - assert(oldState != newState); - for (a=oldState->ins ; a!=NULL ; a=a->inchain) { - if (all || a->type != EMPTY) { + if (!BULK_ARC_OP_USE_SORT(oldState->nins, newState->nins)) { + /* With not too many arcs, just do them one at a time */ + struct arc *a; + + for (a = oldState->ins; a != NULL; a = a->inchain) { cparc(nfa, a, a->from, newState); } + } else { + /* + * With many arcs, use a sort-merge approach. Note that createarc() + * will put new arcs onto the front of newState's chain, so it does + * not break our walk through the sorted part of the chain. + */ + struct arc *oa; + struct arc *na; + + /* + * Because we bypass newarc() in this code path, we'd better include a + * cancel check. + */ + if (CANCEL_REQUESTED(nfa->v->re)) { + NERR(REG_CANCEL); + return; + } + + sortins(nfa, oldState); + sortins(nfa, newState); + if (NISERR()) { + return; /* might have failed to sort */ + } + oa = oldState->ins; + na = newState->ins; + while (oa != NULL && na != NULL) { + struct arc *a = oa; + + switch (sortins_cmp(&oa, &na)) { + case -1: + /* newState does not have anything matching oa */ + oa = oa->inchain; + createarc(nfa, a->type, a->co, a->from, newState); + break; + case 0: + /* match, advance in both lists */ + oa = oa->inchain; + na = na->inchain; + break; + case +1: + /* advance only na; oa might have a match later */ + na = na->inchain; + break; + default: + assert(NOTREACHED); + } + } + while (oa != NULL) { + /* newState does not have anything matching oa */ + struct arc *a = oa; + + oa = oa->inchain; + createarc(nfa, a->type, a->co, a->from, newState); + } + } +} + +/* + * mergeins - merge a list of inarcs into a state + * + * This is much like copyins, but the source arcs are listed in an array, + * and are not guaranteed unique. It's okay to clobber the array contents. + */ +static void +mergeins( + struct nfa * nfa, + struct state * s, + struct arc ** arcarray, + int arccount) +{ + struct arc *na; + int i; + int j; + + if (arccount <= 0) { + return; + } + + /* + * Because we bypass newarc() in this code path, we'd better include a + * cancel check. + */ + if (CANCEL_REQUESTED(nfa->v->re)) { + NERR(REG_CANCEL); + return; + } + + /* Sort existing inarcs as well as proposed new ones */ + sortins(nfa, s); + if (NISERR()) { + return; /* might have failed to sort */ + } + + qsort(arcarray, arccount, sizeof(struct arc *), sortins_cmp); + + /* + * arcarray very likely includes dups, so we must eliminate them. (This + * could be folded into the next loop, but it's not worth the trouble.) + */ + j = 0; + for (i = 1; i < arccount; i++) { + switch (sortins_cmp(&arcarray[j], &arcarray[i])) { + case -1: + /* non-dup */ + arcarray[++j] = arcarray[i]; + break; + case 0: + /* dup */ + break; + default: + /* trouble */ + assert(NOTREACHED); + } + } + arccount = j + 1; + + /* + * Now merge into s' inchain. Note that createarc() will put new arcs + * onto the front of s's chain, so it does not break our walk through the + * sorted part of the chain. + */ + i = 0; + na = s->ins; + while (i < arccount && na != NULL) { + struct arc *a = arcarray[i]; + + switch (sortins_cmp(&a, &na)) { + case -1: + /* s does not have anything matching a */ + createarc(nfa, a->type, a->co, a->from, s); + i++; + break; + case 0: + /* match, advance in both lists */ + i++; + na = na->inchain; + break; + case +1: + /* advance only na; array might have a match later */ + na = na->inchain; + break; + default: + assert(NOTREACHED); + } + } + while (i < arccount) { + /* s does not have anything matching a */ + struct arc *a = arcarray[i]; + + createarc(nfa, a->type, a->co, a->from, s); + i++; } } @@ -647,36 +1024,153 @@ moveouts( struct state *oldState, struct state *newState) { - struct arc *a; - assert(oldState != newState); - while ((a = oldState->outs) != NULL) { - cparc(nfa, a, newState, a->to); - freearc(nfa, a); + if (!BULK_ARC_OP_USE_SORT(oldState->nouts, newState->nouts)) { + /* With not too many arcs, just do them one at a time */ + struct arc *a; + + while ((a = oldState->outs) != NULL) { + cparc(nfa, a, newState, a->to); + freearc(nfa, a); + } + } else { + /* + * With many arcs, use a sort-merge approach. Note that createarc() + * will put new arcs onto the front of newState's chain, so it does + * not break our walk through the sorted part of the chain. + */ + struct arc *oa; + struct arc *na; + + /* + * Because we bypass newarc() in this code path, we'd better include a + * cancel check. + */ + if (CANCEL_REQUESTED(nfa->v->re)) { + NERR(REG_CANCEL); + return; + } + + sortouts(nfa, oldState); + sortouts(nfa, newState); + if (NISERR()) { + return; /* might have failed to sort */ + } + oa = oldState->outs; + na = newState->outs; + while (oa != NULL && na != NULL) { + struct arc *a = oa; + + switch (sortouts_cmp(&oa, &na)) { + case -1: + /* newState does not have anything matching oa */ + oa = oa->outchain; + createarc(nfa, a->type, a->co, newState, a->to); + freearc(nfa, a); + break; + case 0: + /* match, advance in both lists */ + oa = oa->outchain; + na = na->outchain; + /* ... and drop duplicate arc from oldState */ + freearc(nfa, a); + break; + case +1: + /* advance only na; oa might have a match later */ + na = na->outchain; + break; + default: + assert(NOTREACHED); + } + } + while (oa != NULL) { + /* newState does not have anything matching oa */ + struct arc *a = oa; + + oa = oa->outchain; + createarc(nfa, a->type, a->co, newState, a->to); + freearc(nfa, a); + } } + + assert(oldState->nouts == 0); + assert(oldState->outs == NULL); } /* - copyouts - copy out arcs of a state to another state - * Either all arcs, or only non-empty ones as determined by all value. - ^ static VOID copyouts(struct nfa *, struct state *, struct state *, int); + ^ static void copyouts(struct nfa *, struct state *, struct state *, int); */ static void copyouts( struct nfa *nfa, struct state *oldState, - struct state *newState, - int all) + struct state *newState) { - struct arc *a; - assert(oldState != newState); - for (a=oldState->outs ; a!=NULL ; a=a->outchain) { - if (all || a->type != EMPTY) { + if (!BULK_ARC_OP_USE_SORT(oldState->nouts, newState->nouts)) { + /* With not too many arcs, just do them one at a time */ + struct arc *a; + + for (a = oldState->outs; a != NULL; a = a->outchain) { cparc(nfa, a, newState, a->to); } + } else { + /* + * With many arcs, use a sort-merge approach. Note that createarc() + * will put new arcs onto the front of newState's chain, so it does + * not break our walk through the sorted part of the chain. + */ + struct arc *oa; + struct arc *na; + + /* + * Because we bypass newarc() in this code path, we'd better include a + * cancel check. + */ + if (CANCEL_REQUESTED(nfa->v->re)) { + NERR(REG_CANCEL); + return; + } + + sortouts(nfa, oldState); + sortouts(nfa, newState); + if (NISERR()) { + return; /* might have failed to sort */ + } + oa = oldState->outs; + na = newState->outs; + while (oa != NULL && na != NULL) { + struct arc *a = oa; + + switch (sortouts_cmp(&oa, &na)) { + case -1: + /* newState does not have anything matching oa */ + oa = oa->outchain; + createarc(nfa, a->type, a->co, newState, a->to); + break; + case 0: + /* match, advance in both lists */ + oa = oa->outchain; + na = na->outchain; + break; + case +1: + /* advance only na; oa might have a match later */ + na = na->outchain; + break; + default: + assert(NOTREACHED); + } + } + while (oa != NULL) { + /* newState does not have anything matching oa */ + struct arc *a = oa; + + oa = oa->outchain; + createarc(nfa, a->type, a->co, newState, a->to); + } } } @@ -895,6 +1389,20 @@ specialcolors( - optimize - optimize an NFA ^ static long optimize(struct nfa *, FILE *); */ + + /* + * The main goal of this function is not so much "optimization" (though it + * does try to get rid of useless NFA states) as reducing the NFA to a form + * the regex executor can handle. The executor, and indeed the cNFA format + * that is its input, can only handle PLAIN and LACON arcs. The output of + * the regex parser also includes EMPTY (do-nothing) arcs, as well as + * ^, $, AHEAD, and BEHIND constraint arcs, which we must get rid of here. + * We first get rid of EMPTY arcs and then deal with the constraint arcs. + * The hardest part of either job is to get rid of circular loops of the + * target arc type. We would have to do that in any case, though, as such a + * loop would otherwise allow the executor to cycle through the loop endlessly + * without making any progress in the input string. + */ static long /* re_info bits */ optimize( struct nfa *nfa, @@ -916,17 +1424,23 @@ optimize( if (verbose) { fprintf(f, "\nconstraints:\n"); } + fixconstraintloops(nfa, f); /* get rid of constraint loops */ pullback(nfa, f); /* pull back constraints backward */ pushfwd(nfa, f); /* push fwd constraints forward */ if (verbose) { fprintf(f, "\nfinal cleanup:\n"); } cleanup(nfa); /* final tidying */ +#ifdef REG_DEBUG + if (verbose) { + dumpnfa(nfa, f); + } +#endif return analyze(nfa); /* and analysis */ } /* - - pullback - pull back constraints backward to (with luck) eliminate them + - pullback - pull back constraints backward to eliminate them ^ static void pullback(struct nfa *, FILE *); */ static void @@ -938,6 +1452,7 @@ pullback( struct state *nexts; struct arc *a; struct arc *nexta; + struct state *intermediates; int progress; /* @@ -948,15 +1463,27 @@ pullback( progress = 0; for (s=nfa->states ; s!=NULL && !NISERR() ; s=nexts) { nexts = s->next; + intermediates = NULL; for (a=s->outs ; a!=NULL && !NISERR() ; a=nexta) { nexta = a->outchain; if (a->type == '^' || a->type == BEHIND) { - if (pull(nfa, a)) { + if (pull(nfa, a, &intermediates)) { progress = 1; } } assert(nexta == NULL || s->no != FREESTATE); } + /* clear tmp fields of intermediate states created here */ + while (intermediates != NULL) { + struct state *ns = intermediates->tmp; + + intermediates->tmp = NULL; + intermediates = ns; + } + /* if s is now useless, get rid of it */ + if ((s->nins == 0 || s->nouts == 0) && !s->flag) { + dropstate(nfa, s); + } } if (progress && f != NULL) { dumpnfa(nfa, f); @@ -966,6 +1493,12 @@ pullback( return; } + /* + * Any ^ constraints we were able to pull to the start state can now be + * replaced by PLAIN arcs referencing the BOS or BOL colors. There should + * be no other ^ or BEHIND arcs left in the NFA, though we do not check + * that here (compact() will fail if so). + */ for (a=nfa->pre->outs ; a!=NULL ; a=nexta) { nexta = a->outchain; if (a->type == '^') { @@ -978,15 +1511,28 @@ pullback( /* - pull - pull a back constraint backward past its source state - * A significant property of this function is that it deletes at most - * one state -- the constraint's from state -- and only if the constraint - * was that state's last outarc. + * + * Returns 1 if successful (which it always is unless the source is the + * start state or we have an internal error), 0 if nothing happened. + * + * A significant property of this function is that it deletes no pre-existing + * states, and no outarcs of the constraint's from state other than the given + * constraint arc. This makes the loops in pullback() safe, at the cost that + * we may leave useless states behind. Therefore, we leave it to pullback() + * to delete such states. + * + * If the from state has multiple back-constraint outarcs, and/or multiple + * compatible constraint inarcs, we only need to create one new intermediate + * state per combination of predecessor and successor states. *intermediates + * points to a list of such intermediate states for this from state (chained + * through their tmp fields). ^ static int pull(struct nfa *, struct arc *); */ -static int /* 0 couldn't, 1 could */ +static int pull( struct nfa *nfa, - struct arc *con) + struct arc *con, + struct state **intermediates) { struct state *from = con->from; struct state *to = con->to; @@ -994,10 +1540,7 @@ pull( struct arc *nexta; struct state *s; - if (from == to) { /* circular constraint is pointless */ - freearc(nfa, con); - return 1; - } + assert(from != to); /* should have gotten rid of this earlier */ if (from->flag) { /* can't pull back beyond start */ return 0; } @@ -1007,26 +1550,9 @@ pull( } /* - * DGP 2007-11-15: Cloning a state with a circular constraint on its list - * of outs can lead to trouble [Bug 1810038], so get rid of them first. - */ - - for (a = from->outs; a != NULL; a = nexta) { - nexta = a->outchain; - switch (a->type) { - case '^': - case '$': - case BEHIND: - case AHEAD: - if (from == a->to) { - freearc(nfa, a); - } - break; - } - } - - /* - * First, clone from state if necessary to avoid other outarcs. + * First, clone from state if necessary to avoid other outarcs. This may + * seem wasteful, but it simplifies the logic, and we'll get rid of the + * clone state again at the bottom. */ if (from->nouts > 1) { @@ -1034,10 +1560,12 @@ pull( if (NISERR()) { return 0; } - assert(to != from); /* con is not an inarc */ - copyins(nfa, from, s, 1); /* duplicate inarcs */ + copyins(nfa, from, s); /* duplicate inarcs */ cparc(nfa, con, s, to); /* move constraint arc */ freearc(nfa, con); + if (NISERR()) { + return 0; + } from = s; con = from->outs; } @@ -1047,7 +1575,7 @@ pull( * Propagate the constraint into the from state's inarcs. */ - for (a=from->ins ; a!=NULL ; a=nexta) { + for (a=from->ins ; a!=NULL && !NISERR(); a=nexta) { nexta = a->inchain; switch (combine(con, a)) { case INCOMPATIBLE: /* destroy the arc */ @@ -1056,17 +1584,25 @@ pull( case SATISFIED: /* no action needed */ break; case COMPATIBLE: /* swap the two arcs, more or less */ - s = newstate(nfa); - if (NISERR()) { - return 0; + /* need an intermediate state, but might have one already */ + for (s = *intermediates; s != NULL; s = s->tmp) { + assert(s->nins > 0 && s->nouts > 0); + if (s->ins->from == a->from && s->outs->to == to) { + break; + } } - cparc(nfa, a, s, to); /* anticipate move */ - cparc(nfa, con, a->from, s); - if (NISERR()) { - return 0; + if (s == NULL) { + s = newstate(nfa); + if (NISERR()) { + return 0; + } + s->tmp = *intermediates; + *intermediates = s; } - freearc(nfa, a); - break; + cparc(nfa, con, a->from, s); + cparc(nfa, a, s, to); + freearc(nfa, a); + break; default: assert(NOTREACHED); break; @@ -1078,12 +1614,13 @@ pull( */ moveins(nfa, from, to); - dropstate(nfa, from); /* will free the constraint */ + freearc(nfa, con); + /* from state is now useless, but we leave it to pullback() to clean up */ return 1; } /* - - pushfwd - push forward constraints forward to (with luck) eliminate them + - pushfwd - push forward constraints forward to eliminate them ^ static void pushfwd(struct nfa *, FILE *); */ static void @@ -1095,6 +1632,7 @@ pushfwd( struct state *nexts; struct arc *a; struct arc *nexta; + struct state *intermediates; int progress; /* @@ -1105,14 +1643,25 @@ pushfwd( progress = 0; for (s=nfa->states ; s!=NULL && !NISERR() ; s=nexts) { nexts = s->next; + intermediates = NULL; for (a = s->ins; a != NULL && !NISERR(); a = nexta) { nexta = a->inchain; if (a->type == '$' || a->type == AHEAD) { - if (push(nfa, a)) { + if (push(nfa, a, &intermediates)) { progress = 1; } } - assert(nexta == NULL || s->no != FREESTATE); + } + /* clear tmp fields of intermediate states created here */ + while (intermediates != NULL) { + struct state *ns = intermediates->tmp; + + intermediates->tmp = NULL; + intermediates = ns; + } + /* if s is now useless, get rid of it */ + if ((s->nins == 0 || s->nouts == 0) && !s->flag) { + dropstate(nfa, s); } } if (progress && f != NULL) { @@ -1123,6 +1672,12 @@ pushfwd( return; } + /* + * Any $ constraints we were able to push to the post state can now be + * replaced by PLAIN arcs referencing the EOS or EOL colors. There should + * be no other $ or AHEAD arcs left in the NFA, though we do not check + * that here (compact() will fail if so). + */ for (a = nfa->post->ins; a != NULL; a = nexta) { nexta = a->inchain; if (a->type == '$') { @@ -1135,15 +1690,28 @@ pushfwd( /* - push - push a forward constraint forward past its destination state - * A significant property of this function is that it deletes at most - * one state -- the constraint's to state -- and only if the constraint - * was that state's last inarc. + * + * Returns 1 if successful (which it always is unless the destination is the + * post state or we have an internal error), 0 if nothing happened. + * + * A significant property of this function is that it deletes no pre-existing + * states, and no inarcs of the constraint's to state other than the given + * constraint arc. This makes the loops in pushfwd() safe, at the cost that + * we may leave useless states behind. Therefore, we leave it to pushfwd() + * to delete such states. + * + * If the to state has multiple forward-constraint inarcs, and/or multiple + * compatible constraint outarcs, we only need to create one new intermediate + * state per combination of predecessor and successor states. *intermediates + * points to a list of such intermediate states for this to state (chained + * through their tmp fields). ^ static int push(struct nfa *, struct arc *); */ -static int /* 0 couldn't, 1 could */ +static int push( struct nfa *nfa, - struct arc *con) + struct arc *con, + struct state **intermediates) { struct state *from = con->from; struct state *to = con->to; @@ -1151,10 +1719,7 @@ push( struct arc *nexta; struct state *s; - if (to == from) { /* circular constraint is pointless */ - freearc(nfa, con); - return 1; - } + assert(to != from); /* should have gotten rid of this earlier */ if (to->flag) { /* can't push forward beyond end */ return 0; } @@ -1164,29 +1729,9 @@ push( } /* - * DGP 2007-11-15: Here we duplicate the same protections as appear - * in pull() above to avoid troubles with cloning a state with a - * circular constraint on its list of ins. It is not clear whether - * this is necessary, or is protecting against a "can't happen". - * Any test case that actually leads to a freearc() call here would - * be a welcome addition to the test suite. - */ - - for (a = to->ins; a != NULL; a = nexta) { - nexta = a->inchain; - switch (a->type) { - case '^': - case '$': - case BEHIND: - case AHEAD: - if (a->from == to) { - freearc(nfa, a); - } - break; - } - } - /* - * First, clone to state if necessary to avoid other inarcs. + * First, clone to state if necessary to avoid other inarcs. This may + * seem wasteful, but it simplifies the logic, and we'll get rid of the + * clone state again at the bottom. */ if (to->nins > 1) { @@ -1194,9 +1739,12 @@ push( if (NISERR()) { return 0; } - copyouts(nfa, to, s, 1); /* duplicate outarcs */ - cparc(nfa, con, from, s); /* move constraint */ + copyouts(nfa, to, s); /* duplicate outarcs */ + cparc(nfa, con, from, s); /* move constraint arc */ freearc(nfa, con); + if (NISERR()) { + return 0; + } to = s; con = to->ins; } @@ -1206,7 +1754,7 @@ push( * Propagate the constraint into the to state's outarcs. */ - for (a = to->outs; a != NULL; a = nexta) { + for (a = to->outs; a != NULL && !NISERR(); a = nexta) { nexta = a->outchain; switch (combine(con, a)) { case INCOMPATIBLE: /* destroy the arc */ @@ -1215,17 +1763,25 @@ push( case SATISFIED: /* no action needed */ break; case COMPATIBLE: /* swap the two arcs, more or less */ - s = newstate(nfa); - if (NISERR()) { - return 0; + /* need an intermediate state, but might have one already */ + for (s = *intermediates; s != NULL; s = s->tmp) { + assert(s->nins > 0 && s->nouts > 0); + if (s->ins->from == from && s->outs->to == a->to) { + break; + } } - cparc(nfa, con, s, a->to); /* anticipate move */ - cparc(nfa, a, from, s); - if (NISERR()) { - return 0; + if (s == NULL) { + s = newstate(nfa); + if (NISERR()) { + return 0; + } + s->tmp = *intermediates; + *intermediates = s; } - freearc(nfa, a); - break; + cparc(nfa, con, s, a->to); + cparc(nfa, a, from, s); + freearc(nfa, a); + break; default: assert(NOTREACHED); break; @@ -1237,7 +1793,8 @@ push( */ moveouts(nfa, to, from); - dropstate(nfa, to); /* will free the constraint */ + freearc(nfa, con); + /* to state is now useless, but we leave it to pushfwd() to clean up */ return 1; } @@ -1315,6 +1872,12 @@ fixempties( struct state *nexts; struct arc *a; struct arc *nexta; + int totalinarcs; + struct arc **inarcsorig; + struct arc **arcarray; + int arccount; + int prevnins; + int nskip; /* * First, get rid of any states whose sole out-arc is an EMPTY, @@ -1345,7 +1908,7 @@ fixempties( for (s = nfa->states; s != NULL && !NISERR(); s = nexts) { nexts = s->next; /* Ensure tmp fields are clear for next step */ - assert(s->tmp = NULL); + assert(s->tmp == NULL); if (s->flag || s->nins != 1) { continue; } @@ -1360,42 +1923,129 @@ fixempties( dropstate(nfa, s); } + if (NISERR()) { + return; + } + /* - * For each remaining NFA state, find all other states that are - * reachable from it by a chain of one or more EMPTY arcs. Then - * generate new arcs that eliminate the need for each such chain. + * For each remaining NFA state, find all other states from which it is + * reachable by a chain of one or more EMPTY arcs. Then generate new arcs + * that eliminate the need for each such chain. + * + * We could replace a chain of EMPTY arcs that leads from a "from" state + * to a "to" state either by pushing non-EMPTY arcs forward (linking + * directly from "from"'s predecessors to "to") or by pulling them back + * (linking directly from "from" to "to"'s successors). We choose to + * always do the former; this choice is somewhat arbitrary, but the + * approach below requires that we uniformly do one or the other. + * + * Suppose we have a chain of N successive EMPTY arcs (where N can easily + * approach the size of the NFA). All of the intermediate states must + * have additional inarcs and outarcs, else they'd have been removed by + * the steps above. Assuming their inarcs are mostly not empties, we will + * add O(N^2) arcs to the NFA, since a non-EMPTY inarc leading to any one + * state in the chain must be duplicated to lead to all its successor + * states as well. So there is no hope of doing less than O(N^2) work; + * however, we should endeavor to keep the big-O cost from being even + * worse than that, which it can easily become without care. In + * particular, suppose we were to copy all S1's inarcs forward to S2, and + * then also to S3, and then later we consider pushing S2's inarcs forward + * to S3. If we include the arcs already copied from S1 in that, we'd be + * doing O(N^3) work. (The duplicate-arc elimination built into newarc() + * and its cohorts would get rid of the extra arcs, but not without cost.) * - * If we just do this straightforwardly, the algorithm gets slow in - * complex graphs, because the same arcs get copied to all - * intermediate states of an EMPTY chain, and then uselessly pushed - * repeatedly to the chain's final state; we waste a lot of time in - * newarc's duplicate checking. To improve matters, we decree that - * any state with only EMPTY out-arcs is "doomed" and will not be - * part of the final NFA. That can be ensured by not adding any new - * out-arcs to such a state. Having ensured that, we need not update - * the state's in-arcs list either; all arcs that might have gotten - * pushed forward to it will just get pushed directly to successor - * states. This eliminates most of the useless duplicate arcs. + * We can avoid this cost by treating only arcs that existed at the start + * of this phase as candidates to be pushed forward. To identify those, + * we remember the first inarc each state had to start with. We rely on + * the fact that newarc() and friends put new arcs on the front of their + * to-states' inchains, and that this phase never deletes arcs, so that + * the original arcs must be the last arcs in their to-states' inchains. + * + * So the process here is that, for each state in the NFA, we gather up + * all non-EMPTY inarcs of states that can reach the target state via + * EMPTY arcs. We then sort, de-duplicate, and merge these arcs into the + * target state's inchain. (We can safely use sort-merge for this as long + * as we update each state's original-arcs pointer after we add arcs to + * it; the sort step of mergeins probably changed the order of the old + * arcs.) + * + * Another refinement worth making is that, because we only add non-EMPTY + * arcs during this phase, and all added arcs have the same from-state as + * the non-EMPTY arc they were cloned from, we know ahead of time that any + * states having only EMPTY outarcs will be useless for lack of outarcs + * after we drop the EMPTY arcs. (They cannot gain non-EMPTY outarcs if + * they had none to start with.) So we need not bother to update the + * inchains of such states at all. + */ + + /* Remember the states' first original inarcs */ + /* ... and while at it, count how many old inarcs there are altogether */ + inarcsorig = (struct arc **) MALLOC(nfa->nstates * sizeof(struct arc *)); + if (inarcsorig == NULL) { + NERR(REG_ESPACE); + return; + } + totalinarcs = 0; + for (s = nfa->states; s != NULL; s = s->next) { + inarcsorig[s->no] = s->ins; + totalinarcs += s->nins; + } + + /* + * Create a workspace for accumulating the inarcs to be added to the + * current target state. totalinarcs is probably a considerable + * overestimate of the space needed, but the NFA is unlikely to be large + * enough at this point to make it worth being smarter. */ + arcarray = (struct arc **) MALLOC(totalinarcs * sizeof(struct arc *)); + if (arcarray == NULL) { + NERR(REG_ESPACE); + FREE(inarcsorig); + return; + } + + /* And iterate over the target states */ for (s = nfa->states; s != NULL && !NISERR(); s = s->next) { - for (s2 = emptyreachable(s, s); s2 != s && !NISERR(); - s2 = nexts) { - /* - * If s2 is doomed, we decide that (1) we will always push - * arcs forward to it, not pull them back to s; and (2) we - * can optimize away the push-forward, per comment above. - * So do nothing. - */ - if (s2->flag || hasnonemptyout(s2)) { - replaceempty(nfa, s, s2); + /* Ignore target states without non-EMPTY outarcs, per note above */ + if (!s->flag && !hasnonemptyout(s)) { + continue; + } + + /* Find predecessor states and accumulate their original inarcs */ + arccount = 0; + for (s2 = emptyreachable(nfa, s, s, inarcsorig); s2 != s; s2 = nexts) { + /* Add s2's original inarcs to arcarray[], but ignore empties */ + for (a = inarcsorig[s2->no]; a != NULL; a = a->inchain) { + if (a->type != EMPTY) { + arcarray[arccount++] = a; + } } - /* Reset the tmp fields as we walk back */ - nexts = s2->tmp; - s2->tmp = NULL; + /* Reset the tmp fields as we walk back */ + nexts = s2->tmp; + s2->tmp = NULL; + } + s->tmp = NULL; + assert(arccount <= totalinarcs); + + /* Remember how many original inarcs this state has */ + prevnins = s->nins; + + /* Add non-duplicate inarcs to target state */ + mergeins(nfa, s, arcarray, arccount); + + /* Now we must update the state's inarcsorig pointer */ + nskip = s->nins - prevnins; + a = s->ins; + while (nskip-- > 0) { + a = a->inchain; } - s->tmp = NULL; + inarcsorig[s->no] = a; } + + FREE(arcarray); + FREE(inarcsorig); + if (NISERR()) { return; } @@ -1431,89 +2081,604 @@ fixempties( } /* - - emptyreachable - recursively find all states reachable from s by EMPTY arcs + - emptyreachable - recursively find all states that can reach s by EMPTY arcs * The return value is the last such state found. Its tmp field links back * to the next-to-last such state, and so on back to s, so that all these * states can be located without searching the whole NFA. + * + * Since this is only used in fixempties(), we pass in the inarcsorig[] array + * maintained by that function. This lets us skip over all new inarcs, which + * are certainly not EMPTY arcs. + * * The maximum recursion depth here is equal to the length of the longest * loop-free chain of EMPTY arcs, which is surely no more than the size of - * the NFA, and in practice will be a lot less than that. + * the NFA, and in practice will be less than that. ^ static struct state *emptyreachable(struct state *, struct state *); */ static struct state * emptyreachable( + struct nfa *nfa, struct state *s, - struct state *lastfound) + struct state *lastfound, + struct arc **inarcsorig) { struct arc *a; s->tmp = lastfound; lastfound = s; - for (a = s->outs; a != NULL; a = a->outchain) { - if (a->type == EMPTY && a->to->tmp == NULL) { - lastfound = emptyreachable(a->to, lastfound); + for (a = inarcsorig[s->no]; a != NULL; a = a->inchain) { + if (a->type == EMPTY && a->from->tmp == NULL) { + lastfound = emptyreachable(nfa, a->from, lastfound, inarcsorig); } } return lastfound; } - + /* - - replaceempty - replace an EMPTY arc chain with some non-empty arcs - * The EMPTY arc(s) should be deleted later, but we can't do it here because - * they may still be needed to identify other arc chains during fixempties(). - ^ static void replaceempty(struct nfa *, struct state *, struct state *); + * isconstraintarc - detect whether an arc is of a constraint type + */ +static inline int +isconstraintarc(struct arc * a) +{ + switch (a->type) + { + case '^': + case '$': + case BEHIND: + case AHEAD: + case LACON: + return 1; + } + return 0; +} + +/* + * hasconstraintout - does state have a constraint out arc? + */ +static int +hasconstraintout(struct state * s) +{ + struct arc *a; + + for (a = s->outs; a != NULL; a = a->outchain) { + if (isconstraintarc(a)) { + return 1; + } + } + return 0; +} + +/* + * fixconstraintloops - get rid of loops containing only constraint arcs + * + * A loop of states that contains only constraint arcs is useless, since + * passing around the loop represents no forward progress. Moreover, it + * would cause infinite looping in pullback/pushfwd, so we need to get rid + * of such loops before doing that. */ static void -replaceempty( - struct nfa *nfa, - struct state *from, - struct state *to) +fixconstraintloops( + struct nfa * nfa, + FILE *f) /* for debug output; NULL none */ { - int fromouts; - int toins; + struct state *s; + struct state *nexts; + struct arc *a; + struct arc *nexta; + int hasconstraints; + + /* + * In the trivial case of a state that loops to itself, we can just drop + * the constraint arc altogether. This is worth special-casing because + * such loops are far more common than loops containing multiple states. + * While we're at it, note whether any constraint arcs survive. + */ + hasconstraints = 0; + for (s = nfa->states; s != NULL && !NISERR(); s = nexts) { + nexts = s->next; + /* while we're at it, ensure tmp fields are clear for next step */ + assert(s->tmp == NULL); + for (a = s->outs; a != NULL && !NISERR(); a = nexta) { + nexta = a->outchain; + if (isconstraintarc(a)) { + if (a->to == s) { + freearc(nfa, a); + } else { + hasconstraints = 1; + } + } + } + /* If we removed all the outarcs, the state is useless. */ + if (s->nouts == 0 && !s->flag) { + dropstate(nfa, s); + } + } - assert(from != to); + /* Nothing to do if no remaining constraint arcs */ + if (NISERR() || !hasconstraints) { + return; + } /* - * Create replacement arcs that bypass the need for the EMPTY chain. We - * can do this either by pushing arcs forward (linking directly from - * "from"'s predecessors to "to") or by pulling them back (linking - * directly from "from" to "to"'s successors). In general, we choose - * whichever way creates greater fan-out or fan-in, so as to improve the - * odds of reducing the other state to zero in-arcs or out-arcs and - * thereby being able to delete it. However, if "from" is doomed (has no - * non-EMPTY out-arcs), we must keep it so, so always push forward in that - * case. + * Starting from each remaining NFA state, search outwards for a + * constraint loop. If we find a loop, break the loop, then start the + * search over. (We could possibly retain some state from the first scan, + * but it would complicate things greatly, and multi-state constraint + * loops are rare enough that it's not worth optimizing the case.) + */ + restart: + for (s = nfa->states; s != NULL && !NISERR(); s = s->next) { + if (findconstraintloop(nfa, s)) { + goto restart; + } + } + + if (NISERR()) { + return; + } + + /* + * Now remove any states that have become useless. (This cleanup is not + * very thorough, and would be even less so if we tried to combine it with + * the previous step; but cleanup() will take care of anything we miss.) * - * The fan-out/fan-in comparison should count only non-EMPTY arcs. If - * "from" is doomed, we can skip counting "to"'s arcs, since we want to - * force taking the copynonemptyins path in that case. + * Because findconstraintloop intentionally doesn't reset all tmp fields, + * we have to clear them after it's done. This is a convenient place to + * do that, too. */ - fromouts = nonemptyouts(from); - toins = (fromouts == 0) ? 1 : nonemptyins(to); + for (s = nfa->states; s != NULL; s = nexts) { + nexts = s->next; + s->tmp = NULL; + if ((s->nins == 0 || s->nouts == 0) && !s->flag) { + dropstate(nfa, s); + } + } + + if (f != NULL) { + dumpnfa(nfa, f); + } +} - if (fromouts > toins) { - copyouts(nfa, to, from, 0); +/* + * findconstraintloop - recursively find a loop of constraint arcs + * + * If we find a loop, break it by calling breakconstraintloop(), then + * return 1; otherwise return 0. + * + * State tmp fields are guaranteed all NULL on a success return, because + * breakconstraintloop does that. After a failure return, any state that + * is known not to be part of a loop is marked with s->tmp == s; this allows + * us not to have to re-prove that fact on later calls. (This convention is + * workable because we already eliminated single-state loops.) + * + * Note that the found loop doesn't necessarily include the first state we + * are called on. Any loop reachable from that state will do. + * + * The maximum recursion depth here is one more than the length of the longest + * loop-free chain of constraint arcs, which is surely no more than the size + * of the NFA, and in practice will be a lot less than that. + */ +static int +findconstraintloop(struct nfa * nfa, struct state * s) +{ + struct arc *a; + + /* Since this is recursive, it could be driven to stack overflow */ + if (STACK_TOO_DEEP(nfa->v->re)) { + NERR(REG_ETOOBIG); + return 1; /* to exit as quickly as possible */ + } + + if (s->tmp != NULL) { + /* Already proven uninteresting? */ + if (s->tmp == s) { + return 0; + } + /* Found a loop involving s */ + breakconstraintloop(nfa, s); + /* The tmp fields have been cleaned up by breakconstraintloop */ + return 1; + } + for (a = s->outs; a != NULL; a = a->outchain) { + if (isconstraintarc(a)) { + struct state *sto = a->to; + + assert(sto != s); + s->tmp = sto; + if (findconstraintloop(nfa, sto)) { + return 1; + } + } + } + + /* + * If we get here, no constraint loop exists leading out from s. Mark it + * with s->tmp == s so we need not rediscover that fact again later. + */ + s->tmp = s; + return 0; +} + +/* + * breakconstraintloop - break a loop of constraint arcs + * + * sinitial is any one member state of the loop. Each loop member's tmp + * field links to its successor within the loop. (Note that this function + * will reset all the tmp fields to NULL.) + * + * We can break the loop by, for any one state S1 in the loop, cloning its + * loop successor state S2 (and possibly following states), and then moving + * all S1->S2 constraint arcs to point to the cloned S2. The cloned S2 should + * copy any non-constraint outarcs of S2. Constraint outarcs should be + * dropped if they point back to S1, else they need to be copied as arcs to + * similarly cloned states S3, S4, etc. In general, each cloned state copies + * non-constraint outarcs, drops constraint outarcs that would lead to itself + * or any earlier cloned state, and sends other constraint outarcs to newly + * cloned states. No cloned state will have any inarcs that aren't constraint + * arcs or do not lead from S1 or earlier-cloned states. It's okay to drop + * constraint back-arcs since they would not take us to any state we've not + * already been in; therefore, no new constraint loop is created. In this way + * we generate a modified NFA that can still represent every useful state + * sequence, but not sequences that represent state loops with no consumption + * of input data. Note that the set of cloned states will certainly include + * all of the loop member states other than S1, and it may also include + * non-loop states that are reachable from S2 via constraint arcs. This is + * important because there is no guarantee that findconstraintloop found a + * maximal loop (and searching for one would be NP-hard, so don't try). + * Frequently the "non-loop states" are actually part of a larger loop that + * we didn't notice, and indeed there may be several overlapping loops. + * This technique ensures convergence in such cases, while considering only + * the originally-found loop does not. + * + * If there is only one S1->S2 constraint arc, then that constraint is + * certainly satisfied when we enter any of the clone states. This means that + * in the common case where many of the constraint arcs are identically + * labeled, we can merge together clone states linked by a similarly-labeled + * constraint: if we can get to the first one we can certainly get to the + * second, so there's no need to distinguish. This greatly reduces the number + * of new states needed, so we preferentially break the given loop at a state + * pair where this is true. + * + * Furthermore, it's fairly common to find that a cloned successor state has + * no outarcs, especially if we're a bit aggressive about removing unnecessary + * outarcs. If that happens, then there is simply not any interesting state + * that can be reached through the predecessor's loop arcs, which means we can + * break the loop just by removing those loop arcs, with no new states added. + */ +static void +breakconstraintloop(struct nfa * nfa, struct state * sinitial) +{ + struct state *s; + struct state *shead; + struct state *stail; + struct state *sclone; + struct state *nexts; + struct arc *refarc; + struct arc *a; + struct arc *nexta; + + /* + * Start by identifying which loop step we want to break at. + * Preferentially this is one with only one constraint arc. (XXX are + * there any other secondary heuristics we want to use here?) Set refarc + * to point to the selected lone constraint arc, if there is one. + */ + refarc = NULL; + s = sinitial; + do { + nexts = s->tmp; + assert(nexts != s); /* should not see any one-element loops */ + if (refarc == NULL) { + int narcs = 0; + + for (a = s->outs; a != NULL; a = a->outchain) { + if (a->to == nexts && isconstraintarc(a)) { + refarc = a; + narcs++; + } + } + assert(narcs > 0); + if (narcs > 1) { + refarc = NULL; /* multiple constraint arcs here, no good */ + } + } + s = nexts; + } while (s != sinitial); + + if (refarc) { + /* break at the refarc */ + shead = refarc->from; + stail = refarc->to; + assert(stail == shead->tmp); + } else { + /* for lack of a better idea, break after sinitial */ + shead = sinitial; + stail = sinitial->tmp; + } + + /* + * Reset the tmp fields so that we can use them for local storage in + * clonesuccessorstates. (findconstraintloop won't mind, since it's just + * going to abandon its search anyway.) + */ + for (s = nfa->states; s != NULL; s = s->next) { + s->tmp = NULL; + } + + /* + * Recursively build clone state(s) as needed. + */ + sclone = newstate(nfa); + if (sclone == NULL) { + assert(NISERR()); return; } - if (fromouts < toins) { - copyins(nfa, from, to, 0); + + clonesuccessorstates(nfa, stail, sclone, shead, refarc, + NULL, NULL, nfa->nstates); + + if (NISERR()) { return; } /* - * fromouts == toins. Decide on secondary issue: copy fewest arcs. - * - * Doesn't seem to be worth the trouble to exclude empties from these - * comparisons; that takes extra time and doesn't seem to improve the - * resulting graph much. + * It's possible that sclone has no outarcs at all, in which case it's + * useless. (We don't try extremely hard to get rid of useless states + * here, but this is an easy and fairly common case.) + */ + if (sclone->nouts == 0) { + freestate(nfa, sclone); + sclone = NULL; + } + + /* + * Move shead's constraint-loop arcs to point to sclone, or just drop them + * if we discovered we don't need sclone. */ - if (from->nins > to->nouts) { - copyouts(nfa, to, from, 0); + for (a = shead->outs; a != NULL; a = nexta) { + nexta = a->outchain; + if (a->to == stail && isconstraintarc(a)) { + if (sclone) { + cparc(nfa, a, shead, sclone); + } + freearc(nfa, a); + if (NISERR()) { + break; + } + } + } +} + +/* + * clonesuccessorstates - create a tree of constraint-arc successor states + * + * ssource is the state to be cloned, and sclone is the state to copy its + * outarcs into. sclone's inarcs, if any, should already be set up. + * + * spredecessor is the original predecessor state that we are trying to build + * successors for (it may not be the immediate predecessor of ssource). + * refarc, if not NULL, is the original constraint arc that is known to have + * been traversed out of spredecessor to reach the successor(s). + * + * For each cloned successor state, we transiently create a "donemap" that is + * a boolean array showing which source states we've already visited for this + * clone state. This prevents infinite recursion as well as useless repeat + * visits to the same state subtree (which can add up fast, since typical NFAs + * have multiple redundant arc pathways). Each donemap is a char array + * indexed by state number. The donemaps are all of the same size "nstates", + * which is nfa->nstates as of the start of the recursion. This is enough to + * have entries for all pre-existing states, but *not* entries for clone + * states created during the recursion. That's okay since we have no need to + * mark those. + * + * curdonemap is NULL when recursing to a new sclone state, or sclone's + * donemap when we are recursing without having created a new state (which we + * do when we decide we can merge a successor state into the current clone + * state). outerdonemap is NULL at the top level and otherwise the parent + * clone state's donemap. + * + * The successor states we create and fill here form a strict tree structure, + * with each state having exactly one predecessor, except that the toplevel + * state has no inarcs as yet (breakconstraintloop will add its inarcs from + * spredecessor after we're done). Thus, we can examine sclone's inarcs back + * to the root, plus refarc if any, to identify the set of constraints already + * known valid at the current point. This allows us to avoid generating extra + * successor states. + */ +static void +clonesuccessorstates( + struct nfa * nfa, + struct state * ssource, + struct state * sclone, + struct state * spredecessor, + struct arc * refarc, + char *curdonemap, + char *outerdonemap, + int nstates) +{ + char *donemap; + struct arc *a; + + /* Since this is recursive, it could be driven to stack overflow */ + if (STACK_TOO_DEEP(nfa->v->re)) { + NERR(REG_ETOOBIG); return; } - copyins(nfa, from, to, 0); + /* If this state hasn't already got a donemap, create one */ + donemap = curdonemap; + if (donemap == NULL) { + donemap = (char *) MALLOC(nstates * sizeof(char)); + if (donemap == NULL) { + NERR(REG_ESPACE); + return; + } + + if (outerdonemap != NULL) { + /* + * Not at outermost recursion level, so copy the outer level's + * donemap; this ensures that we see states in process of being + * visited at outer levels, or already merged into predecessor + * states, as ones we shouldn't traverse back to. + */ + memcpy(donemap, outerdonemap, nstates * sizeof(char)); + } else { + /* At outermost level, only spredecessor is off-limits */ + memset(donemap, 0, nstates * sizeof(char)); + assert(spredecessor->no < nstates); + donemap[spredecessor->no] = 1; + } + } + + /* Mark ssource as visited in the donemap */ + assert(ssource->no < nstates); + assert(donemap[ssource->no] == 0); + donemap[ssource->no] = 1; + + /* + * We proceed by first cloning all of ssource's outarcs, creating new + * clone states as needed but not doing more with them than that. Then in + * a second pass, recurse to process the child clone states. This allows + * us to have only one child clone state per reachable source state, even + * when there are multiple outarcs leading to the same state. Also, when + * we do visit a child state, its set of inarcs is known exactly, which + * makes it safe to apply the constraint-is-already-checked optimization. + * Also, this ensures that we've merged all the states we can into the + * current clone before we recurse to any children, thus possibly saving + * them from making extra images of those states. + * + * While this function runs, child clone states of the current state are + * marked by setting their tmp fields to point to the original state they + * were cloned from. This makes it possible to detect multiple outarcs + * leading to the same state, and also makes it easy to distinguish clone + * states from original states (which will have tmp == NULL). + */ + for (a = ssource->outs; a != NULL && !NISERR(); a = a->outchain) { + struct state *sto = a->to; + + /* + * We do not consider cloning successor states that have no constraint + * outarcs; just link to them as-is. They cannot be part of a + * constraint loop so there is no need to make copies. In particular, + * this rule keeps us from trying to clone the post state, which would + * be a bad idea. + */ + if (isconstraintarc(a) && hasconstraintout(sto)) { + struct state *prevclone; + int canmerge; + struct arc *a2; + + /* + * Back-link constraint arcs must not be followed. Nor is there a + * need to revisit states previously merged into this clone. + */ + assert(sto->no < nstates); + if (donemap[sto->no] != 0) { + continue; + } + + /* + * Check whether we already have a child clone state for this + * source state. + */ + prevclone = NULL; + for (a2 = sclone->outs; a2 != NULL; a2 = a2->outchain) { + if (a2->to->tmp == sto) { + prevclone = a2->to; + break; + } + } + + /* + * If this arc is labeled the same as refarc, or the same as any + * arc we must have traversed to get to sclone, then no additional + * constraints need to be met to get to sto, so we should just + * merge its outarcs into sclone. + */ + if (refarc && a->type == refarc->type && a->co == refarc->co) { + canmerge = 1; + } else { + struct state *s; + + canmerge = 0; + for (s = sclone; s->ins; s = s->ins->from) { + if (s->nins == 1 && + a->type == s->ins->type && a->co == s->ins->co) { + canmerge = 1; + break; + } + } + } + + if (canmerge) { + /* + * We can merge into sclone. If we previously made a child + * clone state, drop it; there's no need to visit it. (This + * can happen if ssource has multiple pathways to sto, and we + * only just now found one that is provably a no-op.) + */ + if (prevclone) { + dropstate(nfa, prevclone); /* kills our outarc, too */ + } + + /* Recurse to merge sto's outarcs into sclone */ + clonesuccessorstates(nfa, sto, sclone, spredecessor, refarc, + donemap, outerdonemap, nstates); + /* sto should now be marked as previously visited */ + assert(NISERR() || donemap[sto->no] == 1); + } else if (prevclone) { + /* + * We already have a clone state for this successor, so just + * make another arc to it. + */ + cparc(nfa, a, sclone, prevclone); + } else { + /* + * We need to create a new successor clone state. + */ + struct state *stoclone; + + stoclone = newstate(nfa); + if (stoclone == NULL) { + assert(NISERR()); + break; + } + /* Mark it as to what it's a clone of */ + stoclone->tmp = sto; + /* ... and add the outarc leading to it */ + cparc(nfa, a, sclone, stoclone); + } + } else { + /* + * Non-constraint outarcs just get copied to sclone, as do outarcs + * leading to states with no constraint outarc. + */ + cparc(nfa, a, sclone, sto); + } + } + + /* + * If we are at outer level for this clone state, recurse to all its child + * clone states, clearing their tmp fields as we go. (If we're not + * outermost for sclone, leave this to be done by the outer call level.) + * Note that if we have multiple outarcs leading to the same clone state, + * it will only be recursed-to once. + */ + if (curdonemap == NULL) { + for (a = sclone->outs; a != NULL && !NISERR(); a = a->outchain) { + struct state *stoclone = a->to; + struct state *sto = stoclone->tmp; + + if (sto != NULL) { + stoclone->tmp = NULL; + clonesuccessorstates(nfa, sto, stoclone, spredecessor, refarc, + NULL, donemap, nstates); + } + } + + /* Don't forget to free sclone's donemap when done with it */ + FREE(donemap); + } } /* @@ -1630,7 +2795,7 @@ analyze( } /* - - compact - compact an NFA + - compact - construct the compact representation of an NFA ^ static void compact(struct nfa *, struct cnfa *); */ static void @@ -1651,13 +2816,16 @@ compact( narcs = 0; for (s = nfa->states; s != NULL; s = s->next) { nstates++; - narcs += 1 + s->nouts + 1; - /* 1 as a fake for flags, nouts for arcs, 1 as endmarker */ + narcs += s->nouts + 1; /* need one extra for endmarker */ } + cnfa->stflags = (char *) MALLOC(nstates * sizeof(char)); cnfa->states = (struct carc **) MALLOC(nstates * sizeof(struct carc *)); cnfa->arcs = (struct carc *) MALLOC(narcs * sizeof(struct carc)); - if (cnfa->states == NULL || cnfa->arcs == NULL) { + if (cnfa->stflags == NULL || cnfa->states == NULL || cnfa->arcs == NULL) { + if (cnfa->stflags != NULL) { + FREE(cnfa->stflags); + } if (cnfa->states != NULL) { FREE(cnfa->states); } @@ -1680,9 +2848,8 @@ compact( ca = cnfa->arcs; for (s = nfa->states; s != NULL; s = s->next) { assert((size_t) s->no < nstates); + cnfa->stflags[s->no] = 0; cnfa->states[s->no] = ca; - ca->co = 0; /* clear and skip flags "arc" */ - ca++; first = ca; for (a = s->outs; a != NULL; a = a->outchain) { switch (a->type) { @@ -1699,11 +2866,11 @@ compact( cnfa->flags |= HASLACONS; break; default: - assert(NOTREACHED); + NERR(REG_ASSERT); break; } } - carcsort(first, ca-1); + carcsort(first, ca - first); ca->co = COLORLESS; ca->to = 0; ca++; @@ -1716,40 +2883,46 @@ compact( */ for (a = nfa->pre->outs; a != NULL; a = a->outchain) { - cnfa->states[a->to->no]->co = 1; + cnfa->stflags[a->to->no] = CNFA_NOPROGRESS; } - cnfa->states[nfa->pre->no]->co = 1; + cnfa->stflags[nfa->pre->no] = CNFA_NOPROGRESS; } /* - carcsort - sort compacted-NFA arcs by color - * Really dumb algorithm, but if the list is long enough for that to matter, - * you're in real trouble anyway. ^ static void carcsort(struct carc *, struct carc *); */ static void carcsort( struct carc *first, - struct carc *last) + size_t n) { - struct carc *p; - struct carc *q; - struct carc tmp; - - if (last - first <= 1) { - return; + if (n > 1) { + qsort(first, n, sizeof(struct carc), carc_cmp); } +} - for (p = first; p <= last; p++) { - for (q = p; q <= last; q++) { - if (p->co > q->co || (p->co == q->co && p->to > q->to)) { - assert(p != q); - tmp = *p; - *p = *q; - *q = tmp; - } - } +static int +carc_cmp( + const void *a, + const void *b) +{ + const struct carc *aa = (const struct carc *) a; + const struct carc *bb = (const struct carc *) b; + + if (aa->co < bb->co) { + return -1; } + if (aa->co > bb->co) { + return +1; + } + if (aa->to < bb->to) { + return -1; + } + if (aa->to > bb->to) { + return +1; + } + return 0; } /* @@ -1762,6 +2935,7 @@ freecnfa( { assert(cnfa->nstates != 0); /* not empty already */ cnfa->nstates = 0; + FREE(cnfa->stflags); FREE(cnfa->states); FREE(cnfa->arcs); } @@ -1777,6 +2951,8 @@ dumpnfa( { #ifdef REG_DEBUG struct state *s; + int nstates = 0; + int narcs = 0; fprintf(f, "pre %d, post %d", nfa->pre->no, nfa->post->no); if (nfa->bos[0] != COLORLESS) { @@ -1794,7 +2970,10 @@ dumpnfa( fprintf(f, "\n"); for (s = nfa->states; s != NULL; s = s->next) { dumpstate(s, f); + nstates++; + narcs += s->nouts; } + fprintf(f, "total of %d states, %d arcs\n", nstates, narcs); if (nfa->parent == NULL) { dumpcolors(nfa->cm, f); } @@ -1847,37 +3026,28 @@ dumparcs( FILE *f) { int pos; + struct arc *a; - assert(s->nouts > 0); - /* printing arcs in reverse order is usually clearer */ - pos = dumprarcs(s->outs, s, f, 1); - if (pos != 1) { - fprintf(f, "\n"); - } -} - -/* - - dumprarcs - dump remaining outarcs, recursively, in reverse order - ^ static int dumprarcs(struct arc *, struct state *, FILE *, int); - */ -static int /* resulting print position */ -dumprarcs( - struct arc *a, - struct state *s, - FILE *f, - int pos) /* initial print position */ -{ - if (a->outchain != NULL) { - pos = dumprarcs(a->outchain, s, f, pos); + /* printing oldest arcs first is usually clearer */ + a = s->outs; + assert(a != NULL); + while (a->outchain != NULL) { + a = a->outchain; } - dumparc(a, s, f); - if (pos == 5) { + pos = 1; + do { + dumparc(a, s, f); + if (pos == 5) { + fprintf(f, "\n"); + pos = 1; + } else { + pos++; + } + a = a->outchainRev; + } while (a != NULL); + if (pos != 1) { fprintf(f, "\n"); - pos = 1; - } else { - pos++; } - return pos; } /* @@ -1984,7 +3154,7 @@ dumpcnfa( } fprintf(f, "\n"); for (st = 0; st < cnfa->nstates; st++) { - dumpcstate(st, cnfa->states[st], cnfa, f); + dumpcstate(st, cnfa, f); } fflush(f); #endif @@ -1997,25 +3167,24 @@ dumpcnfa( /* - dumpcstate - dump a compacted-NFA state in human-readable form - ^ static void dumpcstate(int, struct carc *, struct cnfa *, FILE *); + ^ static void dumpcstate(int, struct cnfa *, FILE *); */ static void dumpcstate( int st, - struct carc *ca, struct cnfa *cnfa, FILE *f) { - int i; + struct carc *ca; int pos; - fprintf(f, "%d%s", st, (ca[0].co) ? ":" : "."); + fprintf(f, "%d%s", st, (cnfa->stflags[st] & CNFA_NOPROGRESS) ? ":" : "."); pos = 1; - for (i = 1; ca[i].co != COLORLESS; i++) { - if (ca[i].co < cnfa->ncolors) { - fprintf(f, "\t[%ld]->%d", (long) ca[i].co, ca[i].to); + for (ca = cnfa->states[st]; ca->co != COLORLESS; ca++) { + if (ca->co < cnfa->ncolors) { + fprintf(f, "\t[%ld]->%d", (long) ca->co, ca->to); } else { - fprintf(f, "\t:%ld:->%d", (long) ca[i].co-cnfa->ncolors,ca[i].to); + fprintf(f, "\t:%ld:->%d", (long) (ca->co - cnfa->ncolors), ca->to); } if (pos == 5) { fprintf(f, "\n"); @@ -2024,7 +3193,7 @@ dumpcstate( pos++; } } - if (i == 1 || pos != 1) { + if (ca == cnfa->states[st] || pos != 1) { fprintf(f, "\n"); } fflush(f); diff --git a/generic/regcomp.c b/generic/regcomp.c index c93eb24..58d55fb 100644 --- a/generic/regcomp.c +++ b/generic/regcomp.c @@ -82,10 +82,7 @@ static int lexescape(struct vars *); static int lexdigits(struct vars *, int, int, int); static int brenext(struct vars *, pchr); static void skip(struct vars *); -static chr newline(NOPARMS); -#ifdef REG_DEBUG -static const chr *ch(NOPARMS); -#endif +static chr newline(void); static chr chrnamed(struct vars *, const chr *, const chr *, pchr); /* === regc_color.c === */ static void initcm(struct vars *, struct colormap *); @@ -119,17 +116,22 @@ static void dropstate(struct nfa *, struct state *); static void freestate(struct nfa *, struct state *); static void destroystate(struct nfa *, struct state *); static void newarc(struct nfa *, int, pcolor, struct state *, struct state *); +static void createarc(struct nfa *, int, pcolor, struct state *, struct state *); static struct arc *allocarc(struct nfa *, struct state *); static void freearc(struct nfa *, struct arc *); +static void changearctarget(struct arc *, struct state *); static int hasnonemptyout(struct state *); -static int nonemptyouts(struct state *); -static int nonemptyins(struct state *); static struct arc *findarc(struct state *, int, pcolor); static void cparc(struct nfa *, struct arc *, struct state *, struct state *); +static void sortins(struct nfa *, struct state *); +static int sortins_cmp(const void *, const void *); +static void sortouts(struct nfa *, struct state *); +static int sortouts_cmp(const void *, const void *); static void moveins(struct nfa *, struct state *, struct state *); -static void copyins(struct nfa *, struct state *, struct state *, int); +static void copyins(struct nfa *, struct state *, struct state *); +static void mergeins(struct nfa *, struct state *, struct arc **, int); static void moveouts(struct nfa *, struct state *, struct state *); -static void copyouts(struct nfa *, struct state *, struct state *, int); +static void copyouts(struct nfa *, struct state *, struct state *); static void cloneouts(struct nfa *, struct state *, struct state *, struct state *, int); static void delsub(struct nfa *, struct state *, struct state *); static void deltraverse(struct nfa *, struct state *, struct state *); @@ -139,33 +141,40 @@ static void cleartraverse(struct nfa *, struct state *); static void specialcolors(struct nfa *); static long optimize(struct nfa *, FILE *); static void pullback(struct nfa *, FILE *); -static int pull(struct nfa *, struct arc *); +static int pull(struct nfa *, struct arc *, struct state **); static void pushfwd(struct nfa *, FILE *); -static int push(struct nfa *, struct arc *); +static int push(struct nfa *, struct arc *, struct state **); #define INCOMPATIBLE 1 /* destroys arc */ #define SATISFIED 2 /* constraint satisfied */ #define COMPATIBLE 3 /* compatible but not satisfied yet */ static int combine(struct arc *, struct arc *); static void fixempties(struct nfa *, FILE *); -static struct state *emptyreachable(struct state *, struct state *); -static void replaceempty(struct nfa *, struct state *, struct state *); +static struct state *emptyreachable(struct nfa *, struct state *, + struct state *, struct arc **); +static int isconstraintarc(struct arc *); +static int hasconstraintout(struct state *); +static void fixconstraintloops(struct nfa *, FILE *); +static int findconstraintloop(struct nfa *, struct state *); +static void breakconstraintloop(struct nfa *, struct state *); +static void clonesuccessorstates(struct nfa *, struct state *, struct state *, + struct state *, struct arc *, char *, char *, int); static void cleanup(struct nfa *); static void markreachable(struct nfa *, struct state *, struct state *, struct state *); static void markcanreach(struct nfa *, struct state *, struct state *, struct state *); static long analyze(struct nfa *); static void compact(struct nfa *, struct cnfa *); -static void carcsort(struct carc *, struct carc *); +static void carcsort(struct carc *, size_t); +static int carc_cmp(const void *, const void *); static void freecnfa(struct cnfa *); static void dumpnfa(struct nfa *, FILE *); #ifdef REG_DEBUG static void dumpstate(struct state *, FILE *); static void dumparcs(struct state *, FILE *); -static int dumprarcs(struct arc *, struct state *, FILE *, int); static void dumparc(struct arc *, struct state *, FILE *); #endif static void dumpcnfa(struct cnfa *, FILE *); #ifdef REG_DEBUG -static void dumpcstate(int, struct carc *, struct cnfa *, FILE *); +static void dumpcstate(int, struct cnfa *, FILE *); #endif /* === regc_cvec.c === */ static struct cvec *clearcvec(struct cvec *); @@ -210,11 +219,12 @@ struct vars { struct subre *tree; /* subexpression tree */ struct subre *treechain; /* all tree nodes allocated */ struct subre *treefree; /* any free tree nodes */ - int ntree; /* number of tree nodes */ + int ntree; /* number of tree nodes, plus one */ struct cvec *cv; /* interface cvec */ struct cvec *cv2; /* utility cvec */ struct subre *lacons; /* lookahead-constraint vector */ int nlacons; /* size of lacons */ + size_t spaceused; /* approx. space used for compilation */ }; /* parsing macros; most know that `v' is the struct vars pointer */ @@ -223,13 +233,13 @@ struct vars { #define EAT(t) (SEE(t) && next(v)) /* if next is this, swallow it */ #define VISERR(vv) ((vv)->err != 0)/* have we seen an error yet? */ #define ISERR() VISERR(v) -#define VERR(vv,e) \ - ((vv)->nexttype = EOS, ((vv)->err) ? (vv)->err : ((vv)->err = (e))) +#define VERR(vv,e) ((vv)->nexttype = EOS, \ + (vv)->err = ((vv)->err ? (vv)->err : (e))) #define ERR(e) VERR(v, e) /* record an error */ #define NOERR() {if (ISERR()) return;} /* if error seen, return */ #define NOERRN() {if (ISERR()) return NULL;} /* NOERR with retval */ #define NOERRZ() {if (ISERR()) return 0;} /* NOERR with retval */ -#define INSIST(c, e) ((c) ? 0 : ERR(e)) /* if condition false, error */ +#define INSIST(c, e) do { if (!(c)) ERR(e); } while (0) /* error if c false */ #define NOTE(b) (v->re->re_info |= (b)) /* note visible condition */ #define EMPTYARC(x, y) newarc(v->nfa, EMPTY, 0, x, y) @@ -258,12 +268,14 @@ struct vars { ((a)->type == PLAIN || (a)->type == AHEAD || (a)->type == BEHIND) /* static function list */ -static struct fns functions = { +static const struct fns functions = { rfree, /* regfree insides */ }; /* - compile - compile regular expression + * Note: on failure, no resources remain allocated, so regfree() + * need not be applied to re. ^ int compile(regex_t *, const chr *, size_t, int); */ int @@ -324,17 +336,18 @@ compile( v->cv2 = NULL; v->lacons = NULL; v->nlacons = 0; + v->spaceused = 0; re->re_magic = REMAGIC; re->re_info = 0; /* bits get set during parse */ re->re_csize = sizeof(chr); re->re_guts = NULL; - re->re_fns = VS(&functions); + re->re_fns = (void*)(&functions); /* * More complex setup, malloced things. */ - re->re_guts = VS(MALLOC(sizeof(struct guts))); + re->re_guts = (void*)(MALLOC(sizeof(struct guts))); if (re->re_guts == NULL) { return freev(v, REG_ESPACE); } @@ -421,7 +434,7 @@ compile( * Can sacrifice main NFA now, so use it as work area. */ - (DISCARD) optimize(v->nfa, debug); + (void) optimize(v->nfa, debug); CNOERR(); makesearch(v, v->nfa); CNOERR(); @@ -593,13 +606,15 @@ makesearch( break; } } - if (b != NULL && s->tmp == NULL) { - /* - * Must be split if not already in the list (fixes bugs 505048, - * 230589, 840258, 504785). - */ - s->tmp = slist; + /* + * We want to mark states as being in the list already by having non + * NULL tmp fields, but we can't just store the old slist value in tmp + * because that doesn't work for the first such state. Instead, the + * first list entry gets its own address in tmp. + */ + if (b != NULL && s->tmp == NULL) { + s->tmp = (slist != NULL) ? slist : s; slist = s; } } @@ -610,8 +625,9 @@ makesearch( for (s=slist ; s!=NULL ; s=s2) { s2 = newstate(nfa); - - copyouts(nfa, s, s2, 1); + NOERR(); + copyouts(nfa, s, s2); + NOERR(); for (a=s->ins ; a!=NULL ; a=b) { b = a->inchain; @@ -620,7 +636,7 @@ makesearch( freearc(nfa, a); } } - s2 = s->tmp; + s2 = (s->tmp != s) ? s->tmp : NULL; s->tmp = NULL; /* clean up while we're at it */ } } @@ -982,6 +998,7 @@ parseqatom( NOERR(); assert(v->nextvalue > 0); atom = subre(v, 'b', BACKR, lp, rp); + NOERR(); subno = v->nextvalue; atom->subno = subno; EMPTYARC(lp, rp); /* temporarily, so there's something */ @@ -996,13 +1013,13 @@ parseqatom( switch (v->nexttype) { case '*': m = 0; - n = INFINITY; + n = DUPINF; qprefer = (v->nextvalue) ? LONGER : SHORTER; NEXT(); break; case '+': m = 1; - n = INFINITY; + n = DUPINF; qprefer = (v->nextvalue) ? LONGER : SHORTER; NEXT(); break; @@ -1019,7 +1036,7 @@ parseqatom( if (SEE(DIGIT)) { n = scannum(v); } else { - n = INFINITY; + n = DUPINF; } if (m > n) { ERR(REG_BADBR); @@ -1102,11 +1119,17 @@ parseqatom( /* * Prepare a general-purpose state skeleton. * - * ---> [s] ---prefix---> [begin] ---atom---> [end] ----rest---> [rp] - * / / - * [lp] ----> [s2] ----bypass--------------------- + * In the no-backrefs case, we want this: + * + * [lp] ---> [s] ---prefix---> [begin] ---atom---> [end] ---rest---> [rp] * - * where bypass is an empty, and prefix is some repetitions of atom + * where prefix is some repetitions of atom. In the general case we need + * + * [lp] ---> [s] ---iterator---> [s2] ---rest---> [rp] + * + * where the iterator wraps around [begin] ---atom---> [end] + * + * We make the s state here for both cases; s2 is made below if needed */ s = newstate(v->nfa); /* first, new endpoints for the atom */ @@ -1117,11 +1140,9 @@ parseqatom( NOERR(); atom->begin = s; atom->end = s2; - s = newstate(v->nfa); /* and spots for prefix and bypass */ - s2 = newstate(v->nfa); + s = newstate(v->nfa); /* set up starting state */ NOERR(); EMPTYARC(lp, s); - EMPTYARC(lp, s2); NOERR(); /* @@ -1129,6 +1150,7 @@ parseqatom( */ t = subre(v, '.', COMBINE(qprefer, atom->flags), lp, rp); + NOERR(); t->left = atom; atomp = &t->left; @@ -1142,6 +1164,7 @@ parseqatom( assert(top->op == '=' && top->left == NULL && top->right == NULL); top->left = subre(v, '=', top->flags, top->begin, lp); + NOERR(); top->op = '.'; top->right = t; @@ -1166,27 +1189,8 @@ parseqatom( } /* - * It's quantifier time; first, turn x{0,...} into x{1,...}|empty - */ - - if (m == 0) { - EMPTYARC(s2, atom->end);/* the bypass */ - assert(PREF(qprefer) != 0); - f = COMBINE(qprefer, atom->flags); - t = subre(v, '|', f, lp, atom->end); - NOERR(); - t->left = atom; - t->right = subre(v, '|', PREF(f), s2, atom->end); - NOERR(); - t->right->left = subre(v, '=', 0, s2, atom->end); - NOERR(); - *atomp = t; - atomp = &t->left; - m = 1; - } - - /* - * Deal with the rest of the quantifier. + * It's quantifier time. If the atom is just a backref, we'll let it deal + * with quantifiers internally. */ if (atomtype == BACKREF) { @@ -1204,21 +1208,29 @@ parseqatom( atom->min = (short) m; atom->max = (short) n; atom->flags |= COMBINE(qprefer, atom->flags); + /* rest of branch can be strung starting from atom->end */ + s2 = atom->end; } else if (m == 1 && n == 1) { /* * No/vacuous quantifier: done. */ EMPTYARC(s, atom->begin); /* empty prefix */ - } else { + /* rest of branch can be strung starting from atom->end */ + s2 = atom->end; + } else if (m > 0 && !(atom->flags & BACKR)) { /* - * Turn x{m,n} into x{m-1,n-1}x, with capturing parens in only second - * x + * If there's no backrefs involved, we can turn x{m,n} into + * x{m-1,n-1}x, with capturing parens in only the second x. This + * is valid because we only care about capturing matches from the + * final iteration of the quantifier. It's a win because we can + * implement the backref-free left side as a plain DFA node, since + * we don't really care where its submatches are. */ dupnfa(v->nfa, atom->begin, atom->end, s, atom->begin); - assert(m >= 1 && m != INFINITY && n >= 1); - repeat(v, s, atom->begin, m-1, (n == INFINITY) ? n : n-1); + assert(m >= 1 && m != DUPINF && n >= 1); + repeat(v, s, atom->begin, m-1, (n == DUPINF) ? n : n-1); f = COMBINE(qprefer, atom->flags); t = subre(v, '.', f, s, atom->end); /* prefix and atom */ NOERR(); @@ -1226,6 +1238,24 @@ parseqatom( NOERR(); t->right = atom; *atomp = t; + /* rest of branch can be strung starting from atom->end */ + s2 = atom->end; + } else { + /* general case: need an iteration node */ + s2 = newstate(v->nfa); + NOERR(); + moveouts(v->nfa, atom->end, s2); + NOERR(); + dupnfa(v->nfa, atom->begin, atom->end, s, s2); + repeat(v, s, s2, m, n); + f = COMBINE(qprefer, atom->flags); + t = subre(v, '*', f, s, s2); + NOERR(); + t->min = (short) m; + t->max = (short) n; + t->left = atom; + *atomp = t; + /* rest of branch is to be strung from iteration's end state */ } /* @@ -1234,10 +1264,10 @@ parseqatom( t = top->right; if (!(SEE('|') || SEE(stopper) || SEE(EOS))) { - t->right = parsebranch(v, stopper, type, atom->end, rp, 1); + t->right = parsebranch(v, stopper, type, s2, rp, 1); } else { - EMPTYARC(atom->end, rp); - t->right = subre(v, '=', 0, atom->end, rp); + EMPTYARC(s2, rp); + t->right = subre(v, '=', 0, s2, rp); } NOERR(); assert(SEE('|') || SEE(stopper) || SEE(EOS)); @@ -1304,6 +1334,8 @@ scannum( /* - repeat - replicate subNFA for quantifiers + * The sub-NFA strung from lp to rp is modified to represent m to n + * repetitions of its initial contents. * The duplication sequences used here are chosen carefully so that any * pointers starting out pointing into the subexpression end up pointing into * the last occurrence. (Note that it may not be strung between the same left @@ -1323,7 +1355,7 @@ repeat( #define SOME 2 #define INF 3 #define PAIR(x, y) ((x)*4 + (y)) -#define REDUCE(x) ( ((x) == INFINITY) ? INF : (((x) > 1) ? SOME : (x)) ) +#define REDUCE(x) ( ((x) == DUPINF) ? INF : (((x) > 1) ? SOME : (x)) ) const int rm = REDUCE(m); const int rn = REDUCE(n); struct state *s, *s2; @@ -1713,11 +1745,11 @@ subre( v->treechain = ret; } - assert(strchr("|.b(=", op) != NULL); + assert(strchr("=b|.*(", op) != NULL); ret->op = op; ret->flags = flags; - ret->retry = 0; + ret->id = 0; /* will be assigned later */ ret->subno = 0; ret->min = ret->max = 1; ret->left = NULL; @@ -1770,7 +1802,8 @@ freesrnode( } sr->flags = 0; - if (v != NULL) { + if (v != NULL && v->treechain != NULL) { + /* we're still parsing, maybe we can reuse the subre */ sr->left = v->treefree; v->treefree = sr; } else { @@ -1798,7 +1831,7 @@ optst( } /* - - numst - number tree nodes (assigning retry indexes) + - numst - number tree nodes (assigning "id" indexes) ^ static int numst(struct subre *, int); */ static int /* next number */ @@ -1811,7 +1844,7 @@ numst( assert(t != NULL); i = start; - t->retry = (short) i++; + t->id = (short) i++; if (t->left != NULL) { i = numst(t->left, i); } @@ -1823,6 +1856,19 @@ numst( /* - markst - mark tree nodes as INUSE + * Note: this is a great deal more subtle than it looks. During initial + * parsing of a regex, all subres are linked into the treechain list; + * discarded ones are also linked into the treefree list for possible reuse. + * After we are done creating all subres required for a regex, we run markst() + * then cleanst(), which results in discarding all subres not reachable from + * v->tree. We then clear v->treechain, indicating that subres must be found + * by descending from v->tree. This changes the behavior of freesubre(): it + * will henceforth FREE() unwanted subres rather than sticking them into the + * treefree list. (Doing that any earlier would result in dangling links in + * the treechain list.) This all means that freev() will clean up correctly + * if invoked before or after markst()+cleanst(); but it would not work if + * called partway through this state conversion, so we mustn't error out + * in or between these two functions. ^ static void markst(struct subre *); */ static void @@ -1874,10 +1920,10 @@ nfatree( assert(t != NULL && t->begin != NULL); if (t->left != NULL) { - (DISCARD) nfatree(v, t->left, f); + (void) nfatree(v, t->left, f); } if (t->right != NULL) { - (DISCARD) nfatree(v, t->right, f); + (void) nfatree(v, t->right, f); } return nfanode(v, t, f); @@ -1929,24 +1975,26 @@ newlacon( struct state *end, int pos) { - struct subre *sub; int n; + struct subre *newlacons; + struct subre *sub; if (v->nlacons == 0) { - v->lacons = (struct subre *) MALLOC(2 * sizeof(struct subre)); n = 1; /* skip 0th */ - v->nlacons = 2; + newlacons = (struct subre *) MALLOC(2 * sizeof(struct subre)); } else { - v->lacons = (struct subre *) REALLOC(v->lacons, - (v->nlacons+1)*sizeof(struct subre)); - n = v->nlacons++; + n = v->nlacons; + newlacons = (struct subre *) REALLOC(v->lacons, + (n + 1) * sizeof(struct subre)); } - if (v->lacons == NULL) { + if (newlacons == NULL) { ERR(REG_ESPACE); return 0; } + v->lacons = newlacons; + v->nlacons = n + 1; sub = &v->lacons[n]; sub->begin = begin; sub->end = end; @@ -1994,18 +2042,20 @@ rfree( g = (struct guts *) re->re_guts; re->re_guts = NULL; re->re_fns = NULL; - g->magic = 0; - freecm(&g->cmap); - if (g->tree != NULL) { - freesubre(NULL, g->tree); - } - if (g->lacons != NULL) { - freelacons(g->lacons, g->nlacons); - } - if (!NULLCNFA(g->search)) { - freecnfa(&g->search); + if (g != NULL) { + g->magic = 0; + freecm(&g->cmap); + if (g->tree != NULL) { + freesubre(NULL, g->tree); + } + if (g->lacons != NULL) { + freelacons(g->lacons, g->nlacons); + } + if (!NULLCNFA(g->search)) { + freecnfa(&g->search); + } + FREE(g); } - FREE(g); } /* @@ -2037,11 +2087,11 @@ dump( fprintf(f, "\n\n\n========= DUMP ==========\n"); fprintf(f, "nsub %d, info 0%lo, csize %d, ntree %d\n", - re->re_nsub, re->re_info, re->re_csize, g->ntree); + (int) re->re_nsub, re->re_info, re->re_csize, g->ntree); dumpcolors(&g->cmap, f); if (!NULLCNFA(g->search)) { - printf("\nsearch:\n"); + fprintf(f, "\nsearch:\n"); dumpcnfa(&g->search, f); } for (i = 1; i < g->nlacons; i++) { @@ -2108,7 +2158,7 @@ stdump( } if (t->min != 1 || t->max != 1) { fprintf(f, " {%d,", t->min); - if (t->max != INFINITY) { + if (t->max != DUPINF) { fprintf(f, "%d", t->max); } fprintf(f, "}"); @@ -2146,14 +2196,14 @@ stid( size_t bufsize) { /* - * Big enough for hex int or decimal t->retry? + * Big enough for hex int or decimal t->id? */ - if (bufsize < sizeof(void*)*2 + 3 || bufsize < sizeof(t->retry)*3 + 1) { + if (bufsize < sizeof(void*)*2 + 3 || bufsize < sizeof(t->id)*3 + 1) { return "unable"; } - if (t->retry != 0) { - sprintf(buf, "%d", t->retry); + if (t->id != 0) { + sprintf(buf, "%d", t->id); } else { sprintf(buf, "%p", t); } diff --git a/generic/regcustom.h b/generic/regcustom.h index 1c970ea..095385d 100644 --- a/generic/regcustom.h +++ b/generic/regcustom.h @@ -36,10 +36,9 @@ * Overrides for regguts.h definitions, if any. */ -#define FUNCPTR(name, args) (*name)args -#define MALLOC(n) VS(attemptckalloc(n)) -#define FREE(p) ckfree(VS(p)) -#define REALLOC(p,n) VS(attemptckrealloc(VS(p),n)) +#define MALLOC(n) (void*)(attemptckalloc(n)) +#define FREE(p) ckfree((void*)(p)) +#define REALLOC(p,n) (void*)(attemptckrealloc((void*)(p),n)) /* * Do not insert extras between the "begin" and "end" lines - this chunk is @@ -60,12 +59,6 @@ #ifdef __REG_REGOFF_T #undef __REG_REGOFF_T #endif -#ifdef __REG_VOID_T -#undef __REG_VOID_T -#endif -#ifdef __REG_CONST -#undef __REG_CONST -#endif #ifdef __REG_NOFRONT #undef __REG_NOFRONT #endif @@ -75,8 +68,6 @@ /* Interface types */ #define __REG_WIDE_T Tcl_UniChar #define __REG_REGOFF_T long /* Not really right, but good enough... */ -#define __REG_VOID_T void -#define __REG_CONST const /* Names and declarations */ #define __REG_WIDE_COMPILE TclReComp #define __REG_WIDE_EXEC TclReExec @@ -100,7 +91,7 @@ typedef int celt; /* Type to hold chr, or NOCELT */ #if TCL_UTF_MAX > 4 #define CHRBITS 32 /* Bits in a chr; must not use sizeof */ #define CHR_MIN 0x00000000 /* Smallest and largest chr; the value */ -#define CHR_MAX 0xffffffff /* CHR_MAX-CHR_MIN+1 should fit in uchr */ +#define CHR_MAX 0x10ffff /* CHR_MAX-CHR_MIN+1 should fit in uchr */ #else #define CHRBITS 16 /* Bits in a chr; must not use sizeof */ #define CHR_MIN 0x0000 /* Smallest and largest chr; the value */ diff --git a/generic/rege_dfa.c b/generic/rege_dfa.c index 920ea6c..e5f22c4 100644 --- a/generic/rege_dfa.c +++ b/generic/rege_dfa.c @@ -84,7 +84,7 @@ longest( if (v->eflags®_FTRACE) { while (cp < realstop) { - FDEBUG(("+++ at c%d +++\n", css - d->ssets)); + FDEBUG(("+++ at c%d +++\n", (int) (css - d->ssets))); co = GETCOLOR(cm, *cp); FDEBUG(("char %c, color %ld\n", (char)*cp, (long)co)); ss = css->outs[co]; @@ -118,7 +118,7 @@ longest( * Shutdown. */ - FDEBUG(("+++ shutdown at c%d +++\n", css - d->ssets)); + FDEBUG(("+++ shutdown at c%d +++\n", (int) (css - d->ssets))); if (cp == v->stop && stop == v->stop) { if (hitstopp != NULL) { *hitstopp = 1; @@ -213,7 +213,7 @@ shortest( if (v->eflags®_FTRACE) { while (cp < realmax) { - FDEBUG(("--- at c%d ---\n", css - d->ssets)); + FDEBUG(("--- at c%d ---\n", (int) (css - d->ssets))); co = GETCOLOR(cm, *cp); FDEBUG(("char %c, color %ld\n", (char)*cp, (long)co)); ss = css->outs[co]; @@ -516,14 +516,14 @@ miss( gotState = 0; for (i = 0; i < d->nstates; i++) { if (ISBSET(css->states, i)) { - for (ca = cnfa->states[i]+1; ca->co != COLORLESS; ca++) { + for (ca = cnfa->states[i]; ca->co != COLORLESS; ca++) { if (ca->co == co) { BSET(d->work, ca->to); gotState = 1; if (ca->to == cnfa->post) { isPost = 1; } - if (!cnfa->states[ca->to]->co) { + if (!(cnfa->stflags[ca->to] & CNFA_NOPROGRESS)) { noProgress = 0; } FDEBUG(("%d -> %d\n", i, ca->to)); @@ -537,8 +537,8 @@ miss( doLAConstraints = 0; for (i = 0; i < d->nstates; i++) { if (ISBSET(d->work, i)) { - for (ca = cnfa->states[i]+1; ca->co != COLORLESS; ca++) { - if (ca->co <= cnfa->ncolors) { + for (ca = cnfa->states[i]; ca->co != COLORLESS; ca++) { + if (ca->co < cnfa->ncolors) { continue; /* NOTE CONTINUE */ } sawLAConstraints = 1; @@ -553,7 +553,7 @@ miss( if (ca->to == cnfa->post) { isPost = 1; } - if (!cnfa->states[ca->to]->co) { + if (!(cnfa->stflags[ca->to] & CNFA_NOPROGRESS)) { noProgress = 0; } FDEBUG(("%d :> %d\n", i, ca->to)); @@ -572,7 +572,7 @@ miss( for (p = d->ssets, i = d->nssused; i > 0; p++, i--) { if (HIT(h, d->work, p, d->wordsper)) { - FDEBUG(("cached c%d\n", p - d->ssets)); + FDEBUG(("cached c%d\n", (int) (p - d->ssets))); break; /* NOTE BREAK OUT */ } } @@ -594,7 +594,8 @@ miss( } if (!sawLAConstraints) { /* lookahead conds. always cache miss */ - FDEBUG(("c%d[%d]->c%d\n", css - d->ssets, co, p - d->ssets)); + FDEBUG(("c%d[%d]->c%d\n", + (int) (css - d->ssets), co, (int) (p - d->ssets))); css->outs[co] = p; css->inchain[co] = p->ins; p->ins.ss = css; @@ -663,7 +664,7 @@ getVacantSS( ap = ss->ins; while ((p = ap.ss) != NULL) { co = ap.co; - FDEBUG(("zapping c%d's %ld outarc\n", p - d->ssets, (long)co)); + FDEBUG(("zapping c%d's %ld outarc\n", (int) (p - d->ssets), (long)co)); p->outs[co] = NULL; ap = p->inchain[co]; p->inchain[co].ss = NULL; /* paranoia */ @@ -680,7 +681,7 @@ getVacantSS( if (p == NULL) { continue; /* NOTE CONTINUE */ } - FDEBUG(("del outarc %d from c%d's in chn\n", i, p - d->ssets)); + FDEBUG(("del outarc %d from c%d's in chn\n", i, (int) (p - d->ssets))); if (p->ins.ss == ss && p->ins.co == i) { p->ins = ss->inchain[i]; } else { @@ -772,7 +773,7 @@ pickNextSS( if ((ss->lastseen == NULL || ss->lastseen < ancient) && !(ss->flags&LOCKED)) { d->search = ss + 1; - FDEBUG(("replacing c%d\n", ss - d->ssets)); + FDEBUG(("replacing c%d\n", (int) (ss - d->ssets))); return ss; } } @@ -780,7 +781,7 @@ pickNextSS( if ((ss->lastseen == NULL || ss->lastseen < ancient) && !(ss->flags&LOCKED)) { d->search = ss + 1; - FDEBUG(("replacing c%d\n", ss - d->ssets)); + FDEBUG(("replacing c%d\n", (int) (ss - d->ssets))); return ss; } } diff --git a/generic/regerror.c b/generic/regerror.c index a1a0163..49d93ed 100644 --- a/generic/regerror.c +++ b/generic/regerror.c @@ -41,7 +41,7 @@ static const char unk[] = "*** unknown regex error code 0x%x ***"; * Struct to map among codes, code names, and explanations. */ -static struct rerr { +static const struct rerr { int code; const char *name; const char *explain; @@ -62,7 +62,7 @@ regerror( char *errbuf, /* Result buffer (unless errbuf_size==0) */ size_t errbuf_size) /* Available space in errbuf, can be 0 */ { - struct rerr *r; + const struct rerr *r; const char *msg; char convbuf[sizeof(unk)+50]; /* 50 = plenty for int */ size_t len; diff --git a/generic/regerrs.h b/generic/regerrs.h index 72548ff..ee203d5 100644 --- a/generic/regerrs.h +++ b/generic/regerrs.h @@ -16,5 +16,5 @@ { REG_INVARG, "REG_INVARG", "invalid argument to regex function" }, { REG_MIXED, "REG_MIXED", "character widths of regex and string differ" }, { REG_BADOPT, "REG_BADOPT", "invalid embedded option" }, -{ REG_ETOOBIG, "REG_ETOOBIG", "nfa has too many states" }, +{ REG_ETOOBIG, "REG_ETOOBIG", "regular expression is too complex" }, { REG_ECOLORS, "REG_ECOLORS", "too many colors" }, diff --git a/generic/regex.h b/generic/regex.h index 9466fbb..8845f72 100644 --- a/generic/regex.h +++ b/generic/regex.h @@ -92,12 +92,6 @@ extern "C" { #ifdef __REG_REGOFF_T #undef __REG_REGOFF_T #endif -#ifdef __REG_VOID_T -#undef __REG_VOID_T -#endif -#ifdef __REG_CONST -#undef __REG_CONST -#endif #ifdef __REG_NOFRONT #undef __REG_NOFRONT #endif @@ -107,8 +101,6 @@ extern "C" { /* interface types */ #define __REG_WIDE_T Tcl_UniChar #define __REG_REGOFF_T long /* not really right, but good enough... */ -#define __REG_VOID_T void -#define __REG_CONST const /* names and declarations */ #define __REG_WIDE_COMPILE TclReComp #define __REG_WIDE_EXEC TclReExec @@ -134,26 +126,6 @@ typedef long regoff_t; #endif /* - * For benefit of old compilers, we offer <sys/types.h> the option of - * overriding the `void' type used to declare nonexistent return types. - */ -#ifdef __REG_VOID_T -typedef __REG_VOID_T re_void; -#else -typedef void re_void; -#endif - -/* - * Also for benefit of old compilers, <sys/types.h> can supply a macro which - * expands to a substitute for `const'. - */ -#ifndef __REG_CONST -#define __REG_CONST const -#endif - - - -/* * other interface types */ @@ -197,13 +169,13 @@ typedef struct { /* * compilation ^ #ifndef __REG_NOCHAR - ^ int re_comp(regex_t *, __REG_CONST char *, size_t, int); + ^ int re_comp(regex_t *, const char *, size_t, int); ^ #endif ^ #ifndef __REG_NOFRONT - ^ int regcomp(regex_t *, __REG_CONST char *, int); + ^ int regcomp(regex_t *, const char *, int); ^ #endif ^ #ifdef __REG_WIDE_T - ^ int __REG_WIDE_COMPILE(regex_t *, __REG_CONST __REG_WIDE_T *, size_t, int); + ^ int __REG_WIDE_COMPILE(regex_t *, const __REG_WIDE_T *, size_t, int); ^ #endif */ #define REG_BASIC 000000 /* BREs (convenience) */ @@ -228,14 +200,14 @@ typedef struct { /* * execution ^ #ifndef __REG_NOCHAR - ^ int re_exec(regex_t *, __REG_CONST char *, size_t, + ^ int re_exec(regex_t *, const char *, size_t, ^ rm_detail_t *, size_t, regmatch_t [], int); ^ #endif ^ #ifndef __REG_NOFRONT - ^ int regexec(regex_t *, __REG_CONST char *, size_t, regmatch_t [], int); + ^ int regexec(regex_t *, const char *, size_t, regmatch_t [], int); ^ #endif ^ #ifdef __REG_WIDE_T - ^ int __REG_WIDE_EXEC(regex_t *, __REG_CONST __REG_WIDE_T *, size_t, + ^ int __REG_WIDE_EXEC(regex_t *, const __REG_WIDE_T *, size_t, ^ rm_detail_t *, size_t, regmatch_t [], int); ^ #endif */ @@ -248,7 +220,7 @@ typedef struct { /* * misc generics (may be more functions here eventually) - ^ re_void regfree(regex_t *); + ^ void regfree(regex_t *); */ /* @@ -260,7 +232,7 @@ typedef struct { * of character is used for error reports is independent of what kind is used * in matching. * - ^ extern size_t regerror(int, __REG_CONST regex_t *, char *, size_t); + ^ extern size_t regerror(int, const regex_t *, char *, size_t); */ #define REG_OKAY 0 /* no errors detected */ #define REG_NOMATCH 1 /* failed to match */ @@ -280,7 +252,7 @@ typedef struct { #define REG_INVARG 16 /* invalid argument to regex function */ #define REG_MIXED 17 /* character widths of regex and string differ */ #define REG_BADOPT 18 /* invalid embedded option */ -#define REG_ETOOBIG 19 /* nfa has too many states */ +#define REG_ETOOBIG 19 /* regular expression is too complex */ #define REG_ECOLORS 20 /* too many colors */ /* two specials for debugging and testing */ #define REG_ATOI 101 /* convert error-code name to number */ @@ -293,25 +265,25 @@ typedef struct { /* automatically gathered by fwd; do not hand-edit */ /* === regproto.h === */ #ifndef __REG_NOCHAR -int re_comp(regex_t *, __REG_CONST char *, size_t, int); +int re_comp(regex_t *, const char *, size_t, int); #endif #ifndef __REG_NOFRONT -int regcomp(regex_t *, __REG_CONST char *, int); +int regcomp(regex_t *, const char *, int); #endif #ifdef __REG_WIDE_T -MODULE_SCOPE int __REG_WIDE_COMPILE(regex_t *, __REG_CONST __REG_WIDE_T *, size_t, int); +MODULE_SCOPE int __REG_WIDE_COMPILE(regex_t *, const __REG_WIDE_T *, size_t, int); #endif #ifndef __REG_NOCHAR -int re_exec(regex_t *, __REG_CONST char *, size_t, rm_detail_t *, size_t, regmatch_t [], int); +int re_exec(regex_t *, const char *, size_t, rm_detail_t *, size_t, regmatch_t [], int); #endif #ifndef __REG_NOFRONT -int regexec(regex_t *, __REG_CONST char *, size_t, regmatch_t [], int); +int regexec(regex_t *, const char *, size_t, regmatch_t [], int); #endif #ifdef __REG_WIDE_T -MODULE_SCOPE int __REG_WIDE_EXEC(regex_t *, __REG_CONST __REG_WIDE_T *, size_t, rm_detail_t *, size_t, regmatch_t [], int); +MODULE_SCOPE int __REG_WIDE_EXEC(regex_t *, const __REG_WIDE_T *, size_t, rm_detail_t *, size_t, regmatch_t [], int); #endif -MODULE_SCOPE re_void regfree(regex_t *); -MODULE_SCOPE size_t regerror(int, __REG_CONST regex_t *, char *, size_t); +MODULE_SCOPE void regfree(regex_t *); +MODULE_SCOPE size_t regerror(int, const regex_t *, char *, size_t); /* automatically gathered by fwd; do not hand-edit */ /* =====^!^===== end forwards =====^!^===== */ diff --git a/generic/regexec.c b/generic/regexec.c index ad4b6e6..128d439 100644 --- a/generic/regexec.c +++ b/generic/regexec.c @@ -44,7 +44,7 @@ struct sset { /* state set */ unsigned hash; /* hash of bitvector */ #define HASH(bv, nw) (((nw) == 1) ? *(bv) : hash(bv, nw)) #define HIT(h,bv,ss,nw) ((ss)->hash == (h) && ((nw) == 1 || \ - memcmp(VS(bv), VS((ss)->states), (nw)*sizeof(unsigned)) == 0)) + memcmp((void*)(bv), (void*)((ss)->states), (nw)*sizeof(unsigned)) == 0)) int flags; #define STARTER 01 /* the initial state set */ #define POSTSTATE 02 /* includes the goal state */ @@ -107,13 +107,13 @@ struct vars { chr *start; /* start of string */ chr *stop; /* just past end of string */ int err; /* error code if any (0 none) */ - regoff_t *mem; /* memory vector for backtracking */ + struct dfa **subdfas; /* per-subre DFAs */ struct smalldfa dfa1; struct smalldfa dfa2; }; #define VISERR(vv) ((vv)->err != 0) /* have we seen an error yet? */ #define ISERR() VISERR(v) -#define VERR(vv,e) (((vv)->err) ? (vv)->err : ((vv)->err = (e))) +#define VERR(vv,e) ((vv)->err = ((vv)->err ? (vv)->err : (e))) #define ERR(e) VERR(v, e) /* record an error */ #define NOERR() {if (ISERR()) return v->err;} /* if error seen, return it */ #define OFF(p) ((p) - v->start) @@ -126,21 +126,20 @@ struct vars { /* automatically gathered by fwd; do not hand-edit */ /* === regexec.c === */ int exec(regex_t *, const chr *, size_t, rm_detail_t *, size_t, regmatch_t [], int); +static struct dfa *getsubdfa(struct vars *, struct subre *); static int simpleFind(struct vars *const, struct cnfa *const, struct colormap *const); static int complicatedFind(struct vars *const, struct cnfa *const, struct colormap *const); static int complicatedFindLoop(struct vars *const, struct cnfa *const, struct colormap *const, struct dfa *const, struct dfa *const, chr **const); -static void zapSubexpressions(regmatch_t *const, const size_t); -static void zapSubtree(struct vars *const, struct subre *const); +static void zapallsubs(regmatch_t *const, const size_t); +static void zaptreesubs(struct vars *const, struct subre *const); static void subset(struct vars *const, struct subre *const, chr *const, chr *const); -static int dissect(struct vars *const, struct subre *, chr *const, chr *const); -static int concatenationDissect(struct vars *const, struct subre *const, chr *const, chr *const); -static int alternationDissect(struct vars *const, struct subre *, chr *const, chr *const); -static inline int complicatedDissect(struct vars *const, struct subre *const, chr *const, chr *const); -static int complicatedCapturingDissect(struct vars *const, struct subre *const, chr *const, chr *const); -static int complicatedConcatenationDissect(struct vars *const, struct subre *const, chr *const, chr *const); -static int complicatedReversedDissect(struct vars *const, struct subre *const, chr *const, chr *const); -static int complicatedBackrefDissect(struct vars *const, struct subre *const, chr *const, chr *const); -static int complicatedAlternationDissect(struct vars *const, struct subre *, chr *const, chr *const); +static int cdissect(struct vars *, struct subre *, chr *, chr *); +static int ccondissect(struct vars *, struct subre *, chr *, chr *); +static int crevcondissect(struct vars *, struct subre *, chr *, chr *); +static int cbrdissect(struct vars *, struct subre *, chr *, chr *); +static int caltdissect(struct vars *, struct subre *, chr *, chr *); +static int citerdissect(struct vars *, struct subre *, chr *, chr *); +static int creviterdissect(struct vars *, struct subre *, chr *, chr *); /* === rege_dfa.c === */ static chr *longest(struct vars *const, struct dfa *const, chr *const, chr *const, int *const); static chr *shortest(struct vars *const, struct dfa *const, chr *const, chr *const, chr *const, chr **const, int *const); @@ -174,10 +173,11 @@ exec( AllocVars(v); int st, backref; size_t n; + size_t i; #define LOCALMAT 20 regmatch_t mat[LOCALMAT]; -#define LOCALMEM 40 - regoff_t mem[LOCALMEM]; +#define LOCALDFAS 40 + struct dfa *subdfas[LOCALDFAS]; /* * Sanity checks. @@ -235,28 +235,20 @@ exec( v->start = (chr *)string; v->stop = (chr *)string + len; v->err = 0; - if (backref) { - /* - * Need retry memory. - */ - - assert(v->g->ntree >= 0); - n = (size_t)v->g->ntree; - if (n <= LOCALMEM) { - v->mem = mem; - } else { - v->mem = (regoff_t *) MALLOC(n*sizeof(regoff_t)); - } - if (v->mem == NULL) { - if (v->pmatch != pmatch && v->pmatch != mat) { - FREE(v->pmatch); - } - FreeVars(v); - return REG_ESPACE; - } - } else { - v->mem = NULL; + assert(v->g->ntree >= 0); + n = (size_t) v->g->ntree; + if (n <= LOCALDFAS) + v->subdfas = subdfas; + else + v->subdfas = (struct dfa **) MALLOC(n * sizeof(struct dfa *)); + if (v->subdfas == NULL) { + if (v->pmatch != pmatch && v->pmatch != mat) + FREE(v->pmatch); + FreeVars(v); + return REG_ESPACE; } + for (i = 0; i < n; i++) + v->subdfas[i] = NULL; /* * Do it. @@ -274,9 +266,9 @@ exec( */ if (st == REG_OKAY && v->pmatch != pmatch && nmatch > 0) { - zapSubexpressions(pmatch, nmatch); + zapallsubs(pmatch, nmatch); n = (nmatch < v->nmatch) ? nmatch : v->nmatch; - memcpy(VS(pmatch), VS(v->pmatch), n*sizeof(regmatch_t)); + memcpy((void*)(pmatch), (void*)(v->pmatch), n*sizeof(regmatch_t)); } /* @@ -286,14 +278,35 @@ exec( if (v->pmatch != pmatch && v->pmatch != mat) { FREE(v->pmatch); } - if (v->mem != NULL && v->mem != mem) { - FREE(v->mem); + n = (size_t) v->g->ntree; + for (i = 0; i < n; i++) { + if (v->subdfas[i] != NULL) + freeDFA(v->subdfas[i]); } + if (v->subdfas != subdfas) + FREE(v->subdfas); FreeVars(v); return st; } /* + - getsubdfa - create or re-fetch the DFA for a subre node + * We only need to create the DFA once per overall regex execution. + * The DFA will be freed by the cleanup step in exec(). + */ +static struct dfa * +getsubdfa(struct vars * v, + struct subre * t) +{ + if (v->subdfas[t->id] == NULL) { + v->subdfas[t->id] = newDFA(v, &t->cnfa, &v->g->cmap, DOMALLOC); + if (ISERR()) + return NULL; + } + return v->subdfas[t->id]; +} + +/* - simpleFind - find a match for the main NFA (no-complications case) ^ static int simpleFind(struct vars *, struct cnfa *, struct colormap *); */ @@ -357,7 +370,10 @@ simpleFind( } else { end = longest(v, d, begin, v->stop, &hitend); } - NOERR(); + if (ISERR()) { + freeDFA(d); + return v->err; + } if (hitend && cold == NULL) { cold = begin; } @@ -388,11 +404,11 @@ simpleFind( } /* - * Submatches. + * Find submatches. */ - zapSubexpressions(v->pmatch, v->nmatch); - return dissect(v, v->g->tree, begin, end); + zapallsubs(v->pmatch, v->nmatch); + return cdissect(v, v->g->tree, begin, end); } /* @@ -488,9 +504,8 @@ complicatedFindLoop( } MDEBUG(("tentative end %ld\n", LOFF(end))); - zapSubexpressions(v->pmatch, v->nmatch); - zapSubtree(v, v->g->tree); - er = complicatedDissect(v, v->g->tree, begin, end); + zapallsubs(v->pmatch, v->nmatch); + er = cdissect(v, v->g->tree, begin, end); if (er == REG_OKAY) { if (v->nmatch > 0) { v->pmatch[0].rm_so = OFF(begin); @@ -501,6 +516,7 @@ complicatedFindLoop( } if (er != REG_NOMATCH) { ERR(er); + *coldp = cold; return er; } if ((shorter) ? end == estop : end == begin) { @@ -525,11 +541,11 @@ complicatedFindLoop( } /* - - zapSubexpressions - initialize the subexpression matches to "no match" - ^ static void zapSubexpressions(regmatch_t *, size_t); + - zapallsubs - initialize all subexpression matches to "no match" + ^ static void zapallsubs(regmatch_t *, size_t); */ static void -zapSubexpressions( +zapallsubs( regmatch_t *const p, const size_t n) { @@ -542,36 +558,33 @@ zapSubexpressions( } /* - - zapSubtree - initialize the retry memory of a subtree to zeros - ^ static void zapSubtree(struct vars *, struct subre *); + - zaptreesubs - initialize subexpressions within subtree to "no match" + ^ static void zaptreesubs(struct vars *, struct subre *); */ static void -zapSubtree( +zaptreesubs( struct vars *const v, struct subre *const t) { - if (t == NULL) { - return; - } - - assert(v->mem != NULL); - v->mem[t->retry] = 0; if (t->op == '(') { - assert(t->subno > 0); - v->pmatch[t->subno].rm_so = -1; - v->pmatch[t->subno].rm_eo = -1; + int n = t->subno; + assert(n > 0); + if ((size_t) n < v->nmatch) { + v->pmatch[n].rm_so = -1; + v->pmatch[n].rm_eo = -1; + } } if (t->left != NULL) { - zapSubtree(v, t->left); + zaptreesubs(v, t->left); } if (t->right != NULL) { - zapSubtree(v, t->right); + zaptreesubs(v, t->right); } } /* - - subset - set any subexpression relevant to a successful subre + - subset - set subexpression match data for a successful subre ^ static void subset(struct vars *, struct subre *, chr *, chr *); */ static void @@ -594,247 +607,91 @@ subset( } /* - - dissect - determine subexpression matches (uncomplicated case) - ^ static int dissect(struct vars *, struct subre *, chr *, chr *); + - cdissect - check backrefs and determine subexpression matches + * cdissect recursively processes a subre tree to check matching of backrefs + * and/or identify submatch boundaries for capture nodes. The proposed match + * runs from "begin" to "end" (not including "end"), and we are basically + * "dissecting" it to see where the submatches are. + * Before calling any level of cdissect, the caller must have run the node's + * DFA and found that the proposed substring satisfies the DFA. (We make + * the caller do that because in concatenation and iteration nodes, it's + * much faster to check all the substrings against the child DFAs before we + * recurse.) Also, caller must have cleared subexpression match data via + * zaptreesubs (or zapallsubs at the top level). + ^ static int cdissect(struct vars *, struct subre *, chr *, chr *); */ static int /* regexec return code */ -dissect( - struct vars *const v, +cdissect( + struct vars *v, struct subre *t, - chr *const begin, /* beginning of relevant substring */ - chr *const end) /* end of same */ + chr *begin, /* beginning of relevant substring */ + chr *end) /* end of same */ { -#ifndef COMPILER_DOES_TAILCALL_OPTIMIZATION - restart: -#endif - assert(t != NULL); - MDEBUG(("dissect %ld-%ld\n", LOFF(begin), LOFF(end))); - - switch (t->op) { - case '=': /* terminal node */ - assert(t->left == NULL && t->right == NULL); - return REG_OKAY; /* no action, parent did the work */ - case '|': /* alternation */ - assert(t->left != NULL); - return alternationDissect(v, t, begin, end); - case 'b': /* back ref -- shouldn't be calling us! */ - return REG_ASSERT; - case '.': /* concatenation */ - assert(t->left != NULL && t->right != NULL); - return concatenationDissect(v, t, begin, end); - case '(': /* capturing */ - assert(t->left != NULL && t->right == NULL); - assert(t->subno > 0); - subset(v, t, begin, end); -#ifndef COMPILER_DOES_TAILCALL_OPTIMIZATION - t = t->left; - goto restart; -#else - return dissect(v, t->left, begin, end); -#endif - default: - return REG_ASSERT; - } -} - -/* - - concatenationDissect - determine concatenation subexpression matches - - (uncomplicated) - ^ static int concatenationDissect(struct vars *, struct subre *, chr *, chr *); - */ -static int /* regexec return code */ -concatenationDissect( - struct vars *const v, - struct subre *const t, - chr *const begin, /* beginning of relevant substring */ - chr *const end) /* end of same */ -{ - struct dfa *d, *d2; - chr *mid; - int i; - int shorter = (t->left->flags&SHORTER) ? 1 : 0; - chr *stop = (shorter) ? end : begin; - - assert(t->op == '.'); - assert(t->left != NULL && t->left->cnfa.nstates > 0); - assert(t->right != NULL && t->right->cnfa.nstates > 0); - - d = newDFA(v, &t->left->cnfa, &v->g->cmap, &v->dfa1); - NOERR(); - d2 = newDFA(v, &t->right->cnfa, &v->g->cmap, &v->dfa2); - if (ISERR()) { - assert(d2 == NULL); - freeDFA(d); - return v->err; - } - - /* - * Pick a tentative midpoint. - */ - - if (shorter) { - mid = shortest(v, d, begin, begin, end, NULL, NULL); - } else { - mid = longest(v, d, begin, end, NULL); - } - if (mid == NULL) { - freeDFA(d); - freeDFA(d2); - return REG_ASSERT; - } - MDEBUG(("tentative midpoint %ld\n", LOFF(mid))); - - /* - * Iterate until satisfaction or failure. - */ - - while (longest(v, d2, mid, end, NULL) != end) { - /* - * That midpoint didn't work, find a new one. - */ - - if (mid == stop) { - /* - * All possibilities exhausted! - */ - - MDEBUG(("no midpoint!\n")); - freeDFA(d); - freeDFA(d2); - return REG_ASSERT; - } - if (shorter) { - mid = shortest(v, d, begin, mid+1, end, NULL, NULL); - } else { - mid = longest(v, d, begin, mid-1, NULL); - } - if (mid == NULL) { - /* - * Failed to find a new one! - */ - - MDEBUG(("failed midpoint!\n")); - freeDFA(d); - freeDFA(d2); - return REG_ASSERT; - } - MDEBUG(("new midpoint %ld\n", LOFF(mid))); - } - - /* - * Satisfaction. - */ - - MDEBUG(("successful\n")); - freeDFA(d); - freeDFA(d2); - i = dissect(v, t->left, begin, mid); - if (i != REG_OKAY) { - return i; - } - return dissect(v, t->right, mid, end); -} - -/* - - alternationDissect - determine alternative subexpression matches (uncomplicated) - ^ static int alternationDissect(struct vars *, struct subre *, chr *, chr *); - */ -static int /* regexec return code */ -alternationDissect( - struct vars *const v, - struct subre *t, - chr *const begin, /* beginning of relevant substring */ - chr *const end) /* end of same */ -{ - int i; - - assert(t != NULL); - assert(t->op == '|'); - - for (i = 0; t != NULL; t = t->right, i++) { - struct dfa *d; + int er; - MDEBUG(("trying %dth\n", i)); - assert(t->left != NULL && t->left->cnfa.nstates > 0); - d = newDFA(v, &t->left->cnfa, &v->g->cmap, &v->dfa1); - if (ISERR()) { - return v->err; - } - if (longest(v, d, begin, end, NULL) == end) { - MDEBUG(("success\n")); - freeDFA(d); - return dissect(v, t->left, begin, end); - } - freeDFA(d); - } - return REG_ASSERT; /* none of them matched?!? */ -} - -/* - - complicatedDissect - determine subexpression matches (with complications) - * The retry memory stores the offset of the trial midpoint from begin, plus 1 - * so that 0 uniquely means "clean slate". - ^ static int complicatedDissect(struct vars *, struct subre *, chr *, chr *); - */ -static inline int /* regexec return code */ -complicatedDissect( - struct vars *const v, - struct subre *const t, - chr *const begin, /* beginning of relevant substring */ - chr *const end) /* end of same */ -{ assert(t != NULL); - MDEBUG(("complicatedDissect %ld-%ld %c\n", LOFF(begin), LOFF(end), t->op)); + MDEBUG(("cdissect %ld-%ld %c\n", LOFF(begin), LOFF(end), t->op)); switch (t->op) { case '=': /* terminal node */ assert(t->left == NULL && t->right == NULL); - return REG_OKAY; /* no action, parent did the work */ - case '|': /* alternation */ - assert(t->left != NULL); - return complicatedAlternationDissect(v, t, begin, end); - case 'b': /* back ref -- shouldn't be calling us! */ + er = REG_OKAY; /* no action, parent did the work */ + break; + case 'b': /* back reference */ assert(t->left == NULL && t->right == NULL); - return complicatedBackrefDissect(v, t, begin, end); + er = cbrdissect(v, t, begin, end); + break; case '.': /* concatenation */ assert(t->left != NULL && t->right != NULL); - return complicatedConcatenationDissect(v, t, begin, end); + if (t->left->flags & SHORTER) /* reverse scan */ + er = crevcondissect(v, t, begin, end); + else + er = ccondissect(v, t, begin, end); + break; + case '|': /* alternation */ + assert(t->left != NULL); + er = caltdissect(v, t, begin, end); + break; + case '*': /* iteration */ + assert(t->left != NULL); + if (t->left->flags & SHORTER) /* reverse scan */ + er = creviterdissect(v, t, begin, end); + else + er = citerdissect(v, t, begin, end); + break; case '(': /* capturing */ assert(t->left != NULL && t->right == NULL); assert(t->subno > 0); - return complicatedCapturingDissect(v, t, begin, end); + er = cdissect(v, t->left, begin, end); + if (er == REG_OKAY) { + subset(v, t, begin, end); + } + break; default: - return REG_ASSERT; + er = REG_ASSERT; + break; } -} -static int /* regexec return code */ -complicatedCapturingDissect( - struct vars *const v, - struct subre *const t, - chr *const begin, /* beginning of relevant substring */ - chr *const end) /* end of same */ -{ - int er = complicatedDissect(v, t->left, begin, end); + /* + * We should never have a match failure unless backrefs lurk below; + * otherwise, either caller failed to check the DFA, or there's some + * inconsistency between the DFA and the node's innards. + */ + assert(er != REG_NOMATCH || (t->flags & BACKR)); - if (er == REG_OKAY) { - subset(v, t, begin, end); - } return er; } /* - - complicatedConcatenationDissect - concatenation subexpression matches (with complications) - * The retry memory stores the offset of the trial midpoint from begin, plus 1 - * so that 0 uniquely means "clean slate". - ^ static int complicatedConcatenationDissect(struct vars *, struct subre *, chr *, chr *); + - ccondissect - dissect match for concatenation node + ^ static int ccondissect(struct vars *, struct subre *, chr *, chr *); */ static int /* regexec return code */ -complicatedConcatenationDissect( - struct vars *const v, - struct subre *const t, - chr *const begin, /* beginning of relevant substring */ - chr *const end) /* end of same */ +ccondissect( + struct vars *v, + struct subre *t, + chr *begin, /* beginning of relevant substring */ + chr *end) /* end of same */ { struct dfa *d, *d2; chr *mid; @@ -842,39 +699,23 @@ complicatedConcatenationDissect( assert(t->op == '.'); assert(t->left != NULL && t->left->cnfa.nstates > 0); assert(t->right != NULL && t->right->cnfa.nstates > 0); + assert(!(t->left->flags & SHORTER)); - if (t->left->flags&SHORTER) { /* reverse scan */ - return complicatedReversedDissect(v, t, begin, end); - } + d = getsubdfa(v, t->left); + NOERR(); + d2 = getsubdfa(v, t->right); + NOERR(); - d = newDFA(v, &t->left->cnfa, &v->g->cmap, DOMALLOC); - if (ISERR()) { - return v->err; - } - d2 = newDFA(v, &t->right->cnfa, &v->g->cmap, DOMALLOC); - if (ISERR()) { - freeDFA(d); - return v->err; - } - MDEBUG(("cConcat %d\n", t->retry)); + MDEBUG(("cConcat %d\n", t->id)); /* * Pick a tentative midpoint. */ - - if (v->mem[t->retry] == 0) { - mid = longest(v, d, begin, end, NULL); - if (mid == NULL) { - freeDFA(d); - freeDFA(d2); - return REG_NOMATCH; - } - MDEBUG(("tentative midpoint %ld\n", LOFF(mid))); - v->mem[t->retry] = (mid - begin) + 1; - } else { - mid = begin + (v->mem[t->retry] - 1); - MDEBUG(("working midpoint %ld\n", LOFF(mid))); + mid = longest(v, d, begin, end, (int *) NULL); + if (mid == NULL) { + return REG_NOMATCH; } + MDEBUG(("tentative midpoint %ld\n", LOFF(mid))); /* * Iterate until satisfaction or failure. @@ -886,24 +727,20 @@ complicatedConcatenationDissect( */ if (longest(v, d2, mid, end, NULL) == end) { - int er = complicatedDissect(v, t->left, begin, mid); + int er = cdissect(v, t->left, begin, mid); if (er == REG_OKAY) { - er = complicatedDissect(v, t->right, mid, end); + er = cdissect(v, t->right, mid, end); if (er == REG_OKAY) { /* * Satisfaction. */ MDEBUG(("successful\n")); - freeDFA(d); - freeDFA(d2); return REG_OKAY; } } - if ((er != REG_OKAY) && (er != REG_NOMATCH)) { - freeDFA(d); - freeDFA(d2); + if (er != REG_NOMATCH) { return er; } } @@ -917,9 +754,7 @@ complicatedConcatenationDissect( * All possibilities exhausted. */ - MDEBUG(("%d no midpoint\n", t->retry)); - freeDFA(d); - freeDFA(d2); + MDEBUG(("%d no midpoint\n", t->id)); return REG_NOMATCH; } mid = longest(v, d, begin, mid-1, NULL); @@ -928,31 +763,25 @@ complicatedConcatenationDissect( * Failed to find a new one. */ - MDEBUG(("%d failed midpoint\n", t->retry)); - freeDFA(d); - freeDFA(d2); + MDEBUG(("%d failed midpoint\n", t->id)); return REG_NOMATCH; } - MDEBUG(("%d: new midpoint %ld\n", t->retry, LOFF(mid))); - v->mem[t->retry] = (mid - begin) + 1; - zapSubtree(v, t->left); - zapSubtree(v, t->right); + MDEBUG(("%d: new midpoint %ld\n", t->id, LOFF(mid))); + zaptreesubs(v, t->left); + zaptreesubs(v, t->right); } } /* - - complicatedReversedDissect - determine backref shortest-first subexpression - - matches - * The retry memory stores the offset of the trial midpoint from begin, plus 1 - * so that 0 uniquely means "clean slate". - ^ static int complicatedReversedDissect(struct vars *, struct subre *, chr *, chr *); + - crevcondissect - dissect match for concatenation node, shortest-first + ^ static int crevcondissect(struct vars *, struct subre *, chr *, chr *); */ static int /* regexec return code */ -complicatedReversedDissect( - struct vars *const v, - struct subre *const t, - chr *const begin, /* beginning of relevant substring */ - chr *const end) /* end of same */ +crevcondissect( + struct vars *v, + struct subre *t, + chr *begin, /* beginning of relevant substring */ + chr *end) /* end of same */ { struct dfa *d, *d2; chr *mid; @@ -962,38 +791,22 @@ complicatedReversedDissect( assert(t->right != NULL && t->right->cnfa.nstates > 0); assert(t->left->flags&SHORTER); - /* - * Concatenation -- need to split the substring between parts. - */ + d = getsubdfa(v, t->left); + NOERR(); + d2 = getsubdfa(v, t->right); + NOERR(); - d = newDFA(v, &t->left->cnfa, &v->g->cmap, DOMALLOC); - if (ISERR()) { - return v->err; - } - d2 = newDFA(v, &t->right->cnfa, &v->g->cmap, DOMALLOC); - if (ISERR()) { - freeDFA(d); - return v->err; - } - MDEBUG(("cRev %d\n", t->retry)); + MDEBUG(("crevcon %d\n", t->id)); /* * Pick a tentative midpoint. */ - if (v->mem[t->retry] == 0) { - mid = shortest(v, d, begin, begin, end, NULL, NULL); - if (mid == NULL) { - freeDFA(d); - freeDFA(d2); - return REG_NOMATCH; - } - MDEBUG(("tentative midpoint %ld\n", LOFF(mid))); - v->mem[t->retry] = (mid - begin) + 1; - } else { - mid = begin + (v->mem[t->retry] - 1); - MDEBUG(("working midpoint %ld\n", LOFF(mid))); + mid = shortest(v, d, begin, begin, end, (chr **) NULL, (int *) NULL); + if (mid == NULL) { + return REG_NOMATCH; } + MDEBUG(("tentative midpoint %ld\n", LOFF(mid))); /* * Iterate until satisfaction or failure. @@ -1005,24 +818,20 @@ complicatedReversedDissect( */ if (longest(v, d2, mid, end, NULL) == end) { - int er = complicatedDissect(v, t->left, begin, mid); + int er = cdissect(v, t->left, begin, mid); if (er == REG_OKAY) { - er = complicatedDissect(v, t->right, mid, end); + er = cdissect(v, t->right, mid, end); if (er == REG_OKAY) { /* * Satisfaction. */ MDEBUG(("successful\n")); - freeDFA(d); - freeDFA(d2); return REG_OKAY; } } - if (er != REG_OKAY && er != REG_NOMATCH) { - freeDFA(d); - freeDFA(d2); + if (er != REG_NOMATCH) { return er; } } @@ -1036,9 +845,7 @@ complicatedReversedDissect( * All possibilities exhausted. */ - MDEBUG(("%d no midpoint\n", t->retry)); - freeDFA(d); - freeDFA(d2); + MDEBUG(("%d no midpoint\n", t->id)); return REG_NOMATCH; } mid = shortest(v, d, begin, mid+1, end, NULL, NULL); @@ -1047,164 +854,474 @@ complicatedReversedDissect( * Failed to find a new one. */ - MDEBUG(("%d failed midpoint\n", t->retry)); - freeDFA(d); - freeDFA(d2); + MDEBUG(("%d failed midpoint\n", t->id)); return REG_NOMATCH; } - MDEBUG(("%d: new midpoint %ld\n", t->retry, LOFF(mid))); - v->mem[t->retry] = (mid - begin) + 1; - zapSubtree(v, t->left); - zapSubtree(v, t->right); + MDEBUG(("%d: new midpoint %ld\n", t->id, LOFF(mid))); + zaptreesubs(v, t->left); + zaptreesubs(v, t->right); } } /* - - complicatedBackrefDissect - determine backref subexpression matches - ^ static int complicatedBackrefDissect(struct vars *, struct subre *, chr *, chr *); + - cbrdissect - dissect match for backref node + ^ static int cbrdissect(struct vars *, struct subre *, chr *, chr *); */ static int /* regexec return code */ -complicatedBackrefDissect( - struct vars *const v, - struct subre *const t, - chr *const begin, /* beginning of relevant substring */ - chr *const end) /* end of same */ +cbrdissect( + struct vars *v, + struct subre *t, + chr *begin, /* beginning of relevant substring */ + chr *end) /* end of same */ { - int i, n = t->subno, min = t->min, max = t->max; - chr *paren, *p, *stop; - size_t len; + int n = t->subno, min = t->min, max = t->max; + size_t numreps; + size_t tlen; + size_t brlen; + chr *brstring; + chr *p; assert(t != NULL); assert(t->op == 'b'); assert(n >= 0); assert((size_t)n < v->nmatch); - MDEBUG(("cbackref n%d %d{%d-%d}\n", t->retry, n, min, max)); + MDEBUG(("cbackref n%d %d{%d-%d}\n", t->id, n, min, max)); + /* get the backreferenced string */ if (v->pmatch[n].rm_so == -1) { return REG_NOMATCH; } - paren = v->start + v->pmatch[n].rm_so; - len = v->pmatch[n].rm_eo - v->pmatch[n].rm_so; + brstring = v->start + v->pmatch[n].rm_so; + brlen = v->pmatch[n].rm_eo - v->pmatch[n].rm_so; - /* - * No room to maneuver -- retries are pointless. - */ - - if (v->mem[t->retry]) { + /* special cases for zero-length strings */ + if (brlen == 0) { + /* + * matches only if target is zero length, but any number of + * repetitions can be considered to be present + */ + if (begin == end && min <= max) { + MDEBUG(("cbackref matched trivially\n")); + return REG_OKAY; + } return REG_NOMATCH; } - v->mem[t->retry] = 1; - - /* - * Special-case zero-length string. - */ - - if (len == 0) { - if (begin == end) { + if (begin == end) { + /* matches only if zero repetitions are okay */ + if (min == 0) { + MDEBUG(("cbackref matched trivially\n")); return REG_OKAY; } return REG_NOMATCH; } /* - * And too-short string. + * check target length to see if it could possibly be an allowed number of + * repetitions of brstring */ - assert(end >= begin); - if ((size_t)(end - begin) < len) { + assert(end > begin); + tlen = end - begin; + if (tlen % brlen != 0) + return REG_NOMATCH; + numreps = tlen / brlen; + if (numreps < (size_t)min || (numreps > (size_t)max && max != DUPINF)) return REG_NOMATCH; + + /* okay, compare the actual string contents */ + p = begin; + while (numreps-- > 0) { + if ((*v->g->compare) (brstring, p, brlen) != 0) + return REG_NOMATCH; + p += brlen; } - stop = end - len; - /* - * Count occurrences. - */ + MDEBUG(("cbackref matched\n")); + return REG_OKAY; +} + +/* + - caltdissect - dissect match for alternation node + ^ static int caltdissect(struct vars *, struct subre *, chr *, chr *); + */ +static int /* regexec return code */ +caltdissect( + struct vars *v, + struct subre *t, + chr *begin, /* beginning of relevant substring */ + chr *end) /* end of same */ +{ + struct dfa *d; + int er; + + /* We loop, rather than tail-recurse, to handle a chain of alternatives */ + while (t != NULL) { + assert(t->op == '|'); + assert(t->left != NULL && t->left->cnfa.nstates > 0); - i = 0; - for (p = begin; p <= stop && (i < max || max == INFINITY); p += len) { - if (v->g->compare(paren, p, len) != 0) { - break; + MDEBUG(("calt n%d\n", t->id)); + + d = getsubdfa(v, t->left); + NOERR(); + if (longest(v, d, begin, end, (int *) NULL) == end) { + MDEBUG(("calt matched\n")); + er = cdissect(v, t->left, begin, end); + if (er != REG_NOMATCH) { + return er; + } } - i++; + + t = t->right; } - MDEBUG(("cbackref found %d\n", i)); + + return REG_NOMATCH; +} + +/* + - citerdissect - dissect match for iteration node + ^ static int citerdissect(struct vars *, struct subre *, chr *, chr *); + */ +static int /* regexec return code */ +citerdissect(struct vars * v, + struct subre * t, + chr *begin, /* beginning of relevant substring */ + chr *end) /* end of same */ +{ + struct dfa *d; + chr **endpts; + chr *limit; + int min_matches; + size_t max_matches; + int nverified; + int k; + int i; + int er; + + assert(t->op == '*'); + assert(t->left != NULL && t->left->cnfa.nstates > 0); + assert(!(t->left->flags & SHORTER)); + assert(begin <= end); /* - * And sort it out. + * If zero matches are allowed, and target string is empty, just declare + * victory. OTOH, if target string isn't empty, zero matches can't work + * so we pretend the min is 1. */ + min_matches = t->min; + if (min_matches <= 0) { + if (begin == end) + return REG_OKAY; + min_matches = 1; + } - if (p != end) { /* didn't consume all of it */ - return REG_NOMATCH; + /* + * We need workspace to track the endpoints of each sub-match. Normally + * we consider only nonzero-length sub-matches, so there can be at most + * end-begin of them. However, if min is larger than that, we will also + * consider zero-length sub-matches in order to find enough matches. + * + * For convenience, endpts[0] contains the "begin" pointer and we store + * sub-match endpoints in endpts[1..max_matches]. + */ + max_matches = end - begin; + if (max_matches > (size_t)t->max && t->max != DUPINF) + max_matches = t->max; + if (max_matches < (size_t)min_matches) + max_matches = min_matches; + endpts = (chr **) MALLOC((max_matches + 1) * sizeof(chr *)); + if (endpts == NULL) + return REG_ESPACE; + endpts[0] = begin; + + d = getsubdfa(v, t->left); + if (ISERR()) { + FREE(endpts); + return v->err; } - if (min <= i && (i <= max || max == INFINITY)) { - return REG_OKAY; + MDEBUG(("citer %d\n", t->id)); + + /* + * Our strategy is to first find a set of sub-match endpoints that are + * valid according to the child node's DFA, and then recursively dissect + * each sub-match to confirm validity. If any validity check fails, + * backtrack the last sub-match and try again. And, when we next try for + * a validity check, we need not recheck any successfully verified + * sub-matches that we didn't move the endpoints of. nverified remembers + * how many sub-matches are currently known okay. + */ + + /* initialize to consider first sub-match */ + nverified = 0; + k = 1; + limit = end; + + /* iterate until satisfaction or failure */ + while (k > 0) { + /* try to find an endpoint for the k'th sub-match */ + endpts[k] = longest(v, d, endpts[k - 1], limit, (int *) NULL); + if (endpts[k] == NULL) { + /* no match possible, so see if we can shorten previous one */ + k--; + goto backtrack; + } + MDEBUG(("%d: working endpoint %d: %ld\n", + t->id, k, LOFF(endpts[k]))); + + /* k'th sub-match can no longer be considered verified */ + if (nverified >= k) + nverified = k - 1; + + if (endpts[k] != end) { + /* haven't reached end yet, try another iteration if allowed */ + if ((size_t)k >= max_matches) { + /* must try to shorten some previous match */ + k--; + goto backtrack; + } + + /* reject zero-length match unless necessary to achieve min */ + if (endpts[k] == endpts[k - 1] && + (k >= min_matches || min_matches - k < end - endpts[k])) + goto backtrack; + + k++; + limit = end; + continue; + } + + /* + * We've identified a way to divide the string into k sub-matches + * that works so far as the child DFA can tell. If k is an allowed + * number of matches, start the slow part: recurse to verify each + * sub-match. We always have k <= max_matches, needn't check that. + */ + if (k < min_matches) + goto backtrack; + + MDEBUG(("%d: verifying %d..%d\n", t->id, nverified + 1, k)); + + for (i = nverified + 1; i <= k; i++) { + zaptreesubs(v, t->left); + er = cdissect(v, t->left, endpts[i - 1], endpts[i]); + if (er == REG_OKAY) { + nverified = i; + continue; + } + if (er == REG_NOMATCH) + break; + /* oops, something failed */ + FREE(endpts); + return er; + } + + if (i > k) { + /* satisfaction */ + MDEBUG(("%d successful\n", t->id)); + FREE(endpts); + return REG_OKAY; + } + + /* match failed to verify, so backtrack */ + + backtrack: + /* + * Must consider shorter versions of the current sub-match. However, + * we'll only ask for a zero-length match if necessary. + */ + while (k > 0) { + chr *prev_end = endpts[k - 1]; + + if (endpts[k] > prev_end) { + limit = endpts[k] - 1; + if (limit > prev_end || + (k < min_matches && min_matches - k >= end - prev_end)) { + /* break out of backtrack loop, continue the outer one */ + break; + } + } + /* can't shorten k'th sub-match any more, consider previous one */ + k--; + } } - return REG_NOMATCH; /* out of range */ + + /* all possibilities exhausted */ + MDEBUG(("%d failed\n", t->id)); + FREE(endpts); + return REG_NOMATCH; } /* - - complicatedAlternationDissect - determine alternative subexpression matches (w. - - complications) - ^ static int complicatedAlternationDissect(struct vars *, struct subre *, chr *, chr *); + - creviterdissect - dissect match for iteration node, shortest-first + ^ static int creviterdissect(struct vars *, struct subre *, chr *, chr *); */ static int /* regexec return code */ -complicatedAlternationDissect( - struct vars *const v, - struct subre *t, - chr *const begin, /* beginning of relevant substring */ - chr *const end) /* end of same */ +creviterdissect(struct vars * v, + struct subre * t, + chr *begin, /* beginning of relevant substring */ + chr *end) /* end of same */ { - int er; -#define UNTRIED 0 /* not yet tried at all */ -#define TRYING 1 /* top matched, trying submatches */ -#define TRIED 2 /* top didn't match or submatches exhausted */ + struct dfa *d; + chr **endpts; + chr *limit; + int min_matches; + size_t max_matches; + int nverified; + int k; + int i; + int er; + + assert(t->op == '*'); + assert(t->left != NULL && t->left->cnfa.nstates > 0); + assert(t->left->flags & SHORTER); + assert(begin <= end); -#ifndef COMPILER_DOES_TAILCALL_OPTIMIZATION - if (0) { - doRight: - t = t->right; - } -#endif - if (t == NULL) { - return REG_NOMATCH; + /* + * If zero matches are allowed, and target string is empty, just declare + * victory. OTOH, if target string isn't empty, zero matches can't work + * so we pretend the min is 1. + */ + min_matches = t->min; + if (min_matches <= 0) { + if (begin == end) + return REG_OKAY; + min_matches = 1; } - assert(t->op == '|'); - if (v->mem[t->retry] == TRIED) { - goto doRight; + + /* + * We need workspace to track the endpoints of each sub-match. Normally + * we consider only nonzero-length sub-matches, so there can be at most + * end-begin of them. However, if min is larger than that, we will also + * consider zero-length sub-matches in order to find enough matches. + * + * For convenience, endpts[0] contains the "begin" pointer and we store + * sub-match endpoints in endpts[1..max_matches]. + */ + max_matches = end - begin; + if (max_matches > (size_t)t->max && t->max != DUPINF) + max_matches = t->max; + if (max_matches < (size_t)min_matches) + max_matches = min_matches; + endpts = (chr **) MALLOC((max_matches + 1) * sizeof(chr *)); + if (endpts == NULL) + return REG_ESPACE; + endpts[0] = begin; + + d = getsubdfa(v, t->left); + if (ISERR()) { + FREE(endpts); + return v->err; } + MDEBUG(("creviter %d\n", t->id)); - MDEBUG(("cAlt n%d\n", t->retry)); - assert(t->left != NULL); + /* + * Our strategy is to first find a set of sub-match endpoints that are + * valid according to the child node's DFA, and then recursively dissect + * each sub-match to confirm validity. If any validity check fails, + * backtrack the last sub-match and try again. And, when we next try for + * a validity check, we need not recheck any successfully verified + * sub-matches that we didn't move the endpoints of. nverified remembers + * how many sub-matches are currently known okay. + */ - if (v->mem[t->retry] == UNTRIED) { - struct dfa *d = newDFA(v, &t->left->cnfa, &v->g->cmap, DOMALLOC); + /* initialize to consider first sub-match */ + nverified = 0; + k = 1; + limit = begin; + + /* iterate until satisfaction or failure */ + while (k > 0) { + /* disallow zero-length match unless necessary to achieve min */ + if (limit == endpts[k - 1] && + limit != end && + (k >= min_matches || min_matches - k < end - limit)) + limit++; + + /* if this is the last allowed sub-match, it must reach to the end */ + if ((size_t)k >= max_matches) + limit = end; + + /* try to find an endpoint for the k'th sub-match */ + endpts[k] = shortest(v, d, endpts[k - 1], limit, end, + (chr **) NULL, (int *) NULL); + if (endpts[k] == NULL) { + /* no match possible, so see if we can lengthen previous one */ + k--; + goto backtrack; + } + MDEBUG(("%d: working endpoint %d: %ld\n", + t->id, k, LOFF(endpts[k]))); + + /* k'th sub-match can no longer be considered verified */ + if (nverified >= k) + nverified = k - 1; + + if (endpts[k] != end) { + /* haven't reached end yet, try another iteration if allowed */ + if ((size_t)k >= max_matches) { + /* must try to lengthen some previous match */ + k--; + goto backtrack; + } - if (ISERR()) { - return v->err; + k++; + limit = endpts[k - 1]; + continue; } - if (longest(v, d, begin, end, NULL) != end) { - freeDFA(d); - v->mem[t->retry] = TRIED; - goto doRight; + + /* + * We've identified a way to divide the string into k sub-matches + * that works so far as the child DFA can tell. If k is an allowed + * number of matches, start the slow part: recurse to verify each + * sub-match. We always have k <= max_matches, needn't check that. + */ + if (k < min_matches) + goto backtrack; + + MDEBUG(("%d: verifying %d..%d\n", t->id, nverified + 1, k)); + + for (i = nverified + 1; i <= k; i++) { + zaptreesubs(v, t->left); + er = cdissect(v, t->left, endpts[i - 1], endpts[i]); + if (er == REG_OKAY) { + nverified = i; + continue; + } + if (er == REG_NOMATCH) + break; + /* oops, something failed */ + FREE(endpts); + return er; } - freeDFA(d); - MDEBUG(("cAlt matched\n")); - v->mem[t->retry] = TRYING; - } - er = complicatedDissect(v, t->left, begin, end); - if (er != REG_NOMATCH) { - return er; + if (i > k) { + /* satisfaction */ + MDEBUG(("%d successful\n", t->id)); + FREE(endpts); + return REG_OKAY; + } + + /* match failed to verify, so backtrack */ + + backtrack: + /* + * Must consider longer versions of the current sub-match. + */ + while (k > 0) { + if (endpts[k] < end) { + limit = endpts[k] + 1; + /* break out of backtrack loop, continue the outer one */ + break; + } + /* can't lengthen k'th sub-match any more, consider previous one */ + k--; + } } - v->mem[t->retry] = TRIED; -#ifndef COMPILER_DOES_TAILCALL_OPTIMIZATION - goto doRight; -#else - doRight: - return complicatedAlternationDissect(v, t->right, begin, end); -#endif + /* all possibilities exhausted */ + MDEBUG(("%d failed\n", t->id)); + FREE(endpts); + return REG_NOMATCH; } #include "rege_dfa.c" diff --git a/generic/regguts.h b/generic/regguts.h index b478e4c..b3dbaa4 100644 --- a/generic/regguts.h +++ b/generic/regguts.h @@ -49,41 +49,15 @@ #include <assert.h> #endif -/* voids */ -#ifndef VOID -#define VOID void /* for function return values */ -#endif -#ifndef DISCARD -#define DISCARD void /* for throwing values away */ -#endif -#ifndef PVOID -#define PVOID void * /* generic pointer */ -#endif -#ifndef VS -#define VS(x) ((void*)(x)) /* cast something to generic ptr */ -#endif -#ifndef NOPARMS -#define NOPARMS void /* for empty parm lists */ -#endif - -/* function-pointer declarator */ -#ifndef FUNCPTR -#if __STDC__ >= 1 -#define FUNCPTR(name, args) (*name)args -#else -#define FUNCPTR(name, args) (*name)() -#endif -#endif - /* memory allocation */ #ifndef MALLOC #define MALLOC(n) malloc(n) #endif #ifndef REALLOC -#define REALLOC(p, n) realloc(VS(p), n) +#define REALLOC(p, n) realloc(p, n) #endif #ifndef FREE -#define FREE(p) free(VS(p)) +#define FREE(p) free(p) #endif /* want size of a char in bits, and max value in bounded quantifiers */ @@ -96,10 +70,9 @@ */ #define NOTREACHED 0 -#define xxx 1 #define DUPMAX _POSIX2_RE_DUP_MAX -#define INFINITY (DUPMAX+1) +#define DUPINF (DUPMAX+1) #define REMAGIC 0xfed7 /* magic number for main struct */ @@ -186,7 +159,14 @@ struct colordesc { union tree *block; /* block of solid color, if any */ }; -/* the color map itself */ +/* + * The color map itself + * + * Much of the data in the colormap struct is only used at compile time. + * However, the bulk of the space usage is in the "tree" structure, so it's + * not clear that there's much point in converting the rest to a more compact + * form when compilation is finished. + */ struct colormap { int magic; #define CMMAGIC 0x876 @@ -242,14 +222,15 @@ struct cvec { struct state; struct arc { - int type; -#define ARCFREE '\0' + int type; /* 0 if free, else an NFA arc type code */ color co; struct state *from; /* where it's from (and contained within) */ struct state *to; /* where it's to */ - struct arc *outchain; /* *from's outs chain or free chain */ -#define freechain outchain + struct arc *outchain; /* link in *from's outs chain or free chain */ + struct arc *outchainRev; /* back-link in *from's outs chain */ +#define freechain outchain /* we do not maintain "freechainRev" */ struct arc *inchain; /* *to's ins chain */ + struct arc *inchainRev; /* back-link in *to's ins chain */ struct arc *colorchain; /* color's arc chain */ struct arc *colorchainRev; /* back-link in color's arc chain */ }; @@ -288,20 +269,28 @@ struct nfa { struct colormap *cm; /* the color map */ color bos[2]; /* colors, if any, assigned to BOS and BOL */ color eos[2]; /* colors, if any, assigned to EOS and EOL */ - size_t size; /* Current NFA size; differs from nstates as - * it also counts the number of states created - * by children of this state. */ struct vars *v; /* simplifies compile error reporting */ struct nfa *parent; /* parent NFA, if any */ }; /* * definitions for compacted NFA + * + * The main space savings in a compacted NFA is from making the arcs as small + * as possible. We store only the transition color and next-state number for + * each arc. The list of out arcs for each state is an array beginning at + * cnfa.states[statenumber], and terminated by a dummy carc struct with + * co == COLORLESS. + * + * The non-dummy carc structs are of two types: plain arcs and LACON arcs. + * Plain arcs just store the transition color number as "co". LACON arcs + * store the lookahead constraint number plus cnfa.ncolors as "co". LACON + * arcs can be distinguished from plain by testing for co >= cnfa.ncolors. */ struct carc { color co; /* COLORLESS is list terminator */ - int to; /* state number */ + int to; /* next-state number */ }; struct cnfa { @@ -313,27 +302,52 @@ struct cnfa { int post; /* teardown state number */ color bos[2]; /* colors, if any, assigned to BOS and BOL */ color eos[2]; /* colors, if any, assigned to EOS and EOL */ + char *stflags; /* vector of per-state flags bytes */ +#define CNFA_NOPROGRESS 01 /* flag bit for a no-progress state */ struct carc **states; /* vector of pointers to outarc lists */ + /* states[n] are pointers into a single malloc'd array of arcs */ struct carc *arcs; /* the area for the lists */ }; #define ZAPCNFA(cnfa) ((cnfa).nstates = 0) #define NULLCNFA(cnfa) ((cnfa).nstates == 0) /* - * Used to limit the maximum NFA size to something sane. [Bug 1810264] + * This symbol limits the transient heap space used by the regex compiler, + * and thereby also the maximum complexity of NFAs that we'll deal with. + * Currently we only count NFA states and arcs against this; the other + * transient data is generally not large enough to notice compared to those. + * Note that we do not charge anything for the final output data structures + * (the compacted NFA and the colormap). */ - -#ifndef REG_MAX_STATES -# define REG_MAX_STATES 100000 +#ifndef REG_MAX_COMPILE_SPACE +#define REG_MAX_COMPILE_SPACE \ + (100000 * sizeof(struct state) + 100000 * sizeof(struct arcbatch)) #endif /* * subexpression tree + * + * "op" is one of: + * '=' plain regex without interesting substructure (implemented as DFA) + * 'b' back-reference (has no substructure either) + * '(' capture node: captures the match of its single child + * '.' concatenation: matches a match for left, then a match for right + * '|' alternation: matches a match for left or a match for right + * '*' iteration: matches some number of matches of its single child + * + * Note: the right child of an alternation must be another alternation or + * NULL; hence, an N-way branch requires N alternation nodes, not N-1 as you + * might expect. This could stand to be changed. Actually I'd rather see + * a single alternation node with N children, but that will take revising + * the representation of struct subre. + * + * Note: when a backref is directly quantified, we stick the min/max counts + * into the backref rather than plastering an iteration node on top. This is + * for efficiency: there is no need to search for possible division points. */ struct subre { - char op; /* '|', '.' (concat), 'b' (backref), '(', - * '=' */ + char op; /* see type codes above */ char flags; #define LONGER 01 /* prefers longer match */ #define SHORTER 02 /* prefers shorter match */ @@ -349,10 +363,10 @@ struct subre { #define PREF(f) ((f)&NOPROP) #define PREF2(f1, f2) ((PREF(f1) != 0) ? PREF(f1) : PREF(f2)) #define COMBINE(f1, f2) (UP((f1)|(f2)) | PREF2(f1, f2)) - short retry; /* index into retry memory */ + short id; /* ID of subre (1..ntree-1) */ int subno; /* subexpression number (for 'b' and '(') */ - short min; /* min repetitions, for backref only */ - short max; /* max repetitions, for backref only */ + short min; /* min repetitions for iteration or backref */ + short max; /* max repetitions for iteration or backref */ struct subre *left; /* left child, if any (also freelist chain) */ struct subre *right; /* right child, if any */ struct state *begin; /* outarcs from here... */ @@ -367,7 +381,7 @@ struct subre { */ struct fns { - void FUNCPTR(free, (regex_t *)); + void (*free) (regex_t *); }; /* @@ -382,9 +396,9 @@ struct guts { size_t nsub; /* copy of re_nsub */ struct subre *tree; struct cnfa search; /* for fast preliminary search */ - int ntree; + int ntree; /* number of subre's, plus one */ struct colormap cmap; - int FUNCPTR(compare, (const chr *, const chr *, size_t)); + int (*compare) (const chr *, const chr *, size_t); struct subre *lacons; /* lookahead-constraint vector */ int nlacons; /* size of lacons */ }; diff --git a/generic/tcl.decls b/generic/tcl.decls index 1829249..f5b0945 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2,8 +2,8 @@ # # This file contains the declarations for all supported public # functions that are exported by the Tcl library via the stubs table. -# This file is used to generate the tclDecls.h, tclPlatDecls.h, -# tclStub.c, and tclPlatStub.c files. +# This file is used to generate the tclDecls.h, tclPlatDecls.h +# and tclStubInit.c files. # # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. @@ -32,12 +32,12 @@ declare 0 { const char *version, const void *clientData) } declare 1 { - CONST84_RETURN char *Tcl_PkgRequireEx(Tcl_Interp *interp, + const char *Tcl_PkgRequireEx(Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr) } declare 2 { - void Tcl_Panic(const char *format, ...) + TCL_NORETURN void Tcl_Panic(const char *format, ...) } declare 3 { char *Tcl_Alloc(unsigned int size) @@ -104,7 +104,7 @@ declare 20 { declare 21 { int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file, int line) } -declare 22 { +declare 22 {deprecated {No longer in use, changed to macro}} { Tcl_Obj *Tcl_DbNewBooleanObj(int boolValue, const char *file, int line) } declare 23 { @@ -119,7 +119,7 @@ declare 25 { Tcl_Obj *Tcl_DbNewListObj(int objc, Tcl_Obj *const *objv, const char *file, int line) } -declare 26 { +declare 26 {deprecated {No longer in use, changed to macro}} { Tcl_Obj *Tcl_DbNewLongObj(long longValue, const char *file, int line) } declare 27 { @@ -152,9 +152,9 @@ declare 35 { int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr) } -declare 36 { +declare 36 {deprecated {No longer in use, changed to macro}} { int Tcl_GetIndexFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - CONST84 char *const *tablePtr, const char *msg, int flags, int *indexPtr) + const char *const *tablePtr, const char *msg, int flags, int *indexPtr) } declare 37 { int Tcl_GetInt(Tcl_Interp *interp, const char *src, int *intPtr) @@ -198,7 +198,7 @@ declare 48 { int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *const objv[]) } -declare 49 { +declare 49 {deprecated {No longer in use, changed to macro}} { Tcl_Obj *Tcl_NewBooleanObj(int boolValue) } declare 50 { @@ -207,13 +207,13 @@ declare 50 { declare 51 { Tcl_Obj *Tcl_NewDoubleObj(double doubleValue) } -declare 52 { +declare 52 {deprecated {No longer in use, changed to macro}} { Tcl_Obj *Tcl_NewIntObj(int intValue) } declare 53 { Tcl_Obj *Tcl_NewListObj(int objc, Tcl_Obj *const objv[]) } -declare 54 { +declare 54 {deprecated {No longer in use, changed to macro}} { Tcl_Obj *Tcl_NewLongObj(long longValue) } declare 55 { @@ -222,7 +222,7 @@ declare 55 { declare 56 { Tcl_Obj *Tcl_NewStringObj(const char *bytes, int length) } -declare 57 { +declare 57 {deprecated {No longer in use, changed to macro}} { void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue) } declare 58 { @@ -235,13 +235,13 @@ declare 59 { declare 60 { void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue) } -declare 61 { +declare 61 {deprecated {No longer in use, changed to macro}} { void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue) } declare 62 { void Tcl_SetListObj(Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[]) } -declare 63 { +declare 63 {deprecated {No longer in use, changed to macro}} { void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue) } declare 64 { @@ -250,10 +250,10 @@ declare 64 { declare 65 { void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, int length) } -declare 66 { +declare 66 {deprecated {No longer in use, changed to macro}} { void Tcl_AddErrorInfo(Tcl_Interp *interp, const char *message) } -declare 67 { +declare 67 {deprecated {No longer in use, changed to macro}} { void Tcl_AddObjErrorInfo(Tcl_Interp *interp, const char *message, int length) } @@ -285,7 +285,7 @@ declare 75 { declare 76 { void Tcl_BackgroundError(Tcl_Interp *interp) } -declare 77 { +declare 77 {deprecated {Use Tcl_UtfBackslash}} { char Tcl_Backslash(const char *src, int *readPtr) } declare 78 { @@ -306,7 +306,7 @@ declare 82 { int Tcl_CommandComplete(const char *cmd) } declare 83 { - char *Tcl_Concat(int argc, CONST84 char *const *argv) + char *Tcl_Concat(int argc, const char *const *argv) } declare 84 { int Tcl_ConvertElement(const char *src, char *dst, int flags) @@ -318,7 +318,7 @@ declare 85 { declare 86 { int Tcl_CreateAlias(Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int argc, - CONST84 char *const *argv) + const char *const *argv) } declare 87 { int Tcl_CreateAliasObj(Tcl_Interp *slave, const char *slaveCmd, @@ -352,7 +352,7 @@ declare 93 { declare 94 { Tcl_Interp *Tcl_CreateInterp(void) } -declare 95 { +declare 95 {deprecated {}} { void Tcl_CreateMathFunc(Tcl_Interp *interp, const char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, ClientData clientData) @@ -461,26 +461,25 @@ declare 126 { int Tcl_Eof(Tcl_Channel chan) } declare 127 { - CONST84_RETURN char *Tcl_ErrnoId(void) + const char *Tcl_ErrnoId(void) } declare 128 { - CONST84_RETURN char *Tcl_ErrnoMsg(int err) + const char *Tcl_ErrnoMsg(int err) } declare 129 { int Tcl_Eval(Tcl_Interp *interp, const char *script) } -# This is obsolete, use Tcl_FSEvalFile declare 130 { int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName) } -declare 131 { +declare 131 {deprecated {No longer in use, changed to macro}} { int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) } declare 132 { void Tcl_EventuallyFree(ClientData clientData, Tcl_FreeProc *freeProc) } declare 133 { - void Tcl_Exit(int status) + TCL_NORETURN void Tcl_Exit(int status) } declare 134 { int Tcl_ExposeCommand(Tcl_Interp *interp, const char *hiddenCmdToken, @@ -529,12 +528,12 @@ declare 147 { } declare 148 { int Tcl_GetAlias(Tcl_Interp *interp, const char *slaveCmd, - Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, - int *argcPtr, CONST84 char ***argvPtr) + Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, + int *argcPtr, const char ***argvPtr) } declare 149 { int Tcl_GetAliasObj(Tcl_Interp *interp, const char *slaveCmd, - Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, + Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv) } declare 150 { @@ -559,7 +558,7 @@ declare 155 { int Tcl_GetChannelMode(Tcl_Channel chan) } declare 156 { - CONST84_RETURN char *Tcl_GetChannelName(Tcl_Channel chan) + const char *Tcl_GetChannelName(Tcl_Channel chan) } declare 157 { int Tcl_GetChannelOption(Tcl_Interp *interp, Tcl_Channel chan, @@ -573,14 +572,14 @@ declare 159 { Tcl_CmdInfo *infoPtr) } declare 160 { - CONST84_RETURN char *Tcl_GetCommandName(Tcl_Interp *interp, + const char *Tcl_GetCommandName(Tcl_Interp *interp, Tcl_Command command) } declare 161 { int Tcl_GetErrno(void) } declare 162 { - CONST84_RETURN char *Tcl_GetHostName(void) + const char *Tcl_GetHostName(void) } declare 163 { int Tcl_GetInterpPath(Tcl_Interp *askInterp, Tcl_Interp *slaveInterp) @@ -623,20 +622,20 @@ declare 173 { Tcl_Channel Tcl_GetStdChannel(int type) } declare 174 { - CONST84_RETURN char *Tcl_GetStringResult(Tcl_Interp *interp) + const char *Tcl_GetStringResult(Tcl_Interp *interp) } -declare 175 { - CONST84_RETURN char *Tcl_GetVar(Tcl_Interp *interp, const char *varName, +declare 175 {deprecated {No longer in use, changed to macro}} { + const char *Tcl_GetVar(Tcl_Interp *interp, const char *varName, int flags) } declare 176 { - CONST84_RETURN char *Tcl_GetVar2(Tcl_Interp *interp, const char *part1, + const char *Tcl_GetVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags) } declare 177 { int Tcl_GlobalEval(Tcl_Interp *interp, const char *command) } -declare 178 { +declare 178 {deprecated {No longer in use, changed to macro}} { int Tcl_GlobalEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) } declare 179 { @@ -663,7 +662,7 @@ declare 185 { } # Obsolete, use Tcl_FSJoinPath declare 186 { - char *Tcl_JoinPath(int argc, CONST84 char *const *argv, + char *Tcl_JoinPath(int argc, const char *const *argv, Tcl_DString *resultPtr) } declare 187 { @@ -686,7 +685,7 @@ declare 191 { Tcl_Channel Tcl_MakeTcpClientChannel(ClientData tcpSocket) } declare 192 { - char *Tcl_Merge(int argc, CONST84 char *const *argv) + char *Tcl_Merge(int argc, const char *const *argv) } declare 193 { Tcl_HashEntry *Tcl_NextHashEntry(Tcl_HashSearch *searchPtr) @@ -704,7 +703,7 @@ declare 196 { } declare 197 { Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, int argc, - CONST84 char **argv, int flags) + const char **argv, int flags) } # This is obsolete, use Tcl_FSOpenFileChannel declare 198 { @@ -730,7 +729,7 @@ declare 203 { int Tcl_PutEnv(const char *assignment) } declare 204 { - CONST84_RETURN char *Tcl_PosixError(Tcl_Interp *interp) + const char *Tcl_PosixError(Tcl_Interp *interp) } declare 205 { void Tcl_QueueEvent(Tcl_Event *evPtr, Tcl_QueuePosition position) @@ -766,7 +765,7 @@ declare 214 { } declare 215 { void Tcl_RegExpRange(Tcl_RegExp regexp, int index, - CONST84 char **startPtr, CONST84 char **endPtr) + const char **startPtr, const char **endPtr) } declare 216 { void Tcl_Release(ClientData clientData) @@ -780,8 +779,7 @@ declare 218 { declare 219 { int Tcl_ScanCountedElement(const char *src, int length, int *flagPtr) } -# Obsolete -declare 220 { +declare 220 {deprecated {}} { int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode) } declare 221 { @@ -815,7 +813,7 @@ declare 229 { void Tcl_SetMaxBlockTime(const Tcl_Time *timePtr) } declare 230 { - void Tcl_SetPanicProc(Tcl_PanicProc *panicProc) + void Tcl_SetPanicProc(TCL_NORETURN1 Tcl_PanicProc *panicProc) } declare 231 { int Tcl_SetRecursionLimit(Tcl_Interp *interp, int depth) @@ -836,30 +834,30 @@ declare 235 { declare 236 { void Tcl_SetStdChannel(Tcl_Channel channel, int type) } -declare 237 { - CONST84_RETURN char *Tcl_SetVar(Tcl_Interp *interp, const char *varName, +declare 237 {deprecated {No longer in use, changed to macro}} { + const char *Tcl_SetVar(Tcl_Interp *interp, const char *varName, const char *newValue, int flags) } declare 238 { - CONST84_RETURN char *Tcl_SetVar2(Tcl_Interp *interp, const char *part1, + const char *Tcl_SetVar2(Tcl_Interp *interp, const char *part1, const char *part2, const char *newValue, int flags) } declare 239 { - CONST84_RETURN char *Tcl_SignalId(int sig) + const char *Tcl_SignalId(int sig) } declare 240 { - CONST84_RETURN char *Tcl_SignalMsg(int sig) + const char *Tcl_SignalMsg(int sig) } declare 241 { void Tcl_SourceRCFile(Tcl_Interp *interp) } declare 242 { int Tcl_SplitList(Tcl_Interp *interp, const char *listStr, int *argcPtr, - CONST84 char ***argvPtr) + const char ***argvPtr) } # Obsolete, use Tcl_FSSplitPath declare 243 { - void Tcl_SplitPath(const char *path, int *argcPtr, CONST84 char ***argvPtr) + void Tcl_SplitPath(const char *path, int *argcPtr, const char ***argvPtr) } declare 244 { void Tcl_StaticPackage(Tcl_Interp *interp, const char *pkgName, @@ -868,11 +866,10 @@ declare 244 { declare 245 { int Tcl_StringMatch(const char *str, const char *pattern) } -# Obsolete -declare 246 { +declare 246 {deprecated {}} { int Tcl_TellOld(Tcl_Channel chan) } -declare 247 { +declare 247 {deprecated {No longer in use, changed to macro}} { int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData) } @@ -893,14 +890,14 @@ declare 251 { declare 252 { int Tcl_UnregisterChannel(Tcl_Interp *interp, Tcl_Channel chan) } -declare 253 { +declare 253 {deprecated {No longer in use, changed to macro}} { int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName, int flags) } declare 254 { int Tcl_UnsetVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags) } -declare 255 { +declare 255 {deprecated {No longer in use, changed to macro}} { void Tcl_UntraceVar(Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData) } @@ -912,7 +909,7 @@ declare 256 { declare 257 { void Tcl_UpdateLinkedVar(Tcl_Interp *interp, const char *varName) } -declare 258 { +declare 258 {deprecated {No longer in use, changed to macro}} { int Tcl_UpVar(Tcl_Interp *interp, const char *frameName, const char *varName, const char *localName, int flags) } @@ -923,7 +920,7 @@ declare 259 { declare 260 { int Tcl_VarEval(Tcl_Interp *interp, ...) } -declare 261 { +declare 261 {deprecated {No longer in use, changed to macro}} { ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData) } @@ -945,48 +942,48 @@ declare 265 { declare 266 { void Tcl_ValidateAllMemory(const char *file, int line) } -declare 267 { +declare 267 {deprecated {see TIP #422}} { void Tcl_AppendResultVA(Tcl_Interp *interp, va_list argList) } -declare 268 { +declare 268 {deprecated {see TIP #422}} { void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, va_list argList) } declare 269 { char *Tcl_HashStats(Tcl_HashTable *tablePtr) } declare 270 { - CONST84_RETURN char *Tcl_ParseVar(Tcl_Interp *interp, const char *start, - CONST84 char **termPtr) + const char *Tcl_ParseVar(Tcl_Interp *interp, const char *start, + const char **termPtr) } -declare 271 { - CONST84_RETURN char *Tcl_PkgPresent(Tcl_Interp *interp, const char *name, +declare 271 {deprecated {No longer in use, changed to macro}} { + const char *Tcl_PkgPresent(Tcl_Interp *interp, const char *name, const char *version, int exact) } declare 272 { - CONST84_RETURN char *Tcl_PkgPresentEx(Tcl_Interp *interp, + const char *Tcl_PkgPresentEx(Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr) } -declare 273 { +declare 273 {deprecated {No longer in use, changed to macro}} { int Tcl_PkgProvide(Tcl_Interp *interp, const char *name, const char *version) } # TIP #268: The internally used new Require function is in slot 573. -declare 274 { - CONST84_RETURN char *Tcl_PkgRequire(Tcl_Interp *interp, const char *name, +declare 274 {deprecated {No longer in use, changed to macro}} { + const char *Tcl_PkgRequire(Tcl_Interp *interp, const char *name, const char *version, int exact) } -declare 275 { +declare 275 {deprecated {see TIP #422}} { void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList) } -declare 276 { +declare 276 {deprecated {see TIP #422}} { int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList) } declare 277 { Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options) } -declare 278 { - void Tcl_PanicVA(const char *format, va_list argList) +declare 278 {deprecated {see TIP #422}} { + TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList) } declare 279 { void Tcl_GetVersion(int *major, int *minor, int *patchLevel, int *type) @@ -1059,7 +1056,7 @@ declare 293 { int Tcl_EvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags) } declare 294 { - void Tcl_ExitThread(int status) + TCL_NORETURN void Tcl_ExitThread(int status) } declare 295 { int Tcl_ExternalToUtf(Tcl_Interp *interp, Tcl_Encoding encoding, @@ -1087,7 +1084,7 @@ declare 301 { Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, const char *name) } declare 302 { - CONST84_RETURN char *Tcl_GetEncodingName(Tcl_Encoding encoding) + const char *Tcl_GetEncodingName(Tcl_Encoding encoding) } declare 303 { void Tcl_GetEncodingNames(Tcl_Interp *interp) @@ -1148,22 +1145,22 @@ declare 319 { Tcl_QueuePosition position) } declare 320 { - Tcl_UniChar Tcl_UniCharAtIndex(const char *src, int index) + int Tcl_UniCharAtIndex(const char *src, int index) } declare 321 { - Tcl_UniChar Tcl_UniCharToLower(int ch) + int Tcl_UniCharToLower(int ch) } declare 322 { - Tcl_UniChar Tcl_UniCharToTitle(int ch) + int Tcl_UniCharToTitle(int ch) } declare 323 { - Tcl_UniChar Tcl_UniCharToUpper(int ch) + int Tcl_UniCharToUpper(int ch) } declare 324 { int Tcl_UniCharToUtf(int ch, char *buf) } declare 325 { - CONST84_RETURN char *Tcl_UtfAtIndex(const char *src, int index) + const char *Tcl_UtfAtIndex(const char *src, int index) } declare 326 { int Tcl_UtfCharComplete(const char *src, int length) @@ -1172,16 +1169,16 @@ declare 327 { int Tcl_UtfBackslash(const char *src, int *readPtr, char *dst) } declare 328 { - CONST84_RETURN char *Tcl_UtfFindFirst(const char *src, int ch) + const char *Tcl_UtfFindFirst(const char *src, int ch) } declare 329 { - CONST84_RETURN char *Tcl_UtfFindLast(const char *src, int ch) + const char *Tcl_UtfFindLast(const char *src, int ch) } declare 330 { - CONST84_RETURN char *Tcl_UtfNext(const char *src) + const char *Tcl_UtfNext(const char *src) } declare 331 { - CONST84_RETURN char *Tcl_UtfPrev(const char *src, const char *start) + const char *Tcl_UtfPrev(const char *src, const char *start) } declare 332 { int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding, @@ -1214,10 +1211,10 @@ declare 339 { declare 340 { char *Tcl_GetString(Tcl_Obj *objPtr) } -declare 341 { - CONST84_RETURN char *Tcl_GetDefaultEncodingDir(void) +declare 341 {deprecated {Use Tcl_GetEncodingSearchPath}} { + const char *Tcl_GetDefaultEncodingDir(void) } -declare 342 { +declare 342 {deprecated {Use Tcl_SetEncodingSearchPath}} { void Tcl_SetDefaultEncodingDir(const char *path) } declare 343 { @@ -1266,7 +1263,7 @@ declare 356 { Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, int flags) } -declare 357 { +declare 357 {deprecated {Use Tcl_EvalTokensStandard}} { Tcl_Obj *Tcl_EvalTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count) } @@ -1279,7 +1276,7 @@ declare 359 { } declare 360 { int Tcl_ParseBraces(Tcl_Interp *interp, const char *start, int numBytes, - Tcl_Parse *parsePtr, int append, CONST84 char **termPtr) + Tcl_Parse *parsePtr, int append, const char **termPtr) } declare 361 { int Tcl_ParseCommand(Tcl_Interp *interp, const char *start, int numBytes, @@ -1292,7 +1289,7 @@ declare 362 { declare 363 { int Tcl_ParseQuotedString(Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, - CONST84 char **termPtr) + const char **termPtr) } declare 364 { int Tcl_ParseVarName(Tcl_Interp *interp, const char *start, int numBytes, @@ -1351,9 +1348,9 @@ declare 380 { int Tcl_GetCharLength(Tcl_Obj *objPtr) } declare 381 { - Tcl_UniChar Tcl_GetUniChar(Tcl_Obj *objPtr, int index) + int Tcl_GetUniChar(Tcl_Obj *objPtr, int index) } -declare 382 { +declare 382 {deprecated {No longer in use, changed to macro}} { Tcl_UniChar *Tcl_GetUnicode(Tcl_Obj *objPtr) } declare 383 { @@ -1408,7 +1405,7 @@ declare 397 { int Tcl_ChannelBuffered(Tcl_Channel chan) } declare 398 { - CONST84_RETURN char *Tcl_ChannelName(const Tcl_ChannelType *chanTypePtr) + const char *Tcl_ChannelName(const Tcl_ChannelType *chanTypePtr) } declare 399 { Tcl_ChannelTypeVersion Tcl_ChannelVersion( @@ -1548,12 +1545,12 @@ declare 434 { } # TIP#15 (math function introspection) dkf -declare 435 { +declare 435 {deprecated {}} { int Tcl_GetMathFuncInfo(Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, ClientData *clientDataPtr) } -declare 436 { +declare 436 {deprecated {}} { Tcl_Obj *Tcl_ListMathFuncs(Tcl_Interp *interp, const char *pattern) } @@ -1872,7 +1869,7 @@ declare 518 { # TIP#121 (exit handler) dkf for Joe Mistachkin declare 519 { - Tcl_ExitProc *Tcl_SetExitProc(Tcl_ExitProc *proc) + Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc) } # TIP#143 (resource limits) dkf @@ -2326,6 +2323,17 @@ declare 630 { # ----- BASELINE -- FOR -- 8.6.0 ----- # +# TIP #456 +declare 631 { + Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp, const char *service, + const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc, + ClientData callbackData) +} + +# ----- BASELINE -- FOR -- 8.7.0 ----- # + + + ############################################################################## # Define the platform specific public Tcl interface. These functions are only @@ -2371,6 +2379,10 @@ export { void Tcl_Main(int argc, char **argv, Tcl_AppInitProc *appInitProc) } export { + void Tcl_MainEx(int argc, char **argv, Tcl_AppInitProc *appInitProc, + Tcl_Interp *interp) +} +export { const char *Tcl_InitStubs(Tcl_Interp *interp, const char *version, int exact) } diff --git a/generic/tcl.h b/generic/tcl.h index a833218..b44b9c3 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -38,10 +38,9 @@ extern "C" { * update the version numbers: * * library/init.tcl (1 LOC patch) - * unix/configure.in (2 LOC Major, 2 LOC minor, 1 LOC patch) - * win/configure.in (as above) + * unix/configure.ac (2 LOC Major, 2 LOC minor, 1 LOC patch) + * win/configure.ac (as above) * win/tcl.m4 (not patchlevel) - * win/makefile.bc (not patchlevel) 2 LOC * README (sections 0 and 2, with and without separator) * macosx/Tcl.pbproj/project.pbxproj (not patchlevel) 1 LOC * macosx/Tcl.pbproj/default.pbxuser (not patchlevel) 1 LOC @@ -54,40 +53,28 @@ extern "C" { */ #define TCL_MAJOR_VERSION 8 -#define TCL_MINOR_VERSION 6 -#define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE -#define TCL_RELEASE_SERIAL 0 +#define TCL_MINOR_VERSION 7 +#define TCL_RELEASE_LEVEL TCL_ALPHA_RELEASE +#define TCL_RELEASE_SERIAL 2 -#define TCL_VERSION "8.6" -#define TCL_PATCH_LEVEL "8.6.0" +#define TCL_VERSION "8.7" +#define TCL_PATCH_LEVEL "8.7a2" +#if !defined(TCL_NO_DEPRECATED) || defined(RC_INVOKED) /* *---------------------------------------------------------------------------- * The following definitions set up the proper options for Windows compilers. * We use this method because there is no autoconf equivalent. */ -#ifndef __WIN32__ -# if defined(_WIN32) || defined(WIN32) || defined(__MINGW32__) || defined(__BORLANDC__) || (defined(__WATCOMC__) && defined(__WINDOWS_386__)) +#ifdef _WIN32 +# ifndef __WIN32__ # define __WIN32__ -# ifndef WIN32 -# define WIN32 -# endif -# ifndef _WIN32 -# define _WIN32 -# endif # endif -#endif - -/* - * STRICT: See MSDN Article Q83456 - */ - -#ifdef __WIN32__ -# ifndef STRICT -# define STRICT +# ifndef WIN32 +# define WIN32 # endif -#endif /* __WIN32__ */ +#endif /* * Utility macros: STRINGIFY takes an argument and wraps it in "" (double @@ -103,6 +90,11 @@ extern "C" { # define JOIN1(a,b) a##b #endif +#ifndef TCL_THREADS +# define TCL_THREADS 1 +#endif +#endif /* !TCL_NO_DEPRECATED */ + /* * A special definition used to allow this header file to be included from * windows resource files so that they can obtain version information. @@ -115,15 +107,10 @@ extern "C" { #ifndef RC_INVOKED /* - * Special macro to define mutexes, that doesn't do anything if we are not - * using threads. + * Special macro to define mutexes. */ -#ifdef TCL_THREADS #define TCL_DECLARE_MUTEX(name) static Tcl_Mutex name; -#else -#define TCL_DECLARE_MUTEX(name) -#endif /* * Tcl's public routine Tcl_FSSeek() uses the values SEEK_SET, SEEK_CUR, and @@ -149,15 +136,30 @@ extern "C" { */ #include <stdarg.h> -#ifndef TCL_NO_DEPRECATED +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 # 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) -#endif +#endif /* !TCL_NO_DEPRECATED */ #if defined(__GNUC__) && (__GNUC__ > 2) # define TCL_FORMAT_PRINTF(a,b) __attribute__ ((__format__ (__printf__, a, b))) +# define TCL_NORETURN __attribute__ ((noreturn)) +# define TCL_NOINLINE __attribute__ ((noinline)) +# if defined(BUILD_tcl) || defined(BUILD_tk) +# define TCL_NORETURN1 __attribute__ ((noreturn)) +# else +# define TCL_NORETURN1 /* nothing */ +# endif #else # define TCL_FORMAT_PRINTF(a,b) +# if defined(_MSC_VER) && (_MSC_VER >= 1310) +# define TCL_NORETURN _declspec(noreturn) +# define TCL_NOINLINE __declspec(noinline) +# else +# define TCL_NORETURN /* nothing */ +# define TCL_NOINLINE /* nothing */ +# endif +# define TCL_NORETURN1 /* nothing */ #endif /* @@ -168,7 +170,7 @@ extern "C" { */ #if defined(__GNUC__) && ((__GNUC__ >= 4) || ((__GNUC__ == 3) && (__GNUC_MINOR__ >= 1))) -# if (__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC__MINOR__ >= 5)) +# if (__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ >= 5)) # define TCL_DEPRECATED_API(msg) __attribute__ ((__deprecated__ (msg))) # else # define TCL_DEPRECATED_API(msg) __attribute__ ((__deprecated__)) @@ -191,7 +193,7 @@ extern "C" { * MSVCRT. */ -#if (defined(__WIN32__) && (defined(_MSC_VER) || (__BORLANDC__ >= 0x0550) || defined(__LCC__) || defined(__WATCOMC__) || (defined(__GNUC__) && defined(__declspec)))) +#if (defined(_WIN32) && (defined(_MSC_VER) || (defined(__BORLANDC__) && (__BORLANDC__ >= 0x0550)) || defined(__LCC__) || defined(__WATCOMC__) || (defined(__GNUC__) && defined(__declspec)))) # define HAVE_DECLSPEC 1 # ifdef STATIC_BUILD # define DLLIMPORT @@ -251,10 +253,9 @@ extern "C" { * New code should use prototypes. */ -#ifndef TCL_NO_DEPRECATED +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 # undef _ANSI_ARGS_ # define _ANSI_ARGS_(x) x -#endif /* * Definitions that allow this header file to be used either with or without @@ -264,34 +265,14 @@ extern "C" { #ifndef INLINE # define INLINE #endif - -#ifdef NO_CONST -# ifndef const -# define const -# endif -#endif #ifndef CONST # define CONST const #endif -#ifdef USE_NON_CONST -# ifdef USE_COMPAT_CONST -# error define at most one of USE_NON_CONST and USE_COMPAT_CONST -# endif -# define CONST84 -# define CONST84_RETURN -#else -# ifdef USE_COMPAT_CONST -# define CONST84 -# define CONST84_RETURN const -# else -# define CONST84 const -# define CONST84_RETURN const -# endif -#endif +#endif /* !TCL_NO_DEPRECATED */ #ifndef CONST86 -# define CONST86 CONST84 +# define CONST86 const #endif /* @@ -315,14 +296,15 @@ extern "C" { * VOID. This block is skipped under Cygwin and Mingw. */ -#if defined(__WIN32__) && !defined(HAVE_WINNT_IGNORE_VOID) +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 +#if defined(_WIN32) && !defined(HAVE_WINNT_IGNORE_VOID) #ifndef VOID #define VOID void typedef char CHAR; typedef short SHORT; typedef long LONG; #endif -#endif /* __WIN32__ && !HAVE_WINNT_IGNORE_VOID */ +#endif /* _WIN32 && !HAVE_WINNT_IGNORE_VOID */ /* * Macro to use instead of "void" for arguments that must have type "void *" @@ -330,23 +312,16 @@ typedef long LONG; */ #ifndef __VXWORKS__ -# ifndef NO_VOID -# define VOID void -# else -# define VOID char -# endif +# define VOID void #endif +#endif /* !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 */ /* * Miscellaneous declarations. */ #ifndef _CLIENTDATA -# ifndef NO_VOID - typedef void *ClientData; -# else - typedef int *ClientData; -# endif + typedef void *ClientData; # define _CLIENTDATA #endif @@ -374,8 +349,8 @@ typedef long LONG; * we have one, we can have the other.) * * 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_WIDE_INT_IS_LONG - if wide ints are really longs (i.e. we're on a + * LP64 system such as modern Solaris or Linux ... not including Win64) * Tcl_WideAsLong - forgetful converter from wideInt to long. * Tcl_LongAsWide - sign-extending converter from long to wideInt. * Tcl_WideAsDouble - converter from wideInt to double. @@ -390,64 +365,49 @@ typedef long LONG; */ #if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG) -# if defined(__WIN32__) +# if defined(_WIN32) # define TCL_WIDE_INT_TYPE __int64 -# ifdef __BORLANDC__ -# define TCL_LL_MODIFIER "L" -# else /* __BORLANDC__ */ -# define TCL_LL_MODIFIER "I64" -# endif /* __BORLANDC__ */ +# define TCL_LL_MODIFIER "I64" +# if defined(_WIN64) +# define TCL_Z_MODIFIER "I" +# endif # elif defined(__GNUC__) -# define TCL_WIDE_INT_TYPE long long -# define TCL_LL_MODIFIER "ll" -# else /* ! __WIN32__ && ! __GNUC__ */ +# define TCL_Z_MODIFIER "z" +# else /* ! _WIN32 && ! __GNUC__ */ /* * 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__ */ +# include <limits.h> +# if defined(LLONG_MAX) && (LLONG_MAX == LONG_MAX) +# define TCL_WIDE_INT_IS_LONG 1 +# endif +# endif /* _WIN32 */ #endif /* !TCL_WIDE_INT_TYPE & !TCL_WIDE_INT_IS_LONG */ -#ifdef TCL_WIDE_INT_IS_LONG -# undef TCL_WIDE_INT_TYPE -# define TCL_WIDE_INT_TYPE long -#endif /* TCL_WIDE_INT_IS_LONG */ + +#ifndef TCL_WIDE_INT_TYPE +# define TCL_WIDE_INT_TYPE long long +#endif /* !TCL_WIDE_INT_TYPE */ typedef TCL_WIDE_INT_TYPE Tcl_WideInt; typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; -#ifdef TCL_WIDE_INT_IS_LONG -# define Tcl_WideAsLong(val) ((long)(val)) -# define Tcl_LongAsWide(val) ((long)(val)) -# define Tcl_WideAsDouble(val) ((double)((long)(val))) -# define Tcl_DoubleAsWide(val) ((long)((double)(val))) -# ifndef TCL_LL_MODIFIER -# define TCL_LL_MODIFIER "l" -# endif /* !TCL_LL_MODIFIER */ -#else /* TCL_WIDE_INT_IS_LONG */ -/* - * The next short section of defines are only done when not running on Windows - * or some other strange platform. - */ -# ifndef TCL_LL_MODIFIER -# define TCL_LL_MODIFIER "ll" -# endif /* !TCL_LL_MODIFIER */ -# define Tcl_WideAsLong(val) ((long)((Tcl_WideInt)(val))) -# define Tcl_LongAsWide(val) ((Tcl_WideInt)((long)(val))) -# define Tcl_WideAsDouble(val) ((double)((Tcl_WideInt)(val))) -# define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val))) -#endif /* TCL_WIDE_INT_IS_LONG */ - -#if defined(__WIN32__) +#ifndef TCL_LL_MODIFIER +# define TCL_LL_MODIFIER "ll" +#endif /* !TCL_LL_MODIFIER */ +#ifndef TCL_Z_MODIFIER +# if defined(__GNUC__) && !defined(_WIN32) +# define TCL_Z_MODIFIER "z" +# else +# define TCL_Z_MODIFIER "" +# endif +#endif /* !TCL_Z_MODIFIER */ +#define Tcl_WideAsLong(val) ((long)((Tcl_WideInt)(val))) +#define Tcl_LongAsWide(val) ((Tcl_WideInt)((long)(val))) +#define Tcl_WideAsDouble(val) ((double)((Tcl_WideInt)(val))) +#define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val))) + +#if defined(_WIN32) # ifdef __BORLANDC__ typedef struct stati64 Tcl_StatBuf; # elif defined(_WIN64) @@ -458,7 +418,7 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; typedef struct _stat32i64 Tcl_StatBuf; # endif /* _MSC_VER < 1400 */ #elif defined(__CYGWIN__) - typedef struct _stat32i64 { + typedef struct { dev_t st_dev; unsigned short st_ino; unsigned short st_mode; @@ -501,37 +461,15 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; */ typedef struct Tcl_Interp -#ifndef TCL_NO_DEPRECATED +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 { /* TIP #330: Strongly discourage extensions from using the string * result. */ -#ifdef USE_INTERP_RESULT - char *result TCL_DEPRECATED_API("use Tcl_GetStringResult/Tcl_SetResult"); - /* If the last command returned a string - * result, this points to it. */ - void (*freeProc) (char *blockPtr) - TCL_DEPRECATED_API("use Tcl_GetStringResult/Tcl_SetResult"); - /* Zero means the string result is statically - * allocated. TCL_DYNAMIC means it was - * allocated with ckalloc and should be freed - * with ckfree. Other values give the address - * of function to invoke to free the result. - * Tcl_Eval must free it before executing next - * command. */ -#else char *resultDontUse; /* Don't use in extensions! */ void (*freeProcDontUse) (char *); /* Don't use in extensions! */ -#endif -#ifdef USE_INTERP_ERRORLINE - int errorLine TCL_DEPRECATED_API("use Tcl_GetErrorLine/Tcl_SetErrorLine"); - /* When TCL_ERROR is returned, this gives the - * line number within the command where the - * error occurred (1 if first line). */ -#else int errorLineDontUse; /* Don't use in extensions! */ -#endif } -#endif /* TCL_NO_DEPRECATED */ +#endif /* !TCL_NO_DEPRECATED */ Tcl_Interp; typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler; @@ -562,7 +500,7 @@ typedef struct Tcl_ZLibStream_ *Tcl_ZlibStream; * will be called as the main fuction of the new thread created by that call. */ -#if defined __WIN32__ +#if defined _WIN32 typedef unsigned (__stdcall Tcl_ThreadCreateProc) (ClientData clientData); #else typedef void (Tcl_ThreadCreateProc) (ClientData clientData); @@ -574,7 +512,7 @@ typedef void (Tcl_ThreadCreateProc) (ClientData clientData); * in generic/tclThreadTest.c for it's usage. */ -#if defined __WIN32__ +#if defined _WIN32 # define Tcl_ThreadCreateType unsigned __stdcall # define TCL_THREAD_CREATE_RETURN return 0 #else @@ -681,7 +619,9 @@ typedef struct stat *Tcl_OldStat_; #define TCL_BREAK 3 #define TCL_CONTINUE 4 +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 #define TCL_RESULT_SIZE 200 +#endif /* *---------------------------------------------------------------------------- @@ -697,6 +637,7 @@ typedef struct stat *Tcl_OldStat_; * Argument descriptors for math function callbacks in expressions: */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 typedef enum { TCL_INT, TCL_DOUBLE, TCL_EITHER, TCL_WIDE_INT } Tcl_ValueType; @@ -708,6 +649,10 @@ typedef struct Tcl_Value { double doubleValue; /* Double-precision floating value. */ Tcl_WideInt wideValue; /* Wide (min. 64-bit) integer value. */ } Tcl_Value; +#else +#define Tcl_ValueType void /* Just enough to prevent compilation error in Tcl */ +#define Tcl_Value void /* Just enough to prevent compilation error in Tcl */ +#endif /* * Forward declaration of Tcl_Obj to prevent an error when the forward @@ -728,10 +673,10 @@ typedef void (Tcl_ChannelProc) (ClientData clientData, int mask); typedef void (Tcl_CloseProc) (ClientData data); typedef void (Tcl_CmdDeleteProc) (ClientData clientData); typedef int (Tcl_CmdProc) (ClientData clientData, Tcl_Interp *interp, - int argc, CONST84 char *argv[]); + int argc, const char *argv[]); typedef void (Tcl_CmdTraceProc) (ClientData clientData, Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *proc, - ClientData cmdClientData, int argc, CONST84 char *argv[]); + ClientData cmdClientData, int argc, const char *argv[]); typedef int (Tcl_CmdObjTraceProc) (ClientData clientData, Tcl_Interp *interp, int level, const char *command, Tcl_Command commandInfo, int objc, struct Tcl_Obj *const *objv); @@ -768,7 +713,7 @@ typedef void (Tcl_TimerProc) (ClientData clientData); typedef int (Tcl_SetFromAnyProc) (Tcl_Interp *interp, struct Tcl_Obj *objPtr); typedef void (Tcl_UpdateStringProc) (struct Tcl_Obj *objPtr); typedef char * (Tcl_VarTraceProc) (ClientData clientData, Tcl_Interp *interp, - CONST84 char *part1, CONST84 char *part2, int flags); + const char *part1, const char *part2, int flags); typedef void (Tcl_CommandTraceProc) (ClientData clientData, Tcl_Interp *interp, const char *oldName, const char *newName, int flags); typedef void (Tcl_CreateFileHandlerProc) (int fd, int mask, Tcl_FileProc *proc, @@ -833,18 +778,20 @@ typedef struct Tcl_Obj { union { /* The internal representation: */ long longValue; /* - an long integer value. */ double doubleValue; /* - a double-precision floating value. */ - void *otherValuePtr; /* - another, type-specific value. */ + void *otherValuePtr; /* - another, type-specific value, not used + * internally any more. */ Tcl_WideInt wideValue; /* - a long long value. */ - struct { /* - internal rep as two pointers. */ + struct { /* - internal rep as two pointers. + * Many uses in Tcl, including a bignum's + * tightly packed fields, where the alloc, + * used and signum flags are packed into + * ptr2 with everything else hung off + * ptr1. */ void *ptr1; void *ptr2; } twoPtrValue; struct { /* - internal rep as a pointer and a long, - * the main use of which is a bignum's - * tightly packed fields, where the alloc, - * used and signum flags are packed into a - * single word with everything else hung - * off the pointer. */ + * not used internally any more. */ void *ptr; unsigned long value; } ptrAndLongRep; @@ -877,7 +824,7 @@ typedef struct Tcl_SavedResult { char *appendResult; int appendAvl; int appendUsed; - char resultSpace[TCL_RESULT_SIZE+1]; + char resultSpace[200+1]; } Tcl_SavedResult; /* @@ -1003,7 +950,9 @@ typedef struct Tcl_DString { #define Tcl_DStringLength(dsPtr) ((dsPtr)->length) #define Tcl_DStringValue(dsPtr) ((dsPtr)->string) -#define Tcl_DStringTrunc Tcl_DStringSetLength +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 +# define Tcl_DStringTrunc Tcl_DStringSetLength +#endif /* !TCL_NO_DEPRECATED */ /* * Definitions for the maximum number of digits of precision that may be @@ -1129,9 +1078,9 @@ typedef struct Tcl_DString { * give the flag) */ -#ifndef TCL_NO_DEPRECATED +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 # define TCL_PARSE_PART1 0x400 -#endif +#endif /* !TCL_NO_DEPRECATED */ /* * Types for linked variables: @@ -1147,8 +1096,13 @@ typedef struct Tcl_DString { #define TCL_LINK_SHORT 8 #define TCL_LINK_USHORT 9 #define TCL_LINK_UINT 10 +#if defined(TCL_WIDE_INT_IS_LONG) || defined(_WIN32) || defined(__CYGWIN__) +#define TCL_LINK_LONG ((sizeof(long) != sizeof(int)) ? TCL_LINK_WIDE_INT : TCL_LINK_INT) +#define TCL_LINK_ULONG ((sizeof(long) != sizeof(int)) ? TCL_LINK_WIDE_UINT : TCL_LINK_UINT) +#else #define TCL_LINK_LONG 11 #define TCL_LINK_ULONG 12 +#endif #define TCL_LINK_FLOAT 13 #define TCL_LINK_WIDE_UINT 14 #define TCL_LINK_READ_ONLY 0x80 @@ -1158,29 +1112,21 @@ typedef struct Tcl_DString { * Forward declarations of Tcl_HashTable and related types. */ +#ifndef TCL_HASH_TYPE +# define TCL_HASH_TYPE unsigned +#endif + typedef struct Tcl_HashKeyType Tcl_HashKeyType; typedef struct Tcl_HashTable Tcl_HashTable; typedef struct Tcl_HashEntry Tcl_HashEntry; -typedef unsigned (Tcl_HashKeyProc) (Tcl_HashTable *tablePtr, void *keyPtr); +typedef TCL_HASH_TYPE (Tcl_HashKeyProc) (Tcl_HashTable *tablePtr, void *keyPtr); typedef int (Tcl_CompareHashKeysProc) (void *keyPtr, Tcl_HashEntry *hPtr); typedef Tcl_HashEntry * (Tcl_AllocHashEntryProc) (Tcl_HashTable *tablePtr, void *keyPtr); typedef void (Tcl_FreeHashEntryProc) (Tcl_HashEntry *hPtr); /* - * This flag controls whether the hash table stores the hash of a key, or - * recalculates it. There should be no reason for turning this flag off as it - * is completely binary and source compatible unless you directly access the - * bucketPtr member of the Tcl_HashTableEntry structure. This member has been - * removed and the space used to store the hash value. - */ - -#ifndef TCL_HASH_KEY_STORE_HASH -# define TCL_HASH_KEY_STORE_HASH 1 -#endif - -/* * Structure definition for an entry in a hash table. No-one outside Tcl * should access any of these fields directly; use the macros defined below. */ @@ -1189,15 +1135,9 @@ struct Tcl_HashEntry { Tcl_HashEntry *nextPtr; /* Pointer to next entry in this hash bucket, * or NULL for end of chain. */ Tcl_HashTable *tablePtr; /* Pointer to table containing entry. */ -#if TCL_HASH_KEY_STORE_HASH void *hash; /* Hash value, stored as pointer to ensure * that the offsets of the fields in this * structure are not changed. */ -#else - Tcl_HashEntry **bucketPtr; /* Pointer to bucket that points to first - * entry in this entry's chain: used for - * deleting the entry. */ -#endif ClientData clientData; /* Application stores something here with * Tcl_SetHashValue. */ union { /* Key has one of these forms: */ @@ -1334,9 +1274,9 @@ typedef struct Tcl_HashSearch { * 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 + * While maintaining binary compatibility 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 + * which don't have a typePtr and new ones which do. Once binary compatibility * 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 @@ -1357,8 +1297,8 @@ typedef struct Tcl_HashSearch { typedef struct { void *next; /* Search position for underlying hash * table. */ - int epoch; /* Epoch marker for dictionary being searched, - * or -1 if search has terminated. */ + unsigned int epoch; /* Epoch marker for dictionary being searched, + * or 0 if search has terminated. */ Tcl_Dict dictionaryPtr; /* Reference to dictionary being searched. */ } Tcl_DictSearch; @@ -1491,14 +1431,14 @@ typedef int (Tcl_DriverClose2Proc) (ClientData instanceData, typedef int (Tcl_DriverInputProc) (ClientData instanceData, char *buf, int toRead, int *errorCodePtr); typedef int (Tcl_DriverOutputProc) (ClientData instanceData, - CONST84 char *buf, int toWrite, int *errorCodePtr); + const char *buf, int toWrite, int *errorCodePtr); typedef int (Tcl_DriverSeekProc) (ClientData instanceData, long offset, int mode, int *errorCodePtr); typedef int (Tcl_DriverSetOptionProc) (ClientData instanceData, Tcl_Interp *interp, const char *optionName, const char *value); typedef int (Tcl_DriverGetOptionProc) (ClientData instanceData, - Tcl_Interp *interp, CONST84 char *optionName, + Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr); typedef void (Tcl_DriverWatchProc) (ClientData instanceData, int mask); typedef int (Tcl_DriverGetHandleProc) (ClientData instanceData, @@ -1991,7 +1931,7 @@ typedef struct Tcl_Token { * TCL_TOKEN_OPERATOR - The token describes one expression operator. * An operator might be the name of a math * function such as "abs". A TCL_TOKEN_OPERATOR - * token is always preceeded by one + * token is always preceded by one * TCL_TOKEN_SUB_EXPR token for the operator's * subexpression, and is followed by zero or more * TCL_TOKEN_SUB_EXPR tokens for the operator's @@ -2147,11 +2087,28 @@ typedef struct Tcl_EncodingType { * substituting one or more "close" characters in * the destination buffer and then continue to * convert the source. + * TCL_ENCODING_NO_TERMINATE - If set, Tcl_ExternalToUtf will not append a + * terminating NUL byte. Knowing that it will + * not need space to do so, it will fill all + * dstLen bytes with encoded UTF-8 content, as + * other circumstances permit. If clear, the + * default behavior is to reserve a byte in + * the dst space for NUL termination, and to + * append the NUL byte. + * TCL_ENCODING_CHAR_LIMIT - If set and dstCharsPtr is not NULL, then + * Tcl_ExternalToUtf takes the initial value + * of *dstCharsPtr is taken as a limit of the + * maximum number of chars to produce in the + * encoded UTF-8 content. Otherwise, the + * number of chars produced is controlled only + * by other limiting factors. */ #define TCL_ENCODING_START 0x01 #define TCL_ENCODING_END 0x02 #define TCL_ENCODING_STOPONERROR 0x04 +#define TCL_ENCODING_NO_TERMINATE 0x08 +#define TCL_ENCODING_CHAR_LIMIT 0x10 /* * The following definitions are the error codes returned by the conversion @@ -2188,16 +2145,16 @@ typedef struct Tcl_EncodingType { /* * The maximum number of bytes that are necessary to represent a single - * Unicode character in UTF-8. The valid values should be 3, 4 or 6 - * (or perhaps 1 if we want to support a non-unicode enabled core). If 3 or - * 4, then Tcl_UniChar must be 2-bytes in size (UCS-2) (the default). If 6, + * Unicode character in UTF-8. The valid values are 4 and 6 + * (or perhaps 1 if we want to support a non-unicode enabled core). If 4, + * then Tcl_UniChar must be 2-bytes in size (UCS-2) (the default). If 6, * then Tcl_UniChar must be 4-bytes in size (UCS-4). At this time UCS-2 mode * is the default and recommended mode. UCS-4 is experimental and not * recommended. It works for the core, but most extensions expect UCS-2. */ #ifndef TCL_UTF_MAX -#define TCL_UTF_MAX 3 +#define TCL_UTF_MAX 4 #endif /* @@ -2259,6 +2216,8 @@ typedef struct mp_int mp_int; #define MP_INT_DECLARED typedef unsigned int mp_digit; #define MP_DIGIT_DECLARED +typedef unsigned TCL_WIDE_INT_TYPE mp_word; +#define MP_WORD_DECLARED /* *---------------------------------------------------------------------------- @@ -2369,6 +2328,13 @@ typedef int (Tcl_ArgvGenFuncProc)(ClientData clientData, Tcl_Interp *interp, /* *---------------------------------------------------------------------------- + * Definitions needed for the Tcl_OpenTcpServerEx function. [TIP #456] + */ +#define TCL_TCPSERVER_REUSEADDR (1<<0) +#define TCL_TCPSERVER_REUSEPORT (1<<1) + +/* + *---------------------------------------------------------------------------- * Single public declaration for NRE. */ @@ -2378,13 +2344,10 @@ typedef int (Tcl_NRPostProc) (ClientData data[], Tcl_Interp *interp, /* *---------------------------------------------------------------------------- * The following constant is used to test for older versions of Tcl in the - * stubs tables. - * - * Jan Nijtman's plus patch uses 0xFCA1BACF, so we need to pick a different - * value since the stubs tables don't match. + * stubs tables. If TCL_UTF_MAX>4 use a different value. */ -#define TCL_STUB_MAGIC ((int) 0xFCA3BACF) +#define TCL_STUB_MAGIC ((int) 0xFCA3BACF + (TCL_UTF_MAX>4)) /* * The following function is required to be defined in all stubs aware @@ -2394,22 +2357,38 @@ typedef int (Tcl_NRPostProc) (ClientData data[], Tcl_Interp *interp, */ const char * Tcl_InitStubs(Tcl_Interp *interp, const char *version, - int exact); + int exact, int magic); const char * TclTomMathInitializeStubs(Tcl_Interp *interp, const char *version, int epoch, int revision); - -/* - * When not using stubs, make it a macro. - */ - -#ifndef USE_TCL_STUBS -#define Tcl_InitStubs(interp, version, exact) \ - Tcl_PkgInitStubsCheck(interp, version, exact) +#if defined(_WIN32) + TCL_NORETURN void Tcl_ConsolePanic(const char *format, ...); +#else +# define Tcl_ConsolePanic ((Tcl_PanicProc *)0) #endif -/* - * TODO - tommath stubs export goes here! - */ +#ifdef USE_TCL_STUBS +#if TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE +# define Tcl_InitStubs(interp, version, exact) \ + (Tcl_InitStubs)(interp, version, \ + (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \ + TCL_STUB_MAGIC) +#else +# define Tcl_InitStubs(interp, version, exact) \ + (Tcl_InitStubs)(interp, TCL_PATCH_LEVEL, \ + 1|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \ + TCL_STUB_MAGIC) +#endif +#else +#if TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE +# define Tcl_InitStubs(interp, version, exact) \ + Tcl_PkgInitStubsCheck(interp, version, \ + (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16)) +#else +# define Tcl_InitStubs(interp, version, exact) \ + Tcl_PkgInitStubsCheck(interp, TCL_PATCH_LEVEL, \ + 1|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16)) +#endif +#endif /* * Public functions that are not accessible via the stubs table. @@ -2417,14 +2396,12 @@ const char * TclTomMathInitializeStubs(Tcl_Interp *interp, */ #define Tcl_Main(argc, argv, proc) Tcl_MainEx(argc, argv, proc, \ - ((Tcl_CreateInterp)())) + (((Tcl_SetPanicProc)(Tcl_ConsolePanic), Tcl_CreateInterp)())) EXTERN void Tcl_MainEx(int argc, char **argv, Tcl_AppInitProc *appInitProc, Tcl_Interp *interp); EXTERN const char * Tcl_PkgInitStubsCheck(Tcl_Interp *interp, const char *version, int exact); -#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); -#endif /* *---------------------------------------------------------------------------- @@ -2436,9 +2413,15 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); /* * Include platform specific public function declarations that are accessible - * via the stubs table. + * via the stubs table. Make all TclOO symbols MODULE_SCOPE (which only + * has effect on building it as a shared library). See ticket [3010352]. */ +#if defined(BUILD_tcl) +# undef TCLAPI +# define TCLAPI MODULE_SCOPE +#endif + #include "tclPlatDecls.h" /* @@ -2505,7 +2488,7 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); # define Tcl_DecrRefCount(objPtr) \ do { \ Tcl_Obj *_objPtr = (objPtr); \ - if (--(_objPtr)->refCount <= 0) { \ + if ((_objPtr)->refCount-- <= 1) { \ TclFreeObj(_objPtr); \ } \ } while(0) @@ -2525,22 +2508,16 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); Tcl_DbNewBignumObj(val, __FILE__, __LINE__) # undef Tcl_NewBooleanObj # define Tcl_NewBooleanObj(val) \ - Tcl_DbNewBooleanObj(val, __FILE__, __LINE__) + Tcl_DbNewLongObj((val)!=0, __FILE__, __LINE__) # undef Tcl_NewByteArrayObj # define Tcl_NewByteArrayObj(bytes, len) \ Tcl_DbNewByteArrayObj(bytes, len, __FILE__, __LINE__) # undef Tcl_NewDoubleObj # define Tcl_NewDoubleObj(val) \ Tcl_DbNewDoubleObj(val, __FILE__, __LINE__) -# undef Tcl_NewIntObj -# define Tcl_NewIntObj(val) \ - Tcl_DbNewLongObj(val, __FILE__, __LINE__) # undef Tcl_NewListObj # define Tcl_NewListObj(objc, objv) \ Tcl_DbNewListObj(objc, objv, __FILE__, __LINE__) -# undef Tcl_NewLongObj -# define Tcl_NewLongObj(val) \ - Tcl_DbNewLongObj(val, __FILE__, __LINE__) # undef Tcl_NewObj # define Tcl_NewObj() \ Tcl_DbNewObj(__FILE__, __LINE__) @@ -2579,34 +2556,13 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); /* *---------------------------------------------------------------------------- - * Macros that eliminate the overhead of the thread synchronization functions - * when compiling without thread support. - */ - -#ifndef TCL_THREADS -#undef Tcl_MutexLock -#define Tcl_MutexLock(mutexPtr) -#undef Tcl_MutexUnlock -#define Tcl_MutexUnlock(mutexPtr) -#undef Tcl_MutexFinalize -#define Tcl_MutexFinalize(mutexPtr) -#undef Tcl_ConditionNotify -#define Tcl_ConditionNotify(condPtr) -#undef Tcl_ConditionWait -#define Tcl_ConditionWait(condPtr, mutexPtr, timePtr) -#undef Tcl_ConditionFinalize -#define Tcl_ConditionFinalize(condPtr) -#endif /* TCL_THREADS */ - -/* - *---------------------------------------------------------------------------- * Deprecated Tcl functions: */ -#ifndef TCL_NO_DEPRECATED +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 /* * These function have been renamed. The old names are deprecated, but we - * define these macros for backwards compatibilty. + * define these macros for backwards compatibility. */ # define Tcl_Ckalloc Tcl_Alloc @@ -2614,9 +2570,10 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); # define Tcl_Ckrealloc Tcl_Realloc # define Tcl_Return Tcl_SetResult # define Tcl_TildeSubst Tcl_TranslateFileName +#if !defined(__APPLE__) /* On OSX, there is a conflict with "mach/mach.h" */ # define panic Tcl_Panic +#endif # define panicVA Tcl_PanicVA -#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------------- @@ -2627,6 +2584,8 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); extern Tcl_AppInitProc Tcl_AppInit; +#endif /* !TCL_NO_DEPRECATED */ + #endif /* RC_INVOKED */ /* diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c index ae61e85..df1718b 100644 --- a/generic/tclAlloc.c +++ b/generic/tclAlloc.c @@ -22,7 +22,7 @@ */ #include "tclInt.h" -#if !defined(TCL_THREADS) || !defined(USE_THREAD_ALLOC) +#if !TCL_THREADS || !defined(USE_THREAD_ALLOC) #if USE_TCLALLOC @@ -31,8 +31,8 @@ * until Tcl uses config.h properly. */ -#if defined(_MSC_VER) || defined(__MINGW32__) || defined(__BORLANDC__) -typedef unsigned long caddr_t; +#if defined(_MSC_VER) || defined(__MSVCRT__) || defined(__BORLANDC__) +typedef size_t caddr_t; #endif /* @@ -56,7 +56,7 @@ union overhead { unsigned char magic1; /* other magic number */ #ifndef NDEBUG unsigned short rmagic; /* range magic number */ - unsigned long size; /* actual block size */ + size_t size; /* actual block size */ unsigned short unused2; /* padding to 8-byte align */ #endif } ovu; @@ -121,7 +121,7 @@ static struct block bigBlocks={ /* Big blocks aren't suballocated. */ * variable. */ -#ifdef TCL_THREADS +#if TCL_THREADS static Tcl_Mutex *allocMutexPtr; #endif static int allocInit = 0; @@ -133,7 +133,7 @@ static int allocInit = 0; * a given block size. */ -static unsigned int numMallocs[NBUCKETS+1]; +static size_t numMallocs[NBUCKETS+1]; #endif #if !defined(NDEBUG) @@ -148,7 +148,7 @@ static unsigned int numMallocs[NBUCKETS+1]; * Prototypes for functions used only in this file. */ -static void MoreCore(int bucket); +static void MoreCore(size_t bucket); /* *------------------------------------------------------------------------- @@ -171,7 +171,7 @@ TclInitAlloc(void) { if (!allocInit) { allocInit = 1; -#ifdef TCL_THREADS +#if TCL_THREADS allocMutexPtr = Tcl_GetAllocMutex(); #endif } @@ -254,7 +254,7 @@ TclpAlloc( unsigned int numBytes) /* Number of bytes to allocate. */ { register union overhead *overPtr; - register long bucket; + register size_t bucket; register unsigned amount; struct block *bigBlockPtr = NULL; @@ -385,12 +385,12 @@ TclpAlloc( static void MoreCore( - int bucket) /* What bucket to allocat to. */ + size_t bucket) /* What bucket to allocate to. */ { register union overhead *overPtr; - register long size; /* size of desired block */ - long amount; /* amount to allocate */ - int numBlocks; /* how many blocks we get */ + register size_t size; /* size of desired block */ + size_t amount; /* amount to allocate */ + size_t numBlocks; /* how many blocks we get */ struct block *blockPtr; /* @@ -398,14 +398,14 @@ MoreCore( * VAX, I think) or for a negative arg. */ - size = 1 << (bucket + 3); + size = ((size_t)1) << (bucket + 3); ASSERT(size > 0); amount = MAXMALLOC; numBlocks = amount / size; ASSERT(numBlocks*size == amount); - blockPtr = (struct block *) TclpSysAlloc((unsigned) + blockPtr = (struct block *) TclpSysAlloc( (sizeof(struct block) + amount), 1); /* no more room! */ if (blockPtr == NULL) { @@ -448,7 +448,7 @@ void TclpFree( char *oldPtr) /* Pointer to memory to free. */ { - register long size; + register size_t size; register union overhead *overPtr; struct block *bigBlockPtr; @@ -518,7 +518,7 @@ TclpRealloc( union overhead *overPtr; struct block *bigBlockPtr; int expensive; - unsigned long maxSize; + size_t maxSize; if (oldPtr == NULL) { return TclpAlloc(numBytes); @@ -645,29 +645,29 @@ void mstats( char *s) /* Where to write info. */ { - register int i, j; + register unsigned int i, j; register union overhead *overPtr; - int totalFree = 0, totalUsed = 0; + size_t totalFree = 0, totalUsed = 0; Tcl_MutexLock(allocMutexPtr); fprintf(stderr, "Memory allocation statistics %s\nTclpFree:\t", s); for (i = 0; i < NBUCKETS; i++) { for (j=0, overPtr=nextf[i]; overPtr; overPtr=overPtr->next, j++) { - fprintf(stderr, " %d", j); + fprintf(stderr, " %u", j); } - totalFree += j * (1 << (i + 3)); + totalFree += ((size_t)j) * (1 << (i + 3)); } fprintf(stderr, "\nused:\t"); for (i = 0; i < NBUCKETS; i++) { - fprintf(stderr, " %d", numMallocs[i]); + fprintf(stderr, " %" TCL_Z_MODIFIER "u", numMallocs[i]); totalUsed += numMallocs[i] * (1 << (i + 3)); } - fprintf(stderr, "\n\tTotal small in use: %d, total free: %d\n", - totalUsed, totalFree); - fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %d\n", + fprintf(stderr, "\n\tTotal small in use: %" TCL_Z_MODIFIER "u, total free: %" TCL_Z_MODIFIER "u\n", + totalUsed, totalFree); + fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %" TCL_Z_MODIFIER "u\n", MAXMALLOC, numMallocs[NBUCKETS]); Tcl_MutexUnlock(allocMutexPtr); diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 100e9ef..6356a00 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -26,6 +26,7 @@ *- jumpTable testing *- syntax (?) *- returnCodeBranch + *- tclooNext, tclooNextClass */ #include "tclInt.h" @@ -49,7 +50,7 @@ typedef enum BasicBlockCatchState { BBCS_UNKNOWN = 0, /* Catch context has not yet been identified */ BBCS_NONE, /* Block is outside of any catch */ BBCS_INCATCH, /* Block is within a catch context */ - BBCS_CAUGHT, /* Block is within a catch context and + BBCS_CAUGHT /* Block is within a catch context and * may be executed after an exception fires */ } BasicBlockCatchState; @@ -120,7 +121,7 @@ enum BasicBlockFlags { * marking it as the start of a 'catch' * sequence. The 'jumpTarget' is the exception * exit from the catch block. */ - BB_ENDCATCH = (1 << 5), /* Block ends with an 'endCatch' instruction, + BB_ENDCATCH = (1 << 5) /* Block ends with an 'endCatch' instruction, * unwinding the catch from the exception * stack. */ }; @@ -136,6 +137,8 @@ typedef enum TalInstType { * ranges */ ASSEM_BOOL, /* One Boolean operand */ ASSEM_BOOL_LVT4, /* One Boolean, one 4-byte LVT ref. */ + ASSEM_CLOCK_READ, /* 1-byte unsigned-integer case number, in the + * range 0-3 */ ASSEM_CONCAT1, /* 1-byte unsigned-integer operand count, must * be strictly positive, consumes N, produces * 1 */ @@ -183,7 +186,7 @@ typedef enum TalInstType { * produces N */ ASSEM_SINT1, /* One 1-byte signed-integer operand * (INCR_STK_IMM) */ - ASSEM_SINT4_LVT4, /* Signed 4-byte integer operand followed by + ASSEM_SINT4_LVT4 /* Signed 4-byte integer operand followed by * LVT entry. Fixed arity */ } TalInstType; @@ -349,7 +352,9 @@ static const TalInstDesc TalInstructionTable[] = { {"bitnot", ASSEM_1BYTE, INST_BITNOT, 1, 1}, {"bitor", ASSEM_1BYTE, INST_BITOR, 2, 1}, {"bitxor", ASSEM_1BYTE, INST_BITXOR, 2, 1}, - {"concat", ASSEM_CONCAT1, INST_CONCAT1, INT_MIN,1}, + {"clockRead", ASSEM_CLOCK_READ, INST_CLOCK_READ, 0, 1}, + {"concat", ASSEM_CONCAT1, INST_STR_CONCAT1, INT_MIN,1}, + {"concatStk", ASSEM_LIST, INST_CONCAT_STK, INT_MIN,1}, {"coroName", ASSEM_1BYTE, INST_COROUTINE_NAME, 0, 1}, {"currentNamespace",ASSEM_1BYTE, INST_NS_CURRENT, 0, 1}, {"dictAppend", ASSEM_LVT4, INST_DICT_APPEND, 2, 1}, @@ -408,6 +413,10 @@ static const TalInstDesc TalInstructionTable[] = { {"lappendArray", ASSEM_LVT, (INST_LAPPEND_ARRAY1<<8 | INST_LAPPEND_ARRAY4),2, 1}, {"lappendArrayStk", ASSEM_1BYTE, INST_LAPPEND_ARRAY_STK, 3, 1}, + {"lappendList", ASSEM_LVT4, INST_LAPPEND_LIST, 1, 1}, + {"lappendListArray",ASSEM_LVT4, INST_LAPPEND_LIST_ARRAY,2, 1}, + {"lappendListArrayStk", ASSEM_1BYTE,INST_LAPPEND_LIST_ARRAY_STK, 3, 1}, + {"lappendListStk", ASSEM_1BYTE, INST_LAPPEND_LIST_STK, 2, 1}, {"lappendStk", ASSEM_1BYTE, INST_LAPPEND_STK, 2, 1}, {"le", ASSEM_1BYTE, INST_LE, 2, 1}, {"lindexMulti", ASSEM_LINDEX_MULTI, @@ -436,6 +445,8 @@ static const TalInstDesc TalInstructionTable[] = { {"nop", ASSEM_1BYTE, INST_NOP, 0, 0}, {"not", ASSEM_1BYTE, INST_LNOT, 1, 1}, {"nsupvar", ASSEM_LVT4, INST_NSUPVAR, 2, 1}, + {"numericType", ASSEM_1BYTE, INST_NUM_TYPE, 1, 1}, + {"originCmd", ASSEM_1BYTE, INST_ORIGIN_COMMAND, 1, 1}, {"over", ASSEM_OVER, INST_OVER, INT_MIN,-1-1}, {"pop", ASSEM_1BYTE, INST_POP, 1, 0}, {"pushReturnCode", ASSEM_1BYTE, INST_PUSH_RETURN_CODE, 0, 1}, @@ -452,7 +463,11 @@ static const TalInstDesc TalInstructionTable[] = { | INST_STORE_ARRAY4), 2, 1}, {"storeArrayStk", ASSEM_1BYTE, INST_STORE_ARRAY_STK, 3, 1}, {"storeStk", ASSEM_1BYTE, INST_STORE_STK, 2, 1}, + {"strcaseLower", ASSEM_1BYTE, INST_STR_LOWER, 1, 1}, + {"strcaseTitle", ASSEM_1BYTE, INST_STR_TITLE, 1, 1}, + {"strcaseUpper", ASSEM_1BYTE, INST_STR_UPPER, 1, 1}, {"strcmp", ASSEM_1BYTE, INST_STR_CMP, 2, 1}, + {"strcat", ASSEM_CONCAT1, INST_STR_CONCAT1, INT_MIN,1}, {"streq", ASSEM_1BYTE, INST_STR_EQ, 2, 1}, {"strfind", ASSEM_1BYTE, INST_STR_FIND, 2, 1}, {"strindex", ASSEM_1BYTE, INST_STR_INDEX, 2, 1}, @@ -461,12 +476,17 @@ static const TalInstDesc TalInstructionTable[] = { {"strmatch", ASSEM_BOOL, INST_STR_MATCH, 2, 1}, {"strneq", ASSEM_1BYTE, INST_STR_NEQ, 2, 1}, {"strrange", ASSEM_1BYTE, INST_STR_RANGE, 3, 1}, + {"strreplace", ASSEM_1BYTE, INST_STR_REPLACE, 4, 1}, {"strrfind", ASSEM_1BYTE, INST_STR_FIND_LAST, 2, 1}, + {"strtrim", ASSEM_1BYTE, INST_STR_TRIM, 2, 1}, + {"strtrimLeft", ASSEM_1BYTE, INST_STR_TRIM_LEFT, 2, 1}, + {"strtrimRight", ASSEM_1BYTE, INST_STR_TRIM_RIGHT, 2, 1}, {"sub", ASSEM_1BYTE, INST_SUB, 2, 1}, {"tclooClass", ASSEM_1BYTE, INST_TCLOO_CLASS, 1, 1}, {"tclooIsObject", ASSEM_1BYTE, INST_TCLOO_IS_OBJECT, 1, 1}, {"tclooNamespace", ASSEM_1BYTE, INST_TCLOO_NS, 1, 1}, {"tclooSelf", ASSEM_1BYTE, INST_TCLOO_SELF, 0, 1}, + {"tryCvtToBoolean", ASSEM_1BYTE, INST_TRY_CVT_TO_BOOLEAN,1, 2}, {"tryCvtToNumeric", ASSEM_1BYTE, INST_TRY_CVT_TO_NUMERIC,1, 1}, {"uminus", ASSEM_1BYTE, INST_UMINUS, 1, 1}, {"unset", ASSEM_BOOL_LVT4,INST_UNSET_SCALAR, 0, 0}, @@ -493,6 +513,7 @@ static const unsigned char NonThrowingByteCodes[] = { INST_PUSH1, INST_PUSH4, INST_POP, INST_DUP, /* 1-4 */ INST_JUMP1, INST_JUMP4, /* 34-35 */ INST_END_CATCH, INST_PUSH_RESULT, INST_PUSH_RETURN_CODE, /* 70-72 */ + INST_LIST, /* 79 */ INST_OVER, /* 95 */ INST_PUSH_RETURN_OPTIONS, /* 108 */ INST_REVERSE, /* 126 */ @@ -502,7 +523,11 @@ static const unsigned char NonThrowingByteCodes[] = { INST_COROUTINE_NAME, /* 149 */ INST_NS_CURRENT, /* 151 */ INST_INFO_LEVEL_NUM, /* 152 */ - INST_RESOLVE_COMMAND /* 154 */ + INST_RESOLVE_COMMAND, /* 154 */ + INST_STR_TRIM, INST_STR_TRIM_LEFT, INST_STR_TRIM_RIGHT, /* 166-168 */ + INST_CONCAT_STK, /* 169 */ + INST_STR_UPPER, INST_STR_LOWER, INST_STR_TITLE, /* 170-172 */ + INST_NUM_TYPE /* 180 */ }; /* @@ -682,7 +707,7 @@ BBEmitInstInt4( * BBEmitInst1or4 -- * * Emits a 1- or 4-byte operation according to the magnitude of the - * operand + * operand. * *----------------------------------------------------------------------------- */ @@ -844,7 +869,7 @@ CompileAssembleObj( * Not valid, so free it and regenerate. */ - FreeAssembleCodeInternalRep(objPtr); + TclFreeIntRep(objPtr); } /* @@ -869,15 +894,13 @@ CompileAssembleObj( */ TclEmitOpcode(INST_DONE, &compEnv); - TclInitByteCodeObj(objPtr, &compEnv); - objPtr->typePtr = &assembleCodeType; + codePtr = TclInitByteCodeObj(objPtr, &assembleCodeType, &compEnv); TclFreeCompileEnv(&compEnv); /* * Record the local variable context to which the bytecode pertains */ - codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; @@ -1279,8 +1302,8 @@ AssembleOneLine( if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) { goto cleanup; } - operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len); - litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len); + operand1 = TclGetStringFromObj(operand1Obj, &operand1Len); + litIndex = TclRegisterLiteral(envPtr, operand1, operand1Len, 0); BBEmitInst1or4(assemEnvPtr, tblIdx, litIndex, 0); break; @@ -1341,6 +1364,23 @@ AssembleOneLine( TclEmitInt4(localVar, envPtr); break; + case ASSEM_CLOCK_READ: + if (parsePtr->numWords != 2) { + Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8"); + goto cleanup; + } + if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) { + goto cleanup; + } + if (opnd < 0 || opnd > 3) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("operand must be [0..3]", -1)); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND<0,>3", NULL); + goto cleanup; + } + BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, opnd); + break; + case ASSEM_CONCAT1: if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8"); @@ -1428,8 +1468,8 @@ AssembleOneLine( &operand1Obj) != TCL_OK) { goto cleanup; } else { - operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len); - litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len); + operand1 = TclGetStringFromObj(operand1Obj, &operand1Len); + litIndex = TclRegisterLiteral(envPtr, operand1, operand1Len, 0); /* * Assumes that PUSH is the first slot! @@ -1523,7 +1563,7 @@ AssembleOneLine( * Add the (label_name, address) pair to the hash table. */ - if (DefineLabel(assemEnvPtr, Tcl_GetString(operand1Obj)) != TCL_OK) { + if (DefineLabel(assemEnvPtr, TclGetString(operand1Obj)) != TCL_OK) { goto cleanup; } break; @@ -1702,7 +1742,7 @@ AssembleOneLine( default: Tcl_Panic("Instruction \"%s\" could not be found, can't happen\n", - Tcl_GetString(instNameObj)); + TclGetString(instNameObj)); } status = TCL_OK; @@ -1965,15 +2005,15 @@ CreateMirrorJumpTable( DEBUG_PRINT("jump table {\n"); for (i = 0; i < objc; i+=2) { - DEBUG_PRINT(" %s -> %s\n", Tcl_GetString(objv[i]), - Tcl_GetString(objv[i+1])); - hashEntry = Tcl_CreateHashEntry(jtHashPtr, Tcl_GetString(objv[i]), + DEBUG_PRINT(" %s -> %s\n", TclGetString(objv[i]), + TclGetString(objv[i+1])); + hashEntry = Tcl_CreateHashEntry(jtHashPtr, TclGetString(objv[i]), &isNew); if (!isNew) { if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "duplicate entry in jump table for \"%s\"", - Tcl_GetString(objv[i]))); + TclGetString(objv[i]))); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPJUMPTABLEENTRY"); DeleteMirrorJumpTable(jtPtr); return TCL_ERROR; @@ -2206,23 +2246,24 @@ GetListIndexOperand( Tcl_Token* tokenPtr = *tokenPtrPtr; /* INOUT: Pointer to the next token in the * source code */ - Tcl_Obj* intObj; /* Integer from the source code */ - int status; /* Tcl status return */ - - /* - * Extract the next token as a string. - */ + Tcl_Obj *value; + int status; - if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) { + /* General operand validity check */ + if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &value) != TCL_OK) { return TCL_ERROR; } + /* Convert to an integer, advance to the next token and return. */ /* - * Convert to an integer, advance to the next token and return. + * NOTE: Indexing a list with an index before it yields the + * same result as indexing after it, and might be more easily portable + * when list size limits grow. */ + status = TclIndexEncode(interp, value, + TCL_INDEX_BEFORE,TCL_INDEX_BEFORE, result); - status = TclGetIntForIndex(interp, intObj, -2, result); - Tcl_DecrRefCount(intObj); + Tcl_DecrRefCount(value); *tokenPtrPtr = TokenAfter(tokenPtr); return status; } @@ -2268,7 +2309,7 @@ FindLocalVar( if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &varNameObj) != TCL_OK) { return -1; } - varNameStr = Tcl_GetStringFromObj(varNameObj, &varNameLen); + varNameStr = TclGetStringFromObj(varNameObj, &varNameLen); if (CheckNamespaceQualifiers(interp, varNameStr, varNameLen)) { Tcl_DecrRefCount(varNameObj); return -1; @@ -2617,6 +2658,7 @@ AllocBB( bb->minStackDepth = 0; bb->maxStackDepth = 0; bb->finalStackDepth = 0; + bb->catchDepth = 0; bb->enclosingCatch = NULL; bb->foreignExceptionBase = -1; bb->foreignExceptionCount = 0; @@ -2780,7 +2822,7 @@ CalculateJumpRelocations( if (bbPtr->jumpTarget != NULL) { entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(bbPtr->jumpTarget)); + TclGetString(bbPtr->jumpTarget)); if (entry == NULL) { ReportUndefinedLabel(assemEnvPtr, bbPtr, bbPtr->jumpTarget); @@ -2861,10 +2903,10 @@ CheckJumpTableLabels( symEntryPtr = Tcl_NextHashEntry(&search)) { symbolObj = Tcl_GetHashValue(symEntryPtr); valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(symbolObj)); + TclGetString(symbolObj)); DEBUG_PRINT(" %s -> %s (%d)\n", (char*) Tcl_GetHashKey(symHash, symEntryPtr), - Tcl_GetString(symbolObj), (valEntryPtr != NULL)); + TclGetString(symbolObj), (valEntryPtr != NULL)); if (valEntryPtr == NULL) { ReportUndefinedLabel(assemEnvPtr, bbPtr, symbolObj); return TCL_ERROR; @@ -2902,9 +2944,9 @@ ReportUndefinedLabel( if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "undefined label \"%s\"", Tcl_GetString(jumpTarget))); + "undefined label \"%s\"", TclGetString(jumpTarget))); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOLABEL", - Tcl_GetString(jumpTarget), NULL); + TclGetString(jumpTarget), NULL); Tcl_SetErrorLine(interp, bbPtr->jumpLine); } } @@ -2987,7 +3029,7 @@ FillInJumpOffsets( bbPtr = bbPtr->successor1) { if (bbPtr->jumpTarget != NULL) { entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(bbPtr->jumpTarget)); + TclGetString(bbPtr->jumpTarget)); jumpTarget = Tcl_GetHashValue(entry); fromOffset = bbPtr->jumpOffset; targetOffset = jumpTarget->startOffset; @@ -3059,17 +3101,17 @@ ResolveJumpTableTargets( symEntryPtr != NULL; symEntryPtr = Tcl_NextHashEntry(&search)) { symbolObj = Tcl_GetHashValue(symEntryPtr); - DEBUG_PRINT(" symbol %s\n", Tcl_GetString(symbolObj)); + DEBUG_PRINT(" symbol %s\n", TclGetString(symbolObj)); valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(symbolObj)); + TclGetString(symbolObj)); jumpTargetBBPtr = Tcl_GetHashValue(valEntryPtr); realJumpEntryPtr = Tcl_CreateHashEntry(realJumpHashPtr, Tcl_GetHashKey(symHash, symEntryPtr), &junk); DEBUG_PRINT(" %s -> %s -> bb %p (pc %d) hash entry %p\n", (char*) Tcl_GetHashKey(symHash, symEntryPtr), - Tcl_GetString(symbolObj), jumpTargetBBPtr, + TclGetString(symbolObj), jumpTargetBBPtr, jumpTargetBBPtr->startOffset, realJumpEntryPtr); Tcl_SetHashValue(realJumpEntryPtr, @@ -3441,7 +3483,7 @@ StackCheckBasicBlock( if (result == TCL_OK && blockPtr->jumpTarget != NULL) { entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(blockPtr->jumpTarget)); + TclGetString(blockPtr->jumpTarget)); jumpTarget = Tcl_GetHashValue(entry); result = StackCheckBasicBlock(assemEnvPtr, jumpTarget, blockPtr, stackDepth); @@ -3458,7 +3500,7 @@ StackCheckBasicBlock( jtEntry = Tcl_NextHashEntry(&jtSearch)) { targetLabel = Tcl_GetHashValue(jtEntry); entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(targetLabel)); + TclGetString(targetLabel)); jumpTarget = Tcl_GetHashValue(entry); result = StackCheckBasicBlock(assemEnvPtr, jumpTarget, blockPtr, stackDepth); @@ -3520,7 +3562,7 @@ StackCheckExit( * Emit a 'push' of the empty literal. */ - litIndex = TclRegisterNewLiteral(envPtr, "", 0); + litIndex = TclRegisterLiteral(envPtr, "", 0, 0); /* * Assumes that 'push' is at slot 0 in TalInstructionTable. @@ -3763,7 +3805,7 @@ ProcessCatchesInBasicBlock( } if (result == TCL_OK && bbPtr->jumpTarget != NULL) { entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(bbPtr->jumpTarget)); + TclGetString(bbPtr->jumpTarget)); jumpTarget = Tcl_GetHashValue(entry); result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget, jumpEnclosing, jumpState, catchDepth); @@ -3779,7 +3821,7 @@ ProcessCatchesInBasicBlock( jtEntry = Tcl_NextHashEntry(&jtSearch)) { targetLabel = Tcl_GetHashValue(jtEntry); entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(targetLabel)); + TclGetString(targetLabel)); jumpTarget = Tcl_GetHashValue(entry); result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget, jumpEnclosing, jumpState, catchDepth); @@ -3961,10 +4003,12 @@ UnstackExpiredCatches( while (catchDepth > bbPtr->catchDepth) { --catchDepth; - range = envPtr->exceptArrayPtr + catchIndices[catchDepth]; - range->numCodeBytes = bbPtr->startOffset - range->codeOffset; - catches[catchDepth] = NULL; - catchIndices[catchDepth] = -1; + if (catches[catchDepth] != NULL) { + range = envPtr->exceptArrayPtr + catchIndices[catchDepth]; + range->numCodeBytes = bbPtr->startOffset - range->codeOffset; + catches[catchDepth] = NULL; + catchIndices[catchDepth] = -1; + } } /* @@ -4081,7 +4125,7 @@ StackFreshCatches( range->codeOffset = bbPtr->startOffset; entryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(catch->jumpTarget)); + TclGetString(catch->jumpTarget)); if (entryPtr == NULL) { Tcl_Panic("undefined label in tclAssembly.c:" "BuildExceptionRanges, can't happen"); @@ -4223,7 +4267,7 @@ AddBasicBlockRangeToErrorInfo( Tcl_AppendObjToErrorInfo(interp, lineNo); Tcl_AddErrorInfo(interp, " and "); if (bbPtr->successor1 != NULL) { - Tcl_SetIntObj(lineNo, bbPtr->successor1->startLine); + TclSetIntObj(lineNo, bbPtr->successor1->startLine); Tcl_AppendObjToErrorInfo(interp, lineNo); } else { Tcl_AddErrorInfo(interp, "end of assembly code"); @@ -4290,11 +4334,7 @@ FreeAssembleCodeInternalRep( { ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; - codePtr->refCount--; - if (codePtr->refCount <= 0) { - TclCleanupByteCode(codePtr); - } - objPtr->typePtr = NULL; + TclReleaseByteCode(codePtr); } /* diff --git a/generic/tclBasic.c b/generic/tclBasic.c index ccac036..f5a7966 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -22,10 +22,7 @@ #include "tclCompile.h" #include "tommath.h" #include <math.h> - -#if NRE_ENABLE_ASSERTS #include <assert.h> -#endif #define INTERP_STACK_INITIAL_SIZE 2000 #define CORO_STACK_INITIAL_SIZE 200 @@ -132,23 +129,24 @@ static Tcl_ObjCmdProc ExprEntierFunc; static Tcl_ObjCmdProc ExprFloorFunc; static Tcl_ObjCmdProc ExprIntFunc; static Tcl_ObjCmdProc ExprIsqrtFunc; +static Tcl_ObjCmdProc ExprMaxFunc; +static Tcl_ObjCmdProc ExprMinFunc; static Tcl_ObjCmdProc ExprRandFunc; static Tcl_ObjCmdProc ExprRoundFunc; static Tcl_ObjCmdProc ExprSqrtFunc; static Tcl_ObjCmdProc ExprSrandFunc; static Tcl_ObjCmdProc ExprUnaryFunc; static Tcl_ObjCmdProc ExprWideFunc; -static Tcl_Obj * GetCommandSource(Interp *iPtr, int objc, - Tcl_Obj *const objv[]); static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected, int actual, Tcl_Obj *const *objv); static Tcl_NRPostProc NRCoroutineCallerCallback; static Tcl_NRPostProc NRCoroutineExitCallback; -static int NRCommand(ClientData data[], Tcl_Interp *interp, int result); +static Tcl_NRPostProc NRCommand; -static Tcl_NRPostProc NRRunObjProc; +#if !defined(TCL_NO_DEPRECATED) static Tcl_ObjCmdProc OldMathFuncProc; static void OldMathFuncDeleteProc(ClientData clientData); +#endif /* !defined(TCL_NO_DEPRECATED) */ static void ProcessUnexpectedResult(Tcl_Interp *interp, int returnCode); static int RewindCoroutine(CoroutineData *corPtr, int result); @@ -160,10 +158,9 @@ static inline Command * TEOV_LookupCmdFromObj(Tcl_Interp *interp, static int TEOV_NotFound(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Namespace *lookupNsPtr); static int TEOV_RunEnterTraces(Tcl_Interp *interp, - Command **cmdPtrPtr, int objc, - Tcl_Obj *const objv[], Namespace *lookupNsPtr); + Command **cmdPtrPtr, Tcl_Obj *commandPtr, int objc, + Tcl_Obj *const objv[]); static Tcl_NRPostProc RewindCoroutineCallback; -static Tcl_NRPostProc TailcallCleanup; static Tcl_NRPostProc TEOEx_ByteCodeCallback; static Tcl_NRPostProc TEOEx_ListCallback; static Tcl_NRPostProc TEOV_Error; @@ -171,8 +168,11 @@ static Tcl_NRPostProc TEOV_Exception; static Tcl_NRPostProc TEOV_NotFoundCallback; static Tcl_NRPostProc TEOV_RestoreVarFrame; static Tcl_NRPostProc TEOV_RunLeaveTraces; +static Tcl_NRPostProc EvalObjvCore; +static Tcl_NRPostProc Dispatch; static Tcl_ObjCmdProc NRCoroInjectObjCmd; +static Tcl_NRPostProc NRPostInvoke; MODULE_SCOPE const TclStubs tclStubs; @@ -218,11 +218,11 @@ static const CmdInfo builtInCmds[] = { {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, CMD_IS_SAFE}, {"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, CMD_IS_SAFE}, {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, CMD_IS_SAFE}, -#ifndef EXCLUDE_OBSOLETE_COMMANDS +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 {"case", Tcl_CaseObjCmd, NULL, NULL, CMD_IS_SAFE}, #endif {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, CMD_IS_SAFE}, - {"concat", Tcl_ConcatObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"concat", Tcl_ConcatObjCmd, TclCompileConcatCmd, NULL, CMD_IS_SAFE}, {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, CMD_IS_SAFE}, {"coroutine", NULL, NULL, TclNRCoroutineObjCmd, CMD_IS_SAFE}, {"error", Tcl_ErrorObjCmd, TclCompileErrorCmd, NULL, CMD_IS_SAFE}, @@ -238,7 +238,7 @@ static const CmdInfo builtInCmds[] = { {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, NULL, CMD_IS_SAFE}, {"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, NULL, CMD_IS_SAFE}, {"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, CMD_IS_SAFE}, - {"linsert", Tcl_LinsertObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"linsert", Tcl_LinsertObjCmd, TclCompileLinsertCmd, NULL, CMD_IS_SAFE}, {"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, CMD_IS_SAFE|CMD_COMPILES_EXPANDED}, {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, CMD_IS_SAFE}, {"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, CMD_IS_SAFE}, @@ -249,7 +249,7 @@ static const CmdInfo builtInCmds[] = { {"lsearch", Tcl_LsearchObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, CMD_IS_SAFE}, {"lsort", Tcl_LsortObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"package", Tcl_PackageObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"package", Tcl_PackageObjCmd, NULL, TclNRPackageObjCmd, CMD_IS_SAFE}, {"proc", Tcl_ProcObjCmd, NULL, NULL, CMD_IS_SAFE}, {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, CMD_IS_SAFE}, {"regsub", Tcl_RegsubObjCmd, TclCompileRegsubCmd, NULL, CMD_IS_SAFE}, @@ -270,7 +270,7 @@ static const CmdInfo builtInCmds[] = { {"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, NULL, CMD_IS_SAFE}, {"while", Tcl_WhileObjCmd, TclCompileWhileCmd, TclNRWhileObjCmd, CMD_IS_SAFE}, {"yield", NULL, TclCompileYieldCmd, TclNRYieldObjCmd, CMD_IS_SAFE}, - {"yieldto", NULL, NULL, TclNRYieldToObjCmd, CMD_IS_SAFE}, + {"yieldto", NULL, TclCompileYieldToCmd, TclNRYieldToObjCmd, CMD_IS_SAFE}, /* * Commands in the OS-interface. Note that many of these are unsafe. @@ -280,7 +280,6 @@ static const CmdInfo builtInCmds[] = { {"cd", Tcl_CdObjCmd, NULL, NULL, 0}, {"close", Tcl_CloseObjCmd, NULL, NULL, CMD_IS_SAFE}, {"eof", Tcl_EofObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"encoding", Tcl_EncodingObjCmd, NULL, NULL, 0}, {"exec", Tcl_ExecObjCmd, NULL, NULL, 0}, {"exit", Tcl_ExitObjCmd, NULL, NULL, 0}, {"fblocked", Tcl_FblockedObjCmd, NULL, NULL, CMD_IS_SAFE}, @@ -337,6 +336,8 @@ static const BuiltinFuncDef BuiltinFuncTable[] = { { "isqrt", ExprIsqrtFunc, NULL }, { "log", ExprUnaryFunc, (ClientData) log }, { "log10", ExprUnaryFunc, (ClientData) log10 }, + { "max", ExprMaxFunc, NULL }, + { "min", ExprMinFunc, NULL }, { "pow", ExprBinaryFunc, (ClientData) pow }, { "rand", ExprRandFunc, NULL }, { "round", ExprRoundFunc, NULL }, @@ -490,7 +491,6 @@ Tcl_CreateInterp(void) #endif /* TCL_COMPILE_STATS */ char mathFuncName[32]; CallFrame *framePtr; - int result; TclInitSubsystems(); @@ -522,6 +522,7 @@ Tcl_CreateInterp(void) Tcl_InitHashTable(&cancelTable, TCL_ONE_WORD_KEYS); cancelTableInitialized = 1; } + Tcl_MutexUnlock(&cancelLock); } @@ -533,6 +534,7 @@ Tcl_CreateInterp(void) TclRegisterCommandTypeName(TclInvokeImportedCmd, "import"); TclRegisterCommandTypeName(TclOOPublicObjectCmd, "object"); TclRegisterCommandTypeName(TclOOPrivateObjectCmd, "privateObject"); + TclRegisterCommandTypeName(TclOOMyClassObjCmd, "privateClass"); TclRegisterCommandTypeName(TclNRInterpCoroutine, "coroutine"); } @@ -545,7 +547,11 @@ Tcl_CreateInterp(void) iPtr = ckalloc(sizeof(Interp)); interp = (Tcl_Interp *) iPtr; +#ifdef TCL_NO_DEPRECATED + iPtr->result = &tclEmptyString; +#else iPtr->result = iPtr->resultSpace; +#endif iPtr->freeProc = NULL; iPtr->errorLine = 0; iPtr->objResultPtr = Tcl_NewObj(); @@ -555,6 +561,9 @@ Tcl_CreateInterp(void) iPtr->hiddenCmdTablePtr = NULL; iPtr->interpInfo = NULL; + TCL_CT_ASSERT(sizeof(iPtr->extra) <= sizeof(Tcl_HashTable)); + iPtr->extra.optimizer = TclOptimizeBytecode; + iPtr->numLevels = 0; iPtr->maxNestingDepth = MAX_NESTING_DEPTH; iPtr->framePtr = NULL; /* Initialise as soon as :: is available */ @@ -602,23 +611,26 @@ Tcl_CreateInterp(void) iPtr->rootFramePtr = NULL; /* Initialise as soon as :: is available */ iPtr->lookupNsPtr = NULL; +#ifndef TCL_NO_DEPRECATED iPtr->appendResult = NULL; iPtr->appendAvl = 0; iPtr->appendUsed = 0; +#endif Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS); iPtr->packageUnknown = NULL; /* TIP #268 */ +#if (TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE) if (getenv("TCL_PKG_PREFER_LATEST") == NULL) { iPtr->packagePrefer = PKG_PREFER_STABLE; - } else { + } else +#endif iPtr->packagePrefer = PKG_PREFER_LATEST; - } iPtr->cmdCount = 0; TclInitLiteralTable(&iPtr->literalTable); - iPtr->compileEpoch = 0; + iPtr->compileEpoch = 1; iPtr->compiledProcPtr = NULL; iPtr->resolverPtr = NULL; iPtr->evalFlags = 0; @@ -633,7 +645,9 @@ Tcl_CreateInterp(void) iPtr->emptyObjPtr = Tcl_NewObj(); /* Another empty object. */ Tcl_IncrRefCount(iPtr->emptyObjPtr); +#ifndef TCL_NO_DEPRECATED iPtr->resultSpace[0] = 0; +#endif iPtr->threadId = Tcl_GetCurrentThread(); /* TIP #378 */ @@ -668,11 +682,8 @@ Tcl_CreateInterp(void) /* This is needed to satisfy GCC 3.3's strict aliasing rules */ framePtr = ckalloc(sizeof(CallFrame)); - result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr, + (void) Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr, (Tcl_Namespace *) iPtr->globalNsPtr, /*isProcCallFrame*/ 0); - if (result != TCL_OK) { - Tcl_Panic("Tcl_CreateInterp: failed to push the root stack frame"); - } framePtr->objc = 0; iPtr->framePtr = framePtr; @@ -756,9 +767,7 @@ Tcl_CreateInterp(void) * Initialize the ensemble error message rewriting support. */ - iPtr->ensembleRewrite.sourceObjs = NULL; - iPtr->ensembleRewrite.numRemovedObjs = 0; - iPtr->ensembleRewrite.numInsertedObjs = 0; + TclResetRewriteEnsemble(interp, 1); /* * TIP#143: Initialise the resource limit support. @@ -771,7 +780,7 @@ Tcl_CreateInterp(void) * cache was already initialised by the call to alloc the interp struct. */ -#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) +#if TCL_THREADS && defined(USE_THREAD_ALLOC) iPtr->allocCache = TclpGetAllocCache(); #else iPtr->allocCache = NULL; @@ -825,21 +834,23 @@ Tcl_CreateInterp(void) } /* - * Create the "array", "binary", "chan", "dict", "file", "info", - * "namespace" and "string" ensembles. Note that all these commands (and - * their subcommands that are not present in the global namespace) are - * wholly safe *except* for "file". + * Create the "array", "binary", "chan", "clock", "dict", "encoding", + * "file", "info", "namespace" and "string" ensembles. Note that all these + * commands (and their subcommands that are not present in the global + * namespace) are wholly safe *except* for "clock", "encoding" and "file". */ TclInitArrayCmd(interp); TclInitBinaryCmd(interp); TclInitChanCmd(interp); TclInitDictCmd(interp); + TclInitEncodingCmd(interp); TclInitFileCmd(interp); TclInitInfoCmd(interp); TclInitNamespaceCmd(interp); TclInitStringCmd(interp); TclInitPrefixCmd(interp); + TclInitProcessCmd(interp); /* * Register "clock" subcommands. These *do* go through @@ -866,7 +877,9 @@ Tcl_CreateInterp(void) */ Tcl_CreateObjCommand(interp, "::tcl::unsupported::disassemble", - Tcl_DisassembleObjCmd, NULL, NULL); + Tcl_DisassembleObjCmd, INT2PTR(0), NULL); + Tcl_CreateObjCommand(interp, "::tcl::unsupported::getbytecode", + Tcl_DisassembleObjCmd, INT2PTR(1), NULL); Tcl_CreateObjCommand(interp, "::tcl::unsupported::representation", Tcl_RepresentationCmd, NULL, NULL); @@ -947,6 +960,13 @@ Tcl_CreateInterp(void) TclInitEmbeddedConfigurationInformation(interp); /* + * TIP #440: Declare the name of the script engine to be "Tcl". + */ + + Tcl_SetVar2(interp, "tcl_platform", "engine", "Tcl", + TCL_GLOBAL_ONLY); + + /* * Compute the byte order of this machine. */ @@ -966,14 +986,16 @@ Tcl_CreateInterp(void) * Set up other variables such as tcl_version and tcl_library */ - Tcl_SetVar(interp, "tcl_patchLevel", TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY); - Tcl_SetVar(interp, "tcl_version", TCL_VERSION, TCL_GLOBAL_ONLY); + Tcl_SetVar2(interp, "tcl_patchLevel", NULL, TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY); + Tcl_SetVar2(interp, "tcl_version", NULL, TCL_VERSION, TCL_GLOBAL_ONLY); +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 Tcl_TraceVar2(interp, "tcl_precision", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, TclPrecTraceProc, NULL); +#endif /* !TCL_NO_DEPRECATED */ TclpSetVariables(interp); -#ifdef TCL_THREADS +#if TCL_THREADS /* * The existence of the "threaded" element of the tcl_platform array * indicates that this particular Tcl shell has been compiled with threads @@ -992,11 +1014,11 @@ Tcl_CreateInterp(void) Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs); if (TclTommath_Init(interp) != TCL_OK) { - Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); + Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp))); } if (TclOOInit(interp) != TCL_OK) { - Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); + Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp))); } /* @@ -1006,7 +1028,7 @@ Tcl_CreateInterp(void) #ifdef HAVE_ZLIB if (TclZlibInit(interp) != TCL_OK) { - Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); + Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp))); } #endif @@ -1118,6 +1140,7 @@ TclHideUnsafeCommands( Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name); } } + TclMakeEncodingCommandSafe(interp); /* Ugh! */ TclMakeFileCommandSafe(interp); /* Ugh! */ return TCL_OK; } @@ -1153,7 +1176,7 @@ Tcl_CallWhenDeleted( Interp *iPtr = (Interp *) interp; static Tcl_ThreadDataKey assocDataCounterKey; int *assocDataCounterPtr = - Tcl_GetThreadData(&assocDataCounterKey, (int)sizeof(int)); + Tcl_GetThreadData(&assocDataCounterKey, sizeof(int)); int isNew; char buffer[32 + TCL_INTEGER_SPACE]; AssocData *dPtr = ckalloc(sizeof(AssocData)); @@ -1625,10 +1648,12 @@ DeleteInterpProc( if (iPtr->returnOpts) { Tcl_DecrRefCount(iPtr->returnOpts); } +#ifndef TCL_NO_DEPRECATED if (iPtr->appendResult != NULL) { ckfree(iPtr->appendResult); iPtr->appendResult = NULL; } +#endif TclFreePackageInfo(iPtr); while (iPtr->tracePtr != NULL) { Tcl_DeleteTrace((Tcl_Interp *) iPtr, (Tcl_Trace) iPtr->tracePtr); @@ -1726,7 +1751,7 @@ DeleteInterpProc( } Tcl_DeleteHashTable(iPtr->lineLAPtr); - ckfree((char *) iPtr->lineLAPtr); + ckfree(iPtr->lineLAPtr); iPtr->lineLAPtr = NULL; if (iPtr->lineLABCPtr->numEntries && !TclInExit()) { @@ -2133,11 +2158,11 @@ Tcl_CreateCommand( { Interp *iPtr = (Interp *) interp; ImportRef *oldRefPtr = NULL; - Namespace *nsPtr, *dummy1, *dummy2; - Command *cmdPtr, *refCmdPtr; + Namespace *nsPtr; + Command *cmdPtr; Tcl_HashEntry *hPtr; const char *tail; - int isNew; + int isNew = 0, deleted = 0; ImportedCmdData *dataPtr; if (iPtr->flags & DELETED) { @@ -2150,47 +2175,79 @@ Tcl_CreateCommand( } /* - * Determine where the command should reside. If its name contains - * namespace qualifiers, we put it in the specified namespace; otherwise, - * we always put it in the global namespace. + * If the command name we seek to create already exists, we need to + * delete that first. That can be tricky in the presence of traces. + * Loop until we no longer find an existing command in the way, or + * until we've deleted one command and that didn't finish the job. */ - if (strstr(cmdName, "::") != NULL) { - TclGetNamespaceForQualName(interp, cmdName, NULL, - TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); - if ((nsPtr == NULL) || (tail == NULL)) { - return (Tcl_Command) NULL; + while (1) { + /* + * Determine where the command should reside. If its name contains + * namespace qualifiers, we put it in the specified namespace; + * otherwise, we always put it in the global namespace. + */ + + if (strstr(cmdName, "::") != NULL) { + Namespace *dummy1, *dummy2; + + TclGetNamespaceForQualName(interp, cmdName, NULL, + TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); + if ((nsPtr == NULL) || (tail == NULL)) { + return (Tcl_Command) NULL; + } + } else { + nsPtr = iPtr->globalNsPtr; + tail = cmdName; + } + + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); + + if (isNew || deleted) { + /* + * isNew - No conflict with existing command. + * deleted - We've already deleted a conflicting command + */ + break; } - } else { - nsPtr = iPtr->globalNsPtr; - tail = cmdName; - } - hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); - if (!isNew) { + /* An existing command conflicts. Try to delete it.. */ + cmdPtr = Tcl_GetHashValue(hPtr); + /* - * Command already exists. Delete the old one. Be careful to preserve + * Be careful to preserve * any existing import links so we can restore them down below. That * way, you can redefine a command and its import status will remain * intact. */ - cmdPtr = Tcl_GetHashValue(hPtr); - oldRefPtr = cmdPtr->importRefPtr; - cmdPtr->importRefPtr = NULL; + cmdPtr->refCount++; + if (cmdPtr->importRefPtr) { + cmdPtr->flags |= CMD_REDEF_IN_PROGRESS; + } Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); - hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); - if (!isNew) { - /* - * If the deletion callback recreated the command, just throw away - * the new command (if we try to delete it again, we could get - * stuck in an infinite loop). - */ - ckfree(Tcl_GetHashValue(hPtr)); + if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) { + oldRefPtr = cmdPtr->importRefPtr; + cmdPtr->importRefPtr = NULL; } - } else { + TclCleanupCommandMacro(cmdPtr); + deleted = 1; + } + + if (!isNew) { + /* + * If the deletion callback recreated the command, just throw away + * the new command (if we try to delete it again, we could get + * stuck in an infinite loop). + */ + + ckfree(Tcl_GetHashValue(hPtr)); + } + + if (!deleted) { + /* * Command resolvers (per-interp, per-namespace) might have resolved * to a command for the given namespace scope with this command not @@ -2238,7 +2295,7 @@ Tcl_CreateCommand( if (oldRefPtr != NULL) { cmdPtr->importRefPtr = oldRefPtr; while (oldRefPtr != NULL) { - refCmdPtr = oldRefPtr->importedCmdPtr; + Command *refCmdPtr = oldRefPtr->importedCmdPtr; dataPtr = refCmdPtr->objClientData; dataPtr->realCmdPtr = cmdPtr; oldRefPtr = oldRefPtr->nextPtr; @@ -2268,12 +2325,9 @@ Tcl_CreateCommand( * future calls to Tcl_GetCommandName. * * Side effects: - * If no command named "cmdName" already exists for interp, one is - * created. Otherwise, if a command does exist, then if the object-based - * Tcl_ObjCmdProc is TclInvokeStringCommand, we assume Tcl_CreateCommand - * was called previously for the same command and just set its - * Tcl_ObjCmdProc to the argument "proc"; otherwise, we delete the old - * command. + * If a command named "cmdName" already exists for interp, it is + * first deleted. Then the new command is created from the arguments. + * [***] (See below for exception). * * In the future, during bytecode evaluation when "cmdName" is seen as * the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based @@ -2296,37 +2350,34 @@ Tcl_CreateObjCommand( * name. */ ClientData clientData, /* Arbitrary value to pass to object * function. */ - Tcl_CmdDeleteProc *deleteProc) + Tcl_CmdDeleteProc *deleteProc /* If not NULL, gives a function to call when * this command is deleted. */ +) { Interp *iPtr = (Interp *) interp; - ImportRef *oldRefPtr = NULL; - Namespace *nsPtr, *dummy1, *dummy2; - Command *cmdPtr, *refCmdPtr; - Tcl_HashEntry *hPtr; + Namespace *nsPtr; const char *tail; - int isNew; - ImportedCmdData *dataPtr; if (iPtr->flags & DELETED) { /* * The interpreter is being deleted. Don't create any new commands; * it's not safe to muck with the interpreter anymore. */ - return (Tcl_Command) NULL; } /* * Determine where the command should reside. If its name contains - * namespace qualifiers, we put it in the specified namespace; otherwise, - * we always put it in the global namespace. + * namespace qualifiers, we put it in the specified namespace; + * otherwise, we always put it in the global namespace. */ if (strstr(cmdName, "::") != NULL) { + Namespace *dummy1, *dummy2; + TclGetNamespaceForQualName(interp, cmdName, NULL, - TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); + TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); if ((nsPtr == NULL) || (tail == NULL)) { return (Tcl_Command) NULL; } @@ -2335,22 +2386,69 @@ Tcl_CreateObjCommand( tail = cmdName; } - hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); - TclInvalidateNsPath(nsPtr); - if (!isNew) { + return TclCreateObjCommandInNs(interp, tail, (Tcl_Namespace *) nsPtr, + proc, clientData, deleteProc); +} + +Tcl_Command +TclCreateObjCommandInNs( + Tcl_Interp *interp, + const char *cmdName, /* Name of command, without any namespace + * components. */ + Tcl_Namespace *namespace, /* The namespace to create the command in */ + Tcl_ObjCmdProc *proc, /* Object-based function to associate with + * name. */ + ClientData clientData, /* Arbitrary value to pass to object + * function. */ + Tcl_CmdDeleteProc *deleteProc) + /* If not NULL, gives a function to call when + * this command is deleted. */ +{ + int deleted = 0, isNew = 0; + Command *cmdPtr; + ImportRef *oldRefPtr = NULL; + ImportedCmdData *dataPtr; + Tcl_HashEntry *hPtr; + Namespace *nsPtr = (Namespace *) namespace; + + /* + * If the command name we seek to create already exists, we need to delete + * that first. That can be tricky in the presence of traces. Loop until we + * no longer find an existing command in the way, or until we've deleted + * one command and that didn't finish the job. + */ + + while (1) { + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &isNew); + + if (isNew || deleted) { + /* + * isNew - No conflict with existing command. + * deleted - We've already deleted a conflicting command + */ + break; + } + + /* + * An existing command conflicts. Try to delete it. + */ + cmdPtr = Tcl_GetHashValue(hPtr); /* - * Command already exists. If its object-based Tcl_ObjCmdProc is - * TclInvokeStringCommand, we just set its Tcl_ObjCmdProc to the - * argument "proc". Otherwise, we delete the old command. + * [***] This is wrong. See Tcl Bug a16752c252. However, this buggy + * behavior is kept under particular circumstances to accommodate + * deployed binaries of the "tclcompiler" program + * http://sourceforge.net/projects/tclpro/ + * that crash if the bug is fixed. */ - if (cmdPtr->objProc == TclInvokeStringCommand) { + if (cmdPtr->objProc == TclInvokeStringCommand + && cmdPtr->clientData == clientData + && cmdPtr->deleteData == clientData + && cmdPtr->deleteProc == deleteProc) { cmdPtr->objProc = proc; cmdPtr->objClientData = clientData; - cmdPtr->deleteProc = deleteProc; - cmdPtr->deleteData = clientData; return (Tcl_Command) cmdPtr; } @@ -2361,21 +2459,40 @@ Tcl_CreateObjCommand( * intact. */ - oldRefPtr = cmdPtr->importRefPtr; - cmdPtr->importRefPtr = NULL; + cmdPtr->refCount++; + if (cmdPtr->importRefPtr) { + cmdPtr->flags |= CMD_REDEF_IN_PROGRESS; + } + + /* + * Make sure namespace doesn't get deallocated. + */ + + cmdPtr->nsPtr->refCount++; Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); - hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); - if (!isNew) { - /* - * If the deletion callback recreated the command, just throw away - * the new command (if we try to delete it again, we could get - * stuck in an infinite loop). - */ + nsPtr = (Namespace *) TclEnsureNamespace(interp, + (Tcl_Namespace *) cmdPtr->nsPtr); + TclNsDecrRefCount(cmdPtr->nsPtr); - ckfree(Tcl_GetHashValue(hPtr)); + if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) { + oldRefPtr = cmdPtr->importRefPtr; + cmdPtr->importRefPtr = NULL; } - } else { + TclCleanupCommandMacro(cmdPtr); + deleted = 1; + } + if (!isNew) { + /* + * If the deletion callback recreated the command, just throw away the + * new command (if we try to delete it again, we could get stuck in an + * infinite loop). + */ + + ckfree(Tcl_GetHashValue(hPtr)); + } + + if (!deleted) { /* * Command resolvers (per-interp, per-namespace) might have resolved * to a command for the given namespace scope with this command not @@ -2386,7 +2503,7 @@ Tcl_CreateObjCommand( * commands. */ - TclInvalidateCmdLiteral(interp, tail, nsPtr); + TclInvalidateCmdLiteral(interp, cmdName, nsPtr); /* * The list of command exported from the namespace might have changed. @@ -2395,6 +2512,7 @@ Tcl_CreateObjCommand( */ TclInvalidateNsCmdLookup(nsPtr); + TclInvalidateNsPath(nsPtr); } cmdPtr = ckalloc(sizeof(Command)); Tcl_SetHashValue(hPtr, cmdPtr); @@ -2422,7 +2540,8 @@ Tcl_CreateObjCommand( if (oldRefPtr != NULL) { cmdPtr->importRefPtr = oldRefPtr; while (oldRefPtr != NULL) { - refCmdPtr = oldRefPtr->importedCmdPtr; + Command *refCmdPtr = oldRefPtr->importedCmdPtr; + dataPtr = refCmdPtr->objClientData; dataPtr->realCmdPtr = cmdPtr; oldRefPtr = oldRefPtr->nextPtr; @@ -2474,7 +2593,7 @@ TclInvokeStringCommand( TclStackAlloc(interp, (unsigned)(objc + 1) * sizeof(char *)); for (i = 0; i < objc; i++) { - argv[i] = Tcl_GetString(objv[i]); + argv[i] = TclGetString(objv[i]); } argv[objc] = 0; @@ -2503,8 +2622,8 @@ TclInvokeStringCommand( * A standard Tcl string result value. * * Side effects: - * Besides those side effects of the called Tcl_CmdProc, - * TclInvokeStringCommand allocates and frees storage. + * Besides those side effects of the called Tcl_ObjCmdProc, + * TclInvokeObjectCommand allocates and frees storage. * *---------------------------------------------------------------------- */ @@ -2615,10 +2734,6 @@ TclRenameCommand( Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", oldName, NULL); return TCL_ERROR; } - cmdNsPtr = cmdPtr->nsPtr; - oldFullName = Tcl_NewObj(); - Tcl_IncrRefCount(oldFullName); - Tcl_GetCommandFullName(interp, cmd, oldFullName); /* * If the new command name is NULL or empty, delete the command. Do this @@ -2627,10 +2742,14 @@ TclRenameCommand( if ((newName == NULL) || (*newName == '\0')) { Tcl_DeleteCommandFromToken(interp, cmd); - result = TCL_OK; - goto done; + return TCL_OK; } + cmdNsPtr = cmdPtr->nsPtr; + oldFullName = Tcl_NewObj(); + Tcl_IncrRefCount(oldFullName); + Tcl_GetCommandFullName(interp, cmd, oldFullName); + /* * Make sure that the destination command does not already exist. The * rename operation is like creating a command, so we should automatically @@ -2728,7 +2847,7 @@ TclRenameCommand( } Tcl_DStringAppend(&newFullName, newTail, -1); cmdPtr->refCount++; - CallCommandTraces(iPtr, cmdPtr, Tcl_GetString(oldFullName), + CallCommandTraces(iPtr, cmdPtr, TclGetString(oldFullName), Tcl_DStringValue(&newFullName), TCL_TRACE_RENAME); Tcl_DStringFree(&newFullName); @@ -3095,13 +3214,6 @@ Tcl_DeleteCommandFromToken( Tcl_Command importCmd; /* - * Bump the command epoch counter. This will invalidate all cached - * references that point to this command. - */ - - cmdPtr->cmdEpoch++; - - /* * The code here is tricky. We can't delete the hash table entry before * invoking the deletion callback because there are cases where the * deletion callback needs to invoke the command (e.g. object systems such @@ -3123,13 +3235,21 @@ Tcl_DeleteCommandFromToken( Tcl_DeleteHashEntry(cmdPtr->hPtr); cmdPtr->hPtr = NULL; } + + /* + * Bump the command epoch counter. This will invalidate all cached + * references that point to this command. + */ + + cmdPtr->cmdEpoch++; + return 0; } /* * 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 + * delete procs may try to delete the command themselves. This flag * declares that a delete is in progress and that recursive deletes should * be ignored. */ @@ -3141,6 +3261,8 @@ Tcl_DeleteCommandFromToken( * traces. */ + cmdPtr->nsPtr->refCount++; + if (cmdPtr->tracePtr != NULL) { CommandTrace *tracePtr; CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE); @@ -3153,7 +3275,7 @@ Tcl_DeleteCommandFromToken( while (tracePtr != NULL) { CommandTrace *nextPtr = tracePtr->nextPtr; - if ((--tracePtr->refCount) <= 0) { + if (tracePtr->refCount-- <= 1) { ckfree(tracePtr); } tracePtr = nextPtr; @@ -3168,6 +3290,7 @@ Tcl_DeleteCommandFromToken( */ TclInvalidateNsCmdLookup(cmdPtr->nsPtr); + TclNsDecrRefCount(cmdPtr->nsPtr); /* * If the command being deleted has a compile function, increment the @@ -3206,12 +3329,13 @@ Tcl_DeleteCommandFromToken( * commands were created that refer back to this command. Delete these * imported commands now. */ - - for (refPtr = cmdPtr->importRefPtr; refPtr != NULL; - refPtr = nextRefPtr) { - nextRefPtr = refPtr->nextPtr; - importCmd = (Tcl_Command) refPtr->importedCmdPtr; - Tcl_DeleteCommandFromToken(interp, importCmd); + if (!(cmdPtr->flags & CMD_REDEF_IN_PROGRESS)) { + for (refPtr = cmdPtr->importRefPtr; refPtr != NULL; + refPtr = nextRefPtr) { + nextRefPtr = refPtr->nextPtr; + importCmd = (Tcl_Command) refPtr->importedCmdPtr; + Tcl_DeleteCommandFromToken(interp, importCmd); + } } /* @@ -3224,6 +3348,13 @@ Tcl_DeleteCommandFromToken( if (cmdPtr->hPtr != NULL) { Tcl_DeleteHashEntry(cmdPtr->hPtr); cmdPtr->hPtr = NULL; + + /* + * Bump the command epoch counter. This will invalidate all cached + * references that point to this command. + */ + + cmdPtr->cmdEpoch++; } /* @@ -3338,7 +3469,7 @@ CallCommandTraces( tracePtr->traceProc(tracePtr->clientData, (Tcl_Interp *) iPtr, oldName, newName, flags); cmdPtr->flags &= ~tracePtr->flags; - if ((--tracePtr->refCount) <= 0) { + if (tracePtr->refCount-- <= 1) { ckfree(tracePtr); } } @@ -3447,62 +3578,6 @@ CancelEvalProc( /* *---------------------------------------------------------------------- * - * GetCommandSource -- - * - * This function returns a Tcl_Obj with the full source string for the - * command. This insures that traces get a correct NUL-terminated command - * string. The Tcl_Obj has refCount==1. - * - * *** MAINTAINER WARNING *** - * The returned Tcl_Obj is all wrong for any purpose but getting the - * source string for an objc/objv command line in the stringRep (no - * stringRep if no source is available) and the corresponding substituted - * version in the List intrep. - * This means that the intRep and stringRep DO NOT COINCIDE! Using these - * Tcl_Objs normally is likely to break things. - * - *---------------------------------------------------------------------- - */ - -static Tcl_Obj * -GetCommandSource( - Interp *iPtr, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_Obj *objPtr, *obj2Ptr; - CmdFrame *cfPtr = iPtr->cmdFramePtr; - const char *command = NULL; - int numChars; - - objPtr = Tcl_NewListObj(objc, objv); - if (cfPtr && (cfPtr->numLevels == iPtr->numLevels-1)) { - switch (cfPtr->type) { - case TCL_LOCATION_EVAL: - case TCL_LOCATION_SOURCE: - command = cfPtr->cmd; - numChars = cfPtr->len; - break; - case TCL_LOCATION_BC: - case TCL_LOCATION_PREBC: - command = TclGetSrcInfoForCmd(iPtr, &numChars); - break; - } - if (command) { - obj2Ptr = Tcl_NewStringObj(command, numChars); - objPtr->bytes = obj2Ptr->bytes; - objPtr->length = numChars; - obj2Ptr->bytes = NULL; - Tcl_DecrRefCount(obj2Ptr); - } - } - Tcl_IncrRefCount(objPtr); - return objPtr; -} - -/* - *---------------------------------------------------------------------- - * * TclCleanupCommand -- * * This function frees up a Command structure unless it is still @@ -3526,8 +3601,7 @@ TclCleanupCommand( register Command *cmdPtr) /* Points to the Command structure to * be freed. */ { - cmdPtr->refCount--; - if (cmdPtr->refCount <= 0) { + if (cmdPtr->refCount-- <= 1) { ckfree(cmdPtr); } } @@ -3554,6 +3628,7 @@ TclCleanupCommand( *---------------------------------------------------------------------- */ +#if !defined(TCL_NO_DEPRECATED) void Tcl_CreateMathFunc( Tcl_Interp *interp, /* Interpreter in which function is to be @@ -3604,7 +3679,7 @@ Tcl_CreateMathFunc( static int OldMathFuncProc( - ClientData clientData, /* Ponter to OldMathFuncData describing the + ClientData clientData, /* Pointer to OldMathFuncData describing the * function being called */ Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Actual parameter count */ @@ -3649,7 +3724,7 @@ OldMathFuncProc( Tcl_SetObjResult(interp, Tcl_NewStringObj( "argument to math function didn't have numeric value", -1)); - TclCheckBadOctal(interp, Tcl_GetString(valuePtr)); + TclCheckBadOctal(interp, TclGetString(valuePtr)); ckfree(args); return TCL_ERROR; } @@ -3669,7 +3744,7 @@ OldMathFuncProc( args[k].type = TCL_INT; break; } - if (Tcl_GetWideIntFromObj(interp, valuePtr, &args[k].wideValue) + if (TclGetWideIntFromObj(interp, valuePtr, &args[k].wideValue) == TCL_OK) { args[k].type = TCL_WIDE_INT; break; @@ -3695,7 +3770,7 @@ OldMathFuncProc( return TCL_ERROR; } valuePtr = Tcl_GetObjResult(interp); - Tcl_GetWideIntFromObj(NULL, valuePtr, &args[k].wideValue); + TclGetWideIntFromObj(NULL, valuePtr, &args[k].wideValue); Tcl_ResetResult(interp); break; } @@ -3717,7 +3792,7 @@ OldMathFuncProc( */ if (funcResult.type == TCL_INT) { - TclNewLongObj(valuePtr, funcResult.intValue); + TclNewIntObj(valuePtr, funcResult.intValue); } else if (funcResult.type == TCL_WIDE_INT) { valuePtr = Tcl_NewWideIntObj(funcResult.wideValue); } else { @@ -3885,6 +3960,7 @@ Tcl_ListMathFuncs( return result; } +#endif /* !defined(TCL_NO_DEPRECATED) */ /* *---------------------------------------------------------------------- @@ -4069,7 +4145,7 @@ Tcl_Canceled( */ if (iPtr->asyncCancelMsg != NULL) { - message = Tcl_GetStringFromObj(iPtr->asyncCancelMsg, &length); + message = TclGetStringFromObj(iPtr->asyncCancelMsg, &length); } else { length = 0; } @@ -4168,7 +4244,7 @@ Tcl_CancelEval( */ if (resultObjPtr != NULL) { - result = Tcl_GetStringFromObj(resultObjPtr, &cancelInfo->length); + result = TclGetStringFromObj(resultObjPtr, &cancelInfo->length); cancelInfo->result = ckrealloc(cancelInfo->result,cancelInfo->length); memcpy(cancelInfo->result, result, (size_t) cancelInfo->length); TclDecrRefCount(resultObjPtr); /* Discard their result object. */ @@ -4263,42 +4339,39 @@ TclNREvalObjv( * requested Command struct to be invoked. */ { Interp *iPtr = (Interp *) interp; - int result; - Namespace *lookupNsPtr = iPtr->lookupNsPtr; - Command **cmdPtrPtr; - NRE_callback *callbackPtr; - - iPtr->lookupNsPtr = NULL; /* - * Push a callback with cleanup tasks for commands; the cmdPtr at data[0] - * will be filled later when the command is found: save its address at - * objProcPtr. - * * data[1] stores a marker for use by tailcalls; it will be set to 1 by - * command redirectors (imports, alias, ensembles) so that tailcalls - * finishes the source command and not just the target. + * command redirectors (imports, alias, ensembles) so that tailcall skips + * this callback (that marks the end of the target command) and goes back + * to the end of the source command. */ if (iPtr->deferredCallbacks) { - callbackPtr = iPtr->deferredCallbacks; iPtr->deferredCallbacks = NULL; } else { TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL); - callbackPtr = TOP_CB(interp); } - cmdPtrPtr = (Command **) &(callbackPtr->data[0]); iPtr->numLevels++; - result = TclInterpReady(interp); - - if ((result != TCL_OK) || (objc == 0)) { - return result; - } + TclNRAddCallback(interp, EvalObjvCore, cmdPtr, INT2PTR(flags), + INT2PTR(objc), objv); + return TCL_OK; +} - if (cmdPtr) { - goto commandFound; - } +static int +EvalObjvCore( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Command *cmdPtr = NULL, *preCmdPtr = data[0]; + int flags = PTR2INT(data[1]); + int objc = PTR2INT(data[2]); + Tcl_Obj **objv = data[3]; + Interp *iPtr = (Interp *) interp; + Namespace *lookupNsPtr = NULL; + int enterTracesDone = 0; /* * Push records for task to be done on return, in INVERSE order. First, if @@ -4309,61 +4382,150 @@ TclNREvalObjv( TEOV_PushExceptionHandlers(interp, objc, objv, flags); } + if (TCL_OK != TclInterpReady(interp)) { + return TCL_ERROR; + } + + if (objc == 0) { + return TCL_OK; + } + + if (TclLimitExceeded(iPtr->limit)) { + return TCL_ERROR; + } + /* * Configure evaluation context to match the requested flags. */ - if ((flags & TCL_EVAL_INVOKE) || lookupNsPtr) { - if (!lookupNsPtr) { - lookupNsPtr = iPtr->globalNsPtr; - } + if (iPtr->lookupNsPtr) { + + /* + * Capture the namespace we should do command name resolution in, as + * instructed by our caller sneaking it in to us in a private interp + * field. Clear that field right away so we cannot possibly have its + * use leak where it should not. The sneaky message pass is done. + * + * Use of this mechanism overrides the TCL_EVAL_GLOBAL flag. + * TODO: Is that a bug? + */ + + lookupNsPtr = iPtr->lookupNsPtr; + iPtr->lookupNsPtr = NULL; + } else if (flags & TCL_EVAL_INVOKE) { + lookupNsPtr = iPtr->globalNsPtr; } else { - if (flags & TCL_EVAL_GLOBAL) { - TEOV_SwitchVarFrame(interp); - lookupNsPtr = iPtr->globalNsPtr; - } /* * TCL_EVAL_INVOKE was not set: clear rewrite rules */ - iPtr->ensembleRewrite.sourceObjs = NULL; + TclResetRewriteEnsemble(interp, 1); + + if (flags & TCL_EVAL_GLOBAL) { + TEOV_SwitchVarFrame(interp); + lookupNsPtr = iPtr->globalNsPtr; + } } /* - * Lookup the command + * Lookup the Command to dispatch. */ - cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); - if (!cmdPtr) { - return TEOV_NotFound(interp, objc, objv, lookupNsPtr); + reresolve: + assert(cmdPtr == NULL); + if (preCmdPtr) { + /* Caller gave it to us */ + if (!(preCmdPtr->flags & CMD_IS_DELETED)) { + /* So long as it exists, use it. */ + cmdPtr = preCmdPtr; + } else if (flags & TCL_EVAL_NORESOLVE) { + /* + * When it's been deleted, and we're told not to attempt + * resolving it ourselves, all we can do is raise an error. + */ + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "attempt to invoke a deleted command")); + Tcl_SetErrorCode(interp, "TCL", "EVAL", "DELETEDCOMMAND", NULL); + return TCL_ERROR; + } } - - iPtr->cmdCount++; - if (TclLimitExceeded(iPtr->limit)) { - return TCL_ERROR; + if (cmdPtr == NULL) { + cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); + if (!cmdPtr) { + return TEOV_NotFound(interp, objc, objv, lookupNsPtr); + } } - /* - * Found a command! The real work begins now ... - */ + if (enterTracesDone || iPtr->tracePtr + || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { + + Tcl_Obj *commandPtr = TclGetSourceFromFrame( + flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL, + objc, objv); + Tcl_IncrRefCount(commandPtr); + + if (!enterTracesDone) { + + int code = TEOV_RunEnterTraces(interp, &cmdPtr, commandPtr, + objc, objv); + + /* + * Send any exception from enter traces back as an exception + * raised by the traced command. + * TODO: Is this a bug? Letting an execution trace BREAK or + * CONTINUE or RETURN in the place of the traced command? + * Would either converting all exceptions to TCL_ERROR, or + * just swallowing them be better? (Swallowing them has the + * problem of permanently hiding program errors.) + */ + + if (code != TCL_OK) { + Tcl_DecrRefCount(commandPtr); + return code; + } + + /* + * If the enter traces made the resolved cmdPtr unusable, go + * back and resolve again, but next time don't run enter + * traces again. + */ + + if (cmdPtr == NULL) { + enterTracesDone = 1; + Tcl_DecrRefCount(commandPtr); + goto reresolve; + } + } - commandFound: - if (iPtr->tracePtr || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { /* - * Call enter traces. They will schedule a call to the leave traces if - * necessary. + * Schedule leave traces. Raise the refCount on the resolved + * cmdPtr, so that when it passes to the leave traces we know + * it's still valid. */ - result = TEOV_RunEnterTraces(interp, &cmdPtr, objc, objv, lookupNsPtr); - if (!cmdPtr) { - return TEOV_NotFound(interp, objc, objv, lookupNsPtr); - } - if (result != TCL_OK) { - return result; - } + cmdPtr->refCount++; + TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc), + commandPtr, cmdPtr, objv); } + TclNRAddCallback(interp, Dispatch, + cmdPtr->nreProc ? cmdPtr->nreProc : cmdPtr->objProc, + cmdPtr->objClientData, INT2PTR(objc), objv); + return TCL_OK; +} + +static int +Dispatch( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_ObjCmdProc *objProc = data[0]; + ClientData clientData = data[1]; + int objc = PTR2INT(data[2]); + Tcl_Obj **objv = data[3]; + Interp *iPtr = (Interp *) interp; #ifdef USE_DTRACE if (TCL_DTRACE_CMD_ARGS_ENABLED()) { @@ -4384,34 +4546,18 @@ TclNREvalObjv( TCL_DTRACE_CMD_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]); TclDecrRefCount(info); } - if (TCL_DTRACE_CMD_RETURN_ENABLED() || TCL_DTRACE_CMD_RESULT_ENABLED()) { + if ((TCL_DTRACE_CMD_RETURN_ENABLED() || TCL_DTRACE_CMD_RESULT_ENABLED()) + && objc) { TclNRAddCallback(interp, DTraceCmdReturn, objv[0], NULL, NULL, NULL); } - if (TCL_DTRACE_CMD_ENTRY_ENABLED()) { + if (TCL_DTRACE_CMD_ENTRY_ENABLED() && objc) { TCL_DTRACE_CMD_ENTRY(TclGetString(objv[0]), objc - 1, (Tcl_Obj **)(objv + 1)); } #endif /* USE_DTRACE */ - /* - * Fix the original callback to point to the now known cmdPtr. Insure that - * the Command struct lives until the command returns. - */ - - *cmdPtrPtr = cmdPtr; - cmdPtr->refCount++; - /* - * Find the objProc to call: nreProc if available, objProc otherwise. Push - * a callback to do the actual running. - */ - - if (cmdPtr->nreProc) { - TclNRAddCallback(interp, NRRunObjProc, cmdPtr, - INT2PTR(objc), (ClientData) objv, NULL); - return TCL_OK; - } else { - return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); - } + iPtr->cmdCount++; + return objProc(clientData, interp, objc, objv); } int @@ -4422,7 +4568,9 @@ TclNRRunCallbacks( /* All callbacks down to rootPtr not inclusive * are to be run. */ { +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 Interp *iPtr = (Interp *) interp; +#endif /* !defined(TCL_NO_DEPRECATED) */ NRE_callback *callbackPtr; Tcl_NRPostProc *procPtr; @@ -4436,9 +4584,13 @@ TclNRRunCallbacks( * are for NR function calls, and those are Tcl_Obj based. */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 if (*(iPtr->result) != 0) { (void) Tcl_GetObjResult(interp); } +#endif /* !defined(TCL_NO_DEPRECATED) */ + + /* This is the trampoline. */ while (TOP_CB(interp) != rootPtr) { callbackPtr = TOP_CB(interp); @@ -4457,18 +4609,13 @@ NRCommand( int result) { Interp *iPtr = (Interp *) interp; - Command *cmdPtr = data[0]; - /* int cmdStart = PTR2INT(data[1]); NOT USED HERE */ - if (cmdPtr) { - TclCleanupCommandMacro(cmdPtr); - } - ((Interp *)interp)->numLevels--; + iPtr->numLevels--; /* - * If there is a tailcall, schedule it + * If there is a tailcall, schedule it next */ - + if (data[1] && (data[1] != INT2PTR(1))) { TclNRAddCallback(interp, TclNRTailcallEval, data[1], NULL, NULL, NULL); } @@ -4490,22 +4637,6 @@ NRCommand( return result; } - -static int -NRRunObjProc( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - /* OPT: do not call? */ - - Command* cmdPtr = data[0]; - int objc = PTR2INT(data[1]); - Tcl_Obj **objv = data[2]; - - return cmdPtr->nreProc(cmdPtr->objClientData, interp, objc, objv); -} - /* *---------------------------------------------------------------------- @@ -4594,7 +4725,7 @@ TEOV_Exception( if (result == TCL_RETURN) { result = TclUpdateReturnInfo(iPtr); } - if ((result != TCL_ERROR) && !allowExceptions) { + if ((result != TCL_OK) && (result != TCL_ERROR) && !allowExceptions) { ProcessUnexpectedResult(interp, result); result = TCL_ERROR; } @@ -4631,7 +4762,7 @@ TEOV_Error( */ listPtr = Tcl_NewListObj(objc, objv); - cmdString = Tcl_GetStringFromObj(listPtr, &cmdLen); + cmdString = TclGetStringFromObj(listPtr, &cmdLen); Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen); Tcl_DecrRefCount(listPtr); } @@ -4769,27 +4900,21 @@ static int TEOV_RunEnterTraces( Tcl_Interp *interp, Command **cmdPtrPtr, + Tcl_Obj *commandPtr, int objc, - Tcl_Obj *const objv[], - Namespace *lookupNsPtr) + Tcl_Obj *const objv[]) { Interp *iPtr = (Interp *) interp; Command *cmdPtr = *cmdPtrPtr; - int traceCode = TCL_OK; - int cmdEpoch = cmdPtr->cmdEpoch; - int newEpoch; - const char *command; - int length; - Tcl_Obj *commandPtr; - - commandPtr = GetCommandSource(iPtr, objc, objv); - command = Tcl_GetStringFromObj(commandPtr, &length); + unsigned int newEpoch, cmdEpoch = cmdPtr->cmdEpoch; + int length, traceCode = TCL_OK; + const char *command = TclGetStringFromObj(commandPtr, &length); /* * Call trace functions. * Execute any command or execution traces. Note that we bump up the - * command's reference count for the duration of the calling of the traces - * so that the structure doesn't go away underneath our feet. + * command's reference count for the duration of the calling of the + * traces so that the structure doesn't go away underneath our feet. */ cmdPtr->refCount++; @@ -4804,29 +4929,22 @@ TEOV_RunEnterTraces( newEpoch = cmdPtr->cmdEpoch; TclCleanupCommandMacro(cmdPtr); - /* - * If the traces modified/deleted the command or any existing traces, they - * will update the command's epoch. We need to lookup again, but do not - * run enter traces on the newly found cmdPtr. - */ - - if (cmdEpoch != newEpoch) { - cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); - *cmdPtrPtr = cmdPtr; + if (traceCode != TCL_OK) { + if (traceCode == TCL_ERROR) { + Tcl_Obj *info; + + TclNewLiteralStringObj(info, "\n (enter trace on \""); + Tcl_AppendLimitedToObj(info, command, length, 55, "..."); + Tcl_AppendToObj(info, "\")", 2); + Tcl_AppendObjToErrorInfo(interp, info); + iPtr->flags |= ERR_ALREADY_LOGGED; + } + return traceCode; } - - if (cmdPtr) { - /* - * Command was found: push a record to schedule the leave traces. - */ - - TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(traceCode), - commandPtr, cmdPtr, NULL); - cmdPtr->refCount++; - } else { - Tcl_DecrRefCount(commandPtr); + if (cmdEpoch != newEpoch) { + *cmdPtrPtr = NULL; } - return traceCode; + return TCL_OK; } static int @@ -4836,20 +4954,16 @@ TEOV_RunLeaveTraces( int result) { Interp *iPtr = (Interp *) interp; - const char *command; - int length, objc; - Tcl_Obj **objv; - int traceCode = PTR2INT(data[0]); + int traceCode = TCL_OK; + int objc = PTR2INT(data[0]); Tcl_Obj *commandPtr = data[1]; Command *cmdPtr = data[2]; - - command = Tcl_GetStringFromObj(commandPtr, &length); - if (TCL_OK != Tcl_ListObjGetElements(interp, commandPtr, &objc, &objv)) { - Tcl_Panic("Who messed with commandPtr?"); - } + Tcl_Obj **objv = data[3]; + int length; + const char *command = TclGetStringFromObj(commandPtr, &length); if (!(cmdPtr->flags & CMD_IS_DELETED)) { - if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && traceCode == TCL_OK){ + if (cmdPtr->flags & CMD_HAS_EXEC_TRACES){ traceCode = TclCheckExecutionTraces(interp, command, length, cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv); } @@ -4858,7 +4972,6 @@ TEOV_RunLeaveTraces( cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv); } } - Tcl_DecrRefCount(commandPtr); /* * As cmdPtr is set, TclNRRunCallbacks is about to reduce the numlevels. @@ -4869,8 +4982,18 @@ TEOV_RunLeaveTraces( TclCleanupCommandMacro(cmdPtr); if (traceCode != TCL_OK) { - return traceCode; + if (traceCode == TCL_ERROR) { + Tcl_Obj *info; + + TclNewLiteralStringObj(info, "\n (leave trace on \""); + Tcl_AppendLimitedToObj(info, command, length, 55, "..."); + Tcl_AppendToObj(info, "\")", 2); + Tcl_AppendObjToErrorInfo(interp, info); + iPtr->flags |= ERR_ALREADY_LOGGED; + } + result = traceCode; } + Tcl_DecrRefCount(commandPtr); return result; } @@ -4886,7 +5009,6 @@ TEOV_LookupCmdFromObj( if (lookupNsPtr) { iPtr->varFramePtr->nsPtr = lookupNsPtr; - iPtr->lookupNsPtr = NULL; } cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, namePtr); iPtr->varFramePtr->nsPtr = savedNsPtr; @@ -4927,6 +5049,7 @@ Tcl_EvalTokensStandard( NULL, NULL); } +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 /* *---------------------------------------------------------------------- * @@ -4974,6 +5097,7 @@ Tcl_EvalTokens( Tcl_ResetResult(interp); return resPtr; } +#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -5113,11 +5237,11 @@ TclEvalEx( */ eeFramePtr->level = iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level + 1 : 1; - eeFramePtr->numLevels = iPtr->numLevels; eeFramePtr->framePtr = iPtr->framePtr; eeFramePtr->nextPtr = iPtr->cmdFramePtr; eeFramePtr->nline = 0; eeFramePtr->line = NULL; + eeFramePtr->cmdObj = NULL; iPtr->cmdFramePtr = eeFramePtr; if (iPtr->evalFlags & TCL_EVAL_FILE) { @@ -5343,11 +5467,16 @@ TclEvalEx( eeFramePtr->line = lines; TclArgumentEnter(interp, objv, objectsUsed, eeFramePtr); - code = Tcl_EvalObjv(interp, objectsUsed, objv, TCL_EVAL_NOERR); + code = Tcl_EvalObjv(interp, objectsUsed, objv, + TCL_EVAL_NOERR | TCL_EVAL_SOURCE_IN_FRAME); TclArgumentRelease(interp, objv, objectsUsed); eeFramePtr->line = NULL; eeFramePtr->nline = 0; + if (eeFramePtr->cmdObj) { + Tcl_DecrRefCount(eeFramePtr->cmdObj); + eeFramePtr->cmdObj = NULL; + } if (code != TCL_OK) { goto error; @@ -5659,8 +5788,7 @@ TclArgumentRelease( } cfwPtr = Tcl_GetHashValue(hPtr); - cfwPtr->refCount--; - if (cfwPtr->refCount > 0) { + if (cfwPtr->refCount-- > 1) { continue; } @@ -5722,10 +5850,10 @@ TclArgumentBCEnter( * ensemble dispatch. Ensemble subcommands that lead to script * evaluation are not supposed to get compiled, because a command * such as [info level] in the script can expose some of the dispatch - * shenanigans. This means that we don't have to tend to the + * shenanigans. This means that we don't have to tend to the * housekeeping, and can escape now. */ - + if (ePtr->nline != objc) { return; } @@ -5925,6 +6053,7 @@ TclArgumentGet( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_Eval int Tcl_Eval( @@ -5977,6 +6106,7 @@ Tcl_GlobalEvalObj( { return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -5989,7 +6119,7 @@ Tcl_GlobalEvalObj( * * If the flag TCL_EVAL_DIRECT is passed in, the value of invoker * must be NULL. Support for non-NULL invokers in that mode has - * been removed since it was unused and untested. Failure to + * been removed since it was unused and untested. Failure to * follow this limitation will lead to an assertion panic. * * Results: @@ -6088,7 +6218,6 @@ TclNREvalObjEx( Tcl_IncrRefCount(objPtr); listPtr = TclListObjCopy(interp, objPtr); Tcl_IncrRefCount(listPtr); - TclDecrRefCount(objPtr); if (word != INT_MIN) { /* @@ -6114,21 +6243,24 @@ TclNREvalObjEx( eoFramePtr->type = TCL_LOCATION_EVAL; eoFramePtr->level = (iPtr->cmdFramePtr == NULL? 1 : iPtr->cmdFramePtr->level + 1); - eoFramePtr->numLevels = iPtr->numLevels; eoFramePtr->framePtr = iPtr->framePtr; eoFramePtr->nextPtr = iPtr->cmdFramePtr; - eoFramePtr->cmd = Tcl_GetStringFromObj(listPtr, &(eoFramePtr->len)); + eoFramePtr->cmdObj = objPtr; + eoFramePtr->cmd = NULL; + eoFramePtr->len = 0; eoFramePtr->data.eval.path = NULL; iPtr->cmdFramePtr = eoFramePtr; + + flags |= TCL_EVAL_SOURCE_IN_FRAME; } TclMarkTailcall(interp); TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr, - NULL, NULL); + objPtr, NULL); - ListObjGetElements(listPtr, objc, objv); + TclListObjGetElements(NULL, listPtr, &objc, &objv); return TclNREvalObjv(interp, objc, objv, flags, NULL); } @@ -6196,7 +6328,7 @@ TclNREvalObjEx( Tcl_IncrRefCount(objPtr); - script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + script = TclGetStringFromObj(objPtr, &numSrcBytes); result = Tcl_EvalEx(interp, script, numSrcBytes, flags); TclDecrRefCount(objPtr); @@ -6227,7 +6359,7 @@ TEOEx_ByteCodeCallback( ProcessUnexpectedResult(interp, result); result = TCL_ERROR; - script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + script = TclGetStringFromObj(objPtr, &numSrcBytes); Tcl_LogCommandInfo(interp, script, script, numSrcBytes); } @@ -6261,6 +6393,7 @@ TEOEx_ListCallback( Interp *iPtr = (Interp *) interp; Tcl_Obj *listPtr = data[0]; CmdFrame *eoFramePtr = data[1]; + Tcl_Obj *objPtr = data[2]; /* * Remove the cmdFrame @@ -6270,6 +6403,7 @@ TEOEx_ListCallback( iPtr->cmdFramePtr = eoFramePtr->nextPtr; TclStackFree(interp, eoFramePtr); } + TclDecrRefCount(objPtr); TclDecrRefCount(listPtr); return result; @@ -6482,7 +6616,6 @@ Tcl_ExprLongObj( resultPtr = Tcl_NewBignumObj(&big); /* FALLTHROUGH */ } - case TCL_NUMBER_LONG: case TCL_NUMBER_WIDE: case TCL_NUMBER_BIG: result = TclGetLongFromObj(interp, resultPtr, ptr); @@ -6593,11 +6726,7 @@ TclObjInvokeNamespace( * command. */ - result = TclPushStackFrame(interp, &framePtr, nsPtr, /*isProcFrame*/0); - if (result != TCL_OK) { - return TCL_ERROR; - } - + (void) TclPushStackFrame(interp, &framePtr, nsPtr, /*isProcFrame*/0); result = TclObjInvoke(interp, objc, objv, flags); TclPopStackFrame(interp); @@ -6632,30 +6761,32 @@ TclObjInvoke( * TCL_INVOKE_HIDDEN, TCL_INVOKE_NO_UNKNOWN, * or TCL_INVOKE_NO_TRACEBACK. */ { - register Interp *iPtr = (Interp *) interp; - Tcl_HashTable *hTblPtr; /* Table of hidden commands. */ - const char *cmdName; /* Name of the command from objv[0]. */ - Tcl_HashEntry *hPtr = NULL; - Command *cmdPtr; - int result; - if (interp == NULL) { return TCL_ERROR; } - if ((objc < 1) || (objv == NULL)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "illegal argument vector", -1)); return TCL_ERROR; } - if ((flags & TCL_INVOKE_HIDDEN) == 0) { Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN"); } + return Tcl_NRCallObjProc(interp, TclNRInvoke, NULL, objc, objv); +} - if (TclInterpReady(interp) == TCL_ERROR) { - return TCL_ERROR; - } +int +TclNRInvoke( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + register Interp *iPtr = (Interp *) interp; + Tcl_HashTable *hTblPtr; /* Table of hidden commands. */ + const char *cmdName; /* Name of the command from objv[0]. */ + Tcl_HashEntry *hPtr = NULL; + Command *cmdPtr; cmdName = TclGetString(objv[0]); hTblPtr = iPtr->hiddenCmdTablePtr; @@ -6671,36 +6802,27 @@ TclObjInvoke( } cmdPtr = Tcl_GetHashValue(hPtr); - /* - * Invoke the command function. - */ - - iPtr->cmdCount++; - if (cmdPtr->objProc != NULL) { - result = cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); - } else { - result = Tcl_NRCallObjProc(interp, cmdPtr->nreProc, - cmdPtr->objClientData, objc, objv); - } + /* Avoid the exception-handling brain damage when numLevels == 0 . */ + iPtr->numLevels++; + Tcl_NRAddCallback(interp, NRPostInvoke, NULL, NULL, NULL, NULL); /* - * If an error occurred, record information about what was being executed - * when the error occurred. + * Normal command resolution of objv[0] isn't going to find cmdPtr. + * That's the whole point of **hidden** commands. So tell the + * Eval core machinery not to even try (and risk finding something wrong). */ - if ((result == TCL_ERROR) - && ((flags & TCL_INVOKE_NO_TRACEBACK) == 0) - && ((iPtr->flags & ERR_ALREADY_LOGGED) == 0)) { - int length; - Tcl_Obj *command = Tcl_NewListObj(objc, objv); - const char *cmdString; + return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NORESOLVE, cmdPtr); +} - Tcl_IncrRefCount(command); - cmdString = Tcl_GetStringFromObj(command, &length); - Tcl_LogCommandInfo(interp, cmdString, cmdString, length); - Tcl_DecrRefCount(command); - iPtr->flags &= ~ERR_ALREADY_LOGGED; - } +static int +NRPostInvoke( + ClientData clientData[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *)interp; + iPtr->numLevels--; return result; } @@ -6784,11 +6906,10 @@ Tcl_AppendObjToErrorInfo( * pertains. */ Tcl_Obj *objPtr) /* Message to record. */ { - int length; - const char *message = TclGetStringFromObj(objPtr, &length); + const char *message = TclGetString(objPtr); Tcl_IncrRefCount(objPtr); - Tcl_AddObjErrorInfo(interp, message, length); + Tcl_AddObjErrorInfo(interp, message, objPtr->length); Tcl_DecrRefCount(objPtr); } @@ -6811,6 +6932,7 @@ Tcl_AppendObjToErrorInfo( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_AddErrorInfo void Tcl_AddErrorInfo( @@ -6820,6 +6942,7 @@ Tcl_AddErrorInfo( { Tcl_AddObjErrorInfo(interp, message, -1); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -6860,7 +6983,8 @@ Tcl_AddObjErrorInfo( iPtr->flags |= ERR_LEGACY_COPY; if (iPtr->errorInfo == NULL) { - if (iPtr->result[0] != 0) { +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 + if (*(iPtr->result) != 0) { /* * The interp's string result is set, apparently by some extension * making a deprecated direct write to it. That extension may @@ -6870,9 +6994,9 @@ Tcl_AddObjErrorInfo( */ iPtr->errorInfo = Tcl_NewStringObj(iPtr->result, -1); - } else { + } else +#endif /* !defined(TCL_NO_DEPRECATED) */ iPtr->errorInfo = iPtr->objResultPtr; - } Tcl_IncrRefCount(iPtr->errorInfo); if (!iPtr->errorCode) { Tcl_SetErrorCode(interp, "NONE", NULL); @@ -6935,7 +7059,7 @@ Tcl_VarEvalVA( Tcl_DStringAppend(&buf, string, -1); } - result = Tcl_Eval(interp, Tcl_DStringValue(&buf)); + result = Tcl_EvalEx(interp, Tcl_DStringValue(&buf), -1, 0); Tcl_DStringFree(&buf); return result; } @@ -6992,6 +7116,7 @@ Tcl_VarEval( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_GlobalEval int Tcl_GlobalEval( @@ -7005,10 +7130,11 @@ Tcl_GlobalEval( savedVarFramePtr = iPtr->varFramePtr; iPtr->varFramePtr = iPtr->rootFramePtr; - result = Tcl_Eval(interp, command); + result = Tcl_EvalEx(interp, command, -1, 0); iPtr->varFramePtr = savedVarFramePtr; return result; } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -7262,7 +7388,7 @@ ExprIsqrtFunc( } break; default: - if (Tcl_GetWideIntFromObj(interp, objv[1], &w) != TCL_OK) { + if (TclGetWideIntFromObj(interp, objv[1], &w) != TCL_OK) { return TCL_ERROR; } if (w < 0) { @@ -7466,12 +7592,12 @@ ExprAbsFunc( return TCL_ERROR; } - if (type == TCL_NUMBER_LONG) { - long l = *((const long *) ptr); + if (type == TCL_NUMBER_WIDE) { + Tcl_WideInt l = *((const Tcl_WideInt *) ptr); - if (l > (long)0) { + if (l > (Tcl_WideInt)0) { goto unChanged; - } else if (l == (long)0) { + } else if (l == (Tcl_WideInt)0) { const char *string = objv[1]->bytes; if (string) { while (*string != '0') { @@ -7483,11 +7609,11 @@ ExprAbsFunc( } } goto unChanged; - } else if (l == LONG_MIN) { - TclBNInitBignumFromLong(&big, l); + } else if (l == LLONG_MIN) { + TclInitBignumFromWideInt(&big, l); goto tooLarge; } - Tcl_SetObjResult(interp, Tcl_NewLongObj(-l)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-l)); return TCL_OK; } @@ -7511,24 +7637,8 @@ ExprAbsFunc( return TCL_OK; } -#ifndef TCL_WIDE_INT_IS_LONG - if (type == TCL_NUMBER_WIDE) { - Tcl_WideInt w = *((const Tcl_WideInt *) ptr); - - if (w >= (Tcl_WideInt)0) { - goto unChanged; - } - if (w == LLONG_MIN) { - TclBNInitBignumFromWideInt(&big, w); - goto tooLarge; - } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-w)); - return TCL_OK; - } -#endif - if (type == TCL_NUMBER_BIG) { - if (mp_cmp_d((const mp_int *) ptr, 0) == MP_LT) { + if (mp_isneg((const mp_int *) ptr)) { Tcl_GetBignumFromObj(NULL, objv[1], &big); tooLarge: mp_neg(&big, &big); @@ -7624,7 +7734,7 @@ ExprEntierFunc( if (type == TCL_NUMBER_DOUBLE) { d = *((const double *) ptr); - if ((d >= (double)LONG_MAX) || (d <= (double)LONG_MIN)) { + if ((d >= (double)LLONG_MAX) || (d <= (double)LLONG_MIN)) { mp_int big; if (Tcl_InitBignumFromDouble(interp, d, &big) != TCL_OK) { @@ -7634,9 +7744,9 @@ ExprEntierFunc( Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); return TCL_OK; } else { - long result = (long) d; + Tcl_WideInt result = (Tcl_WideInt) d; - Tcl_SetObjResult(interp, Tcl_NewLongObj(result)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result)); return TCL_OK; } } @@ -7705,7 +7815,7 @@ ExprWideFunc( return TCL_ERROR; } objPtr = Tcl_GetObjResult(interp); - if (Tcl_GetWideIntFromObj(NULL, objPtr, &wResult) != TCL_OK) { + if (TclGetWideIntFromObj(NULL, objPtr, &wResult) != TCL_OK) { /* * Truncate the bignum; keep only bits in wide int range. */ @@ -7716,13 +7826,78 @@ ExprWideFunc( mp_mod_2d(&big, (int) CHAR_BIT * sizeof(Tcl_WideInt), &big); objPtr = Tcl_NewBignumObj(&big); Tcl_IncrRefCount(objPtr); - Tcl_GetWideIntFromObj(NULL, objPtr, &wResult); + TclGetWideIntFromObj(NULL, objPtr, &wResult); Tcl_DecrRefCount(objPtr); } Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wResult)); return TCL_OK; } +/* + * Common implmentation of max() and min(). + */ +static int +ExprMaxMinFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv, /* Actual parameter vector. */ + int op) /* Comparison direction */ +{ + Tcl_Obj *res; + double d; + int type, i; + ClientData ptr; + + if (objc < 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + res = objv[1]; + for (i = 1; i < objc; i++) { + if (TclGetNumberFromObj(interp, objv[i], &ptr, &type) != TCL_OK) { + return TCL_ERROR; + } + if (type == TCL_NUMBER_NAN) { + /* + * Get the error message for NaN. + */ + + Tcl_GetDoubleFromObj(interp, objv[i], &d); + return TCL_ERROR; + } + if (TclCompareTwoNumbers(objv[i], res) == op) { + res = objv[i]; + } + } + + Tcl_SetObjResult(interp, res); + return TCL_OK; +} + +static int +ExprMaxFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Actual parameter vector. */ +{ + return ExprMaxMinFunc(clientData, interp, objc, objv, MP_GT); +} + +static int +ExprMinFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Actual parameter vector. */ +{ + return ExprMaxMinFunc(clientData, interp, objc, objv, MP_LT); +} + static int ExprRandFunc( ClientData clientData, /* Ignored. */ @@ -7746,8 +7921,8 @@ ExprRandFunc( iPtr->flags |= RAND_SEED_INITIALIZED; /* - * Take into consideration the thread this interp is running in order - * to insure different seeds in different threads (bug #416643) + * To ensure different seeds in different threads (bug #416643), + * take into consideration the thread this interp is running in. */ iPtr->randSeed = TclpGetClicks() + (PTR2INT(Tcl_GetCurrentThread())<<12); @@ -7972,7 +8147,7 @@ MathFuncWrongNumArgs( int found, /* Actual parameter count. */ Tcl_Obj *const *objv) /* Actual parameter vector. */ { - const char *name = Tcl_GetString(objv[0]); + const char *name = TclGetString(objv[0]); const char *tail = name + strlen(name); while (tail > name+1) { @@ -8151,39 +8326,11 @@ Tcl_NRCallObjProc( int objc, Tcl_Obj *const objv[]) { - int result = TCL_OK; NRE_callback *rootPtr = TOP_CB(interp); -#ifdef USE_DTRACE - if (TCL_DTRACE_CMD_ARGS_ENABLED()) { - const char *a[10]; - int i = 0; - - while (i < 10) { - a[i] = i < objc ? TclGetString(objv[i]) : NULL; i++; - } - TCL_DTRACE_CMD_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], - a[8], a[9]); - } - if (TCL_DTRACE_CMD_INFO_ENABLED() && ((Interp *) interp)->cmdFramePtr) { - Tcl_Obj *info = TclInfoFrame(interp, ((Interp *) interp)->cmdFramePtr); - const char *a[6]; int i[2]; - - TclDTraceInfo(info, a, i); - TCL_DTRACE_CMD_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]); - TclDecrRefCount(info); - } - if ((TCL_DTRACE_CMD_RETURN_ENABLED() || TCL_DTRACE_CMD_RESULT_ENABLED()) - && objc) { - TclNRAddCallback(interp, DTraceCmdReturn, objv[0], NULL, NULL, NULL); - } - if (TCL_DTRACE_CMD_ENTRY_ENABLED() && objc) { - TCL_DTRACE_CMD_ENTRY(TclGetString(objv[0]), objc - 1, - (Tcl_Obj **)(objv + 1)); - } -#endif /* USE_DTRACE */ - result = objProc(clientData, interp, objc, objv); - return TclNRRunCallbacks(interp, result, rootPtr); + TclNRAddCallback(interp, Dispatch, objProc, clientData, + INT2PTR(objc), objv); + return TclNRRunCallbacks(interp, TCL_OK, rootPtr); } /* @@ -8234,7 +8381,26 @@ Tcl_NRCreateCommand( * this command is deleted. */ { Command *cmdPtr = (Command *) - Tcl_CreateObjCommand(interp,cmdName,proc,clientData,deleteProc); + Tcl_CreateObjCommand(interp, cmdName, proc, clientData, + deleteProc); + + cmdPtr->nreProc = nreProc; + return (Tcl_Command) cmdPtr; +} + +Tcl_Command +TclNRCreateCommandInNs( + Tcl_Interp *interp, + const char *cmdName, + Tcl_Namespace *nsPtr, + Tcl_ObjCmdProc *proc, + Tcl_ObjCmdProc *nreProc, + ClientData clientData, + Tcl_CmdDeleteProc *deleteProc) +{ + Command *cmdPtr = (Command *) + TclCreateObjCommandInNs(interp, cmdName, nsPtr, proc, clientData, + deleteProc); cmdPtr->nreProc = nreProc; return (Tcl_Command) cmdPtr; @@ -8276,31 +8442,36 @@ Tcl_NRCmdSwap( Tcl_Obj *const objv[], int flags) { - return TclNREvalObjv(interp, objc, objv, flags, (Command *) cmd); + return TclNREvalObjv(interp, objc, objv, flags|TCL_EVAL_NOERR, + (Command *) cmd); } /***************************************************************************** - * Stuff for tailcalls + * Tailcall related code ***************************************************************************** * - * Just to show that IT CAN BE DONE! The precise semantics are not simple, - * require more thought. Possibly need a new Tcl return code to do it right? - * Questions include: - * (1) How is the objc/objv tailcall to be run? My current thinking is that - * it should essentially be - * [tailcall a b c] <=> [uplevel 1 [list a b c]] - * with two caveats - * (a) the current frame is dropped first, after running all pending - * cleanup tasks and saving its namespace - * (b) 'a' is looked up in the returning frame's namespace, but the - * command is run in the context to which we are returning - * Current implementation does this if [tailcall] is called from within - * a proc, errors otherwise. - * (2) Should a tailcall bypass [catch] in the returning frame? Current - * implementation does not (or does it? Changed, test!) - it causes an - * error. - * - * FIXME NRE! + * The steps of the tailcall dance are as follows: + * + * 1. when [tailcall] is invoked, it stores the corresponding callback in + * the current CallFrame and returns TCL_RETURN + * 2. when the CallFrame is popped, it calls TclSetTailcall to store the + * callback in the proper NRCommand callback - the spot where the command + * that pushed the CallFrame is completely cleaned up + * 3. when the NRCommand callback runs, it schedules the tailcall callback + * to run immediately after it returns + * + * One delicate point is to properly define the NRCommand where the tailcall + * will execute. There are functions whose purpose is to help define the + * precise spot: + * TclMarkTailcall: if the NEXT command to be pushed tailcalls, execution + * should continue right here + * TclSkipTailcall: if the NEXT command to be pushed tailcalls, execution + * should continue after the CURRENT command is fully returned ("skip + * the next command: we are redirecting to it, tailcalls should run + * after WE return") + * TclPushTailcallPoint: the search for a tailcalling spot cannot traverse + * this point. This is special for OO, as some of the oo constructs + * that behave like commands may not push an NRCommand callback. */ void @@ -8333,6 +8504,17 @@ TclPushTailcallPoint( TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL); ((Interp *) interp)->numLevels++; } + +/* + *---------------------------------------------------------------------- + * + * TclSetTailcall -- + * + * Splice a tailcall command in the proper spot of the NRE callback + * stack, so that it runs at the right time. + * + *---------------------------------------------------------------------- + */ void TclSetTailcall( @@ -8357,6 +8539,22 @@ TclSetTailcall( } runPtr->data[1] = listPtr; } + +/* + *---------------------------------------------------------------------- + * + * TclNRTailcallObjCmd -- + * + * Prepare the tailcall as a list and store it in the current + * varFrame. When the frame is later popped the tailcall will be spliced + * at the proper place. + * + * Results: + * The first NRCommand callback that is not marked to be skipped is + * updated so that its data[1] field contains the tailcall list. + * + *---------------------------------------------------------------------- + */ int TclNRTailcallObjCmd( @@ -8372,9 +8570,9 @@ TclNRTailcallObjCmd( return TCL_ERROR; } - if (!(iPtr->varFramePtr->isProcCallFrame & 1)) { /* or is upleveled */ + if (!(iPtr->varFramePtr->isProcCallFrame & 1)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "tailcall can only be called from a proc or lambda", -1)); + "tailcall can only be called from a proc, lambda or method", -1)); Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL); return TCL_ERROR; } @@ -8392,31 +8590,34 @@ TclNRTailcallObjCmd( /* * Create the callback to actually evaluate the tailcalled * command, then set it in the varFrame so that PopCallFrame can use it - * at the proper time. Being lazy: exploit the TclNRAddCallBack macro to - * build the callback. + * at the proper time. */ if (objc > 1) { Tcl_Obj *listPtr, *nsObjPtr; Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; - Tcl_Namespace *ns1Ptr; /* The tailcall data is in a Tcl list: the first element is the * namespace, the rest the command to be tailcalled. */ - - listPtr = Tcl_NewListObj(objc, objv); nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1); - if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr)) - || (nsPtr != ns1Ptr)) { - Tcl_Panic("Tailcall failed to find the proper namespace"); - } + listPtr = Tcl_NewListObj(objc, objv); TclListObjSetElement(interp, listPtr, 0, nsObjPtr); - + iPtr->varFramePtr->tailcallPtr = listPtr; } return TCL_RETURN; } + +/* + *---------------------------------------------------------------------- + * + * TclNRTailcallEval -- + * + * This NREcallback actually causes the tailcall to be evaluated. + * + *---------------------------------------------------------------------- + */ int TclNRTailcallEval( @@ -8430,9 +8631,9 @@ TclNRTailcallEval( int objc; Tcl_Obj **objv; - Tcl_ListObjGetElements(interp, listPtr, &objc, &objv); + Tcl_ListObjGetElements(interp, listPtr, &objc, &objv); nsObjPtr = objv[0]; - + if (result == TCL_OK) { result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); } @@ -8443,7 +8644,7 @@ TclNRTailcallEval( * a now-gone namespace: cleanup and return. */ - TailcallCleanup(data, interp, result); + Tcl_DecrRefCount(listPtr); return result; } @@ -8452,21 +8653,28 @@ TclNRTailcallEval( */ TclMarkTailcall(interp); - TclNRAddCallback(interp, TailcallCleanup, listPtr, NULL, NULL,NULL); + TclNRAddCallback(interp, TclNRReleaseValues, listPtr, NULL, NULL,NULL); iPtr->lookupNsPtr = (Namespace *) nsPtr; return TclNREvalObjv(interp, objc-1, objv+1, 0, NULL); } -static int -TailcallCleanup( +int +TclNRReleaseValues( ClientData data[], Tcl_Interp *interp, int result) { - Tcl_DecrRefCount((Tcl_Obj *) data[0]); + int i = 0; + while (i < 4) { + if (data[i]) { + Tcl_DecrRefCount((Tcl_Obj *) data[i]); + } else { + break; + } + i++; + } return result; } - void Tcl_NRAddCallback( @@ -8547,8 +8755,7 @@ TclNRYieldToObjCmd( { CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; Tcl_Obj *listPtr, *nsObjPtr; - Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; - Tcl_Namespace *ns1Ptr; + Tcl_Namespace *nsPtr = TclGetCurrentNamespace(interp); if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?"); @@ -8562,11 +8769,13 @@ TclNRYieldToObjCmd( return TCL_ERROR; } - /* - * Add the tailcall in the caller env, then just yield. - * - * This is essentially code from TclNRTailcallObjCmd - */ + if (((Namespace *) nsPtr)->flags & NS_DYING) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "yieldto called in deleted namespace", -1)); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED", + NULL); + return TCL_ERROR; + } /* * Add the tailcall in the caller env, then just yield. @@ -8575,15 +8784,9 @@ TclNRYieldToObjCmd( */ listPtr = Tcl_NewListObj(objc, objv); - nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1); - if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr)) - || (nsPtr != ns1Ptr)) { - Tcl_Panic("yieldto failed to find the proper namespace"); - } TclListObjSetElement(interp, listPtr, 0, nsObjPtr); - /* * Add the callback in the caller's env, then instruct TEBC to yield. */ @@ -8817,6 +9020,35 @@ TclNRCoroutineActivateCallback( /* *---------------------------------------------------------------------- * + * TclNREvalList -- + * + * Callback to invoke command as list, used in order to delayed + * processing of canonical list command in sane environment. + * + *---------------------------------------------------------------------- + */ + +static int +TclNREvalList( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + int objc; + Tcl_Obj **objv; + Tcl_Obj *listPtr = data[0]; + + Tcl_IncrRefCount(listPtr); + + TclMarkTailcall(interp); + TclNRAddCallback(interp, TclNRReleaseValues, listPtr, NULL, NULL,NULL); + TclListObjGetElements(NULL, listPtr, &objc, &objv); + return TclNREvalObjv(interp, objc, objv, 0, NULL); +} + +/* + *---------------------------------------------------------------------- + * * NRCoroInjectObjCmd -- * * Implementation of [::tcl::unsupported::inject] command. @@ -8868,7 +9100,8 @@ NRCoroInjectObjCmd( */ iPtr->execEnvPtr = corPtr->eePtr; - TclNREvalObjEx(interp, Tcl_NewListObj(objc-2, objv+2), 0, NULL, INT_MIN); + TclNRAddCallback(interp, TclNREvalList, Tcl_NewListObj(objc-2, objv+2), + NULL, NULL, NULL); iPtr->execEnvPtr = savedEEPtr; return TCL_OK; @@ -8886,7 +9119,7 @@ TclNRInterpCoroutine( if (!COR_IS_SUSPENDED(corPtr)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "coroutine \"%s\" is already running", - Tcl_GetString(objv[0]))); + TclGetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BUSY", NULL); return TCL_ERROR; } @@ -8947,9 +9180,9 @@ TclNRCoroutineObjCmd( { Command *cmdPtr; CoroutineData *corPtr; - const char *fullName, *procName; - Namespace *nsPtr, *altNsPtr, *cxtNsPtr; - Tcl_DString ds; + const char *procName, *simpleName; + Namespace *nsPtr, *altNsPtr, *cxtNsPtr, + *inNsPtr = (Namespace *)TclGetCurrentNamespace(interp); Namespace *lookupNsPtr = iPtr->varFramePtr->nsPtr; if (objc < 3) { @@ -8957,34 +9190,21 @@ TclNRCoroutineObjCmd( return TCL_ERROR; } - /* - * FIXME: this is copy/pasted from Tcl_ProcObjCommand. Should have - * something in tclUtil.c to find the FQ name. - */ - - fullName = TclGetString(objv[1]); - TclGetNamespaceForQualName(interp, fullName, NULL, 0, - &nsPtr, &altNsPtr, &cxtNsPtr, &procName); + procName = TclGetString(objv[1]); + TclGetNamespaceForQualName(interp, procName, inNsPtr, 0, + &nsPtr, &altNsPtr, &cxtNsPtr, &simpleName); if (nsPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create procedure \"%s\": unknown namespace", - fullName)); + procName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", NULL); return TCL_ERROR; } - if (procName == NULL) { + if (simpleName == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create procedure \"%s\": bad procedure name", - fullName)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", fullName, NULL); - return TCL_ERROR; - } - if ((nsPtr != iPtr->globalNsPtr) - && (procName != NULL) && (procName[0] == ':')) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't create procedure \"%s\" in non-global namespace with" - " name starting with \":\"", procName)); + procName)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", procName, NULL); return TCL_ERROR; } @@ -8996,16 +9216,9 @@ TclNRCoroutineObjCmd( corPtr = ckalloc(sizeof(CoroutineData)); - Tcl_DStringInit(&ds); - if (nsPtr != iPtr->globalNsPtr) { - Tcl_DStringAppend(&ds, nsPtr->fullName, -1); - TclDStringAppendLiteral(&ds, "::"); - } - Tcl_DStringAppend(&ds, procName, -1); - - cmdPtr = (Command *) Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), - /*objProc*/ NULL, TclNRInterpCoroutine, corPtr, DeleteCoroutine); - Tcl_DStringFree(&ds); + cmdPtr = (Command *) TclNRCreateCommandInNs(interp, simpleName, + (Tcl_Namespace *)nsPtr, /*objProc*/ NULL, TclNRInterpCoroutine, + corPtr, DeleteCoroutine); corPtr->cmdPtr = cmdPtr; cmdPtr->refCount++; @@ -9066,7 +9279,7 @@ TclNRCoroutineObjCmd( TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr, NULL, NULL, NULL); - /* insure that the command is looked up in the correct namespace */ + /* ensure that the command is looked up in the correct namespace */ iPtr->lookupNsPtr = lookupNsPtr; Tcl_NREvalObj(interp, Tcl_NewListObj(objc-2, objv+2), 0); iPtr->numLevels--; diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 901237b..cb5a5cb 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -87,10 +87,13 @@ static int BinaryDecodeHex(ClientData clientData, static int BinaryEncode64(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int BinaryDecodeUu(ClientData clientData, +static int BinaryDecode64(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int BinaryDecode64(ClientData clientData, +static int BinaryEncodeUu(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int BinaryDecodeUu(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -139,9 +142,9 @@ static const EnsembleImplMap binaryMap[] = { { NULL, NULL, NULL, NULL, NULL, 0 } }; static const EnsembleImplMap encodeMap[] = { - { "hex", BinaryEncodeHex, TclCompileBasic1ArgCmd, NULL, (ClientData)HexDigits, 0 }, - { "uuencode", BinaryEncode64, NULL, NULL, (ClientData)UueDigits, 0 }, - { "base64", BinaryEncode64, NULL, NULL, (ClientData)B64Digits, 0 }, + { "hex", BinaryEncodeHex, TclCompileBasic1ArgCmd, NULL, NULL, 0 }, + { "uuencode", BinaryEncodeUu, NULL, NULL, NULL, 0 }, + { "base64", BinaryEncode64, NULL, NULL, NULL, 0 }, { NULL, NULL, NULL, NULL, NULL, 0 } }; static const EnsembleImplMap decodeMap[] = { @@ -152,35 +155,108 @@ static const EnsembleImplMap decodeMap[] = { }; /* - * The following object type represents an array of bytes. An array of bytes - * is not equivalent to an internationalized string. Conceptually, a string is - * an array of 16-bit quantities organized as a sequence of properly formed - * UTF-8 characters, while a ByteArray is an array of 8-bit quantities. - * Accessor functions are provided to convert a ByteArray to a String or a - * String to a ByteArray. Two or more consecutive bytes in an array of bytes - * may look like a single UTF-8 character if the array is casually treated as - * a string. But obtaining the String from a ByteArray is guaranteed to - * produced properly formed UTF-8 sequences so that there is a one-to-one map - * between bytes and characters. - * - * Converting a ByteArray to a String proceeds by casting each byte in the - * array to a 16-bit quantity, treating that number as a Unicode character, - * and storing the UTF-8 version of that Unicode character in the String. For - * ByteArrays consisting entirely of values 1..127, the corresponding String - * representation is the same as the ByteArray representation. - * - * Converting a String to a ByteArray proceeds by getting the Unicode - * representation of each character in the String, casting it to a byte by - * truncating the upper 8 bits, and then storing the byte in the ByteArray. - * Converting from ByteArray to String and back to ByteArray is not lossy, but - * converting an arbitrary String to a ByteArray may be. + * The following object types represent an array of bytes. The intent is + * to allow arbitrary binary data to pass through Tcl as a Tcl value + * without loss or damage. Such values are useful for things like + * encoded strings or Tk images to name just two. + * + * It's strange to have two Tcl_ObjTypes in place for this task when + * one would do, so a bit of detail and history how we got to this point + * and where we might go from here. + * + * A bytearray is an ordered sequence of bytes. Each byte is an integer + * value in the range [0-255]. To be a Tcl value type, we need a way to + * encode each value in the value set as a Tcl string. The simplest + * encoding is to represent each byte value as the same codepoint value. + * A bytearray of N bytes is encoded into a Tcl string of N characters + * where the codepoint of each character is the value of corresponding byte. + * This approach creates a one-to-one map between all bytearray values + * and a subset of Tcl string values. + * + * When converting a Tcl string value to the bytearray internal rep, the + * question arises what to do with strings outside that subset? That is, + * those Tcl strings containing at least one codepoint greater than 255? + * The obviously correct answer is to raise an error! That string value + * does not represent any valid bytearray value. Full Stop. The + * setFromAnyProc signature has a completion code return value for just + * this reason, to reject invalid inputs. + * + * Unfortunately this was not the path taken by the authors of the + * original tclByteArrayType. They chose to accept all Tcl string values + * as acceptable string encodings of the bytearray values that result + * from masking away the high bits of any codepoint value at all. This + * meant that every bytearray value had multiple accepted string + * representations. + * + * The implications of this choice are truly ugly. When a Tcl value has + * a string representation, we are required to accept that as the true + * value. Bytearray values that possess a string representation cannot + * be processed as bytearrays because we cannot know which true value + * that bytearray represents. The consequence is that we drag around + * an internal rep that we cannot make any use of. This painful price + * is extracted at any point after a string rep happens to be generated + * for the value. This happens even when the troublesome codepoints + * outside the byte range never show up. This happens rather routinely + * in normal Tcl operations unless we burden the script writer with the + * cognitive burden of avoiding it. The price is also paid by callers + * of the C interface. The routine + * + * unsigned char *Tcl_GetByteArrayFromObj(objPtr, lenPtr) + * + * has a guarantee to always return a non-NULL value, but that value + * points to a byte sequence that cannot be used by the caller to + * process the Tcl value absent some sideband testing that objPtr + * is "pure". Tcl offers no public interface to perform this test, + * so callers either break encapsulation or are unavoidably buggy. Tcl + * has defined a public interface that cannot be used correctly. The + * Tcl source code itself suffers the same problem, and has been buggy, + * but progressively less so as more and more portions of the code have + * been retrofitted with the required "purity testing". The set of values + * able to pass the purity test can be increased via the introduction of + * a "canonical" flag marker, but the only way the broken interface itself + * can be discarded is to start over and define the Tcl_ObjType properly. + * Bytearrays should simply be usable as bytearrays without a kabuki + * dance of testing. + * + * The Tcl_ObjType "properByteArrayType" is (nearly) a correct + * implementation of bytearrays. Any Tcl value with the type + * properByteArrayType can have its bytearray value fetched and + * used with confidence that acting on that value is equivalent to + * acting on the true Tcl string value. This still implies a side + * testing burden -- past mistakes will not let us avoid that + * immediately, but it is at least a conventional test of type, and + * can be implemented entirely by examining the objPtr fields, with + * no need to query the intrep, as a canonical flag would require. + * + * Until Tcl_GetByteArrayFromObj() and Tcl_SetByteArrayLength() can + * be revised to admit the possibility of returning NULL when the true + * value is not a valid bytearray, we need a mechanism to retain + * compatibility with the deployed callers of the broken interface. + * That's what the retained "tclByteArrayType" provides. In those + * unusual circumstances where we convert an invalid bytearray value + * to a bytearray type, it is to this legacy type. Essentially any + * time this legacy type gets used, it's a signal of a bug being ignored. + * A TIP should be drafted to remove this connection to the broken past + * so that Tcl 9 will no longer have any trace of it. Prescribing a + * migration path will be the key element of that work. The internal + * changes now in place are the limit of what can be done short of + * interface repair. They provide a great expansion of the histories + * over which bytearray values can be useful in the meanwhile. */ -const Tcl_ObjType tclByteArrayType = { +static const Tcl_ObjType properByteArrayType = { "bytearray", FreeByteArrayInternalRep, DupByteArrayInternalRep, UpdateStringOfByteArray, + NULL +}; + +const Tcl_ObjType tclByteArrayType = { + "bytearray", + FreeByteArrayInternalRep, + DupByteArrayInternalRep, + NULL, SetByteArrayFromAny }; @@ -208,6 +284,12 @@ typedef struct ByteArray { #define SET_BYTEARRAY(objPtr, baPtr) \ (objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (baPtr) +int +TclIsPureByteArray( + Tcl_Obj * objPtr) +{ + return (objPtr->typePtr == &properByteArrayType); +} /* *---------------------------------------------------------------------- @@ -338,7 +420,7 @@ Tcl_SetByteArrayObj( if ((bytes != NULL) && (length > 0)) { memcpy(byteArrayPtr->bytes, bytes, (size_t) length); } - objPtr->typePtr = &tclByteArrayType; + objPtr->typePtr = &properByteArrayType; SET_BYTEARRAY(objPtr, byteArrayPtr); } @@ -368,7 +450,8 @@ Tcl_GetByteArrayFromObj( { ByteArray *baPtr; - if (objPtr->typePtr != &tclByteArrayType) { + if ((objPtr->typePtr != &properByteArrayType) + && (objPtr->typePtr != &tclByteArrayType)) { SetByteArrayFromAny(NULL, objPtr); } baPtr = GET_BYTEARRAY(objPtr); @@ -411,7 +494,8 @@ Tcl_SetByteArrayLength( if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayLength"); } - if (objPtr->typePtr != &tclByteArrayType) { + if ((objPtr->typePtr != &properByteArrayType) + && (objPtr->typePtr != &tclByteArrayType)) { SetByteArrayFromAny(NULL, objPtr); } @@ -447,29 +531,37 @@ SetByteArrayFromAny( Tcl_Interp *interp, /* Not used. */ Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */ { - int length; + size_t length; + int improper = 0; const char *src, *srcEnd; unsigned char *dst; ByteArray *byteArrayPtr; - Tcl_UniChar ch; + Tcl_UniChar ch = 0; - if (objPtr->typePtr != &tclByteArrayType) { - src = TclGetStringFromObj(objPtr, &length); - srcEnd = src + length; - - byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); - for (dst = byteArrayPtr->bytes; src < srcEnd; ) { - src += Tcl_UtfToUniChar(src, &ch); - *dst++ = UCHAR(ch); - } + if (objPtr->typePtr == &properByteArrayType) { + return TCL_OK; + } + if (objPtr->typePtr == &tclByteArrayType) { + return TCL_OK; + } - byteArrayPtr->used = dst - byteArrayPtr->bytes; - byteArrayPtr->allocated = length; + src = TclGetString(objPtr); + length = objPtr->length; + srcEnd = src + length; - TclFreeIntRep(objPtr); - objPtr->typePtr = &tclByteArrayType; - SET_BYTEARRAY(objPtr, byteArrayPtr); + byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); + for (dst = byteArrayPtr->bytes; src < srcEnd; ) { + src += TclUtfToUniChar(src, &ch); + improper = improper || (ch > 255); + *dst++ = UCHAR(ch); } + + byteArrayPtr->used = dst - byteArrayPtr->bytes; + byteArrayPtr->allocated = length; + + TclFreeIntRep(objPtr); + objPtr->typePtr = improper ? &tclByteArrayType : &properByteArrayType; + SET_BYTEARRAY(objPtr, byteArrayPtr); return TCL_OK; } @@ -532,7 +624,7 @@ DupByteArrayInternalRep( memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, (size_t) length); SET_BYTEARRAY(copyPtr, copyArrayPtr); - copyPtr->typePtr = &tclByteArrayType; + copyPtr->typePtr = srcPtr->typePtr; } /* @@ -607,9 +699,7 @@ UpdateStringOfByteArray( * * This function appends an array of bytes to a byte array object. Note * that the object *must* be unshared, and the array of bytes *must not* - * refer to the object being appended to. Also the caller must have - * already checked that the final length of the bytearray after the - * append operations is complete will not overflow the int range. + * refer to the object being appended to. * * Results: * None. @@ -628,6 +718,7 @@ TclAppendBytesToByteArray( int len) { ByteArray *byteArrayPtr; + int needed; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object","TclAppendBytesToByteArray"); @@ -636,64 +727,58 @@ TclAppendBytesToByteArray( Tcl_Panic("%s must be called with definite number of bytes to append", "TclAppendBytesToByteArray"); } - if (objPtr->typePtr != &tclByteArrayType) { + if (len == 0) { + /* Append zero bytes is a no-op. */ + return; + } + if ((objPtr->typePtr != &properByteArrayType) + && (objPtr->typePtr != &tclByteArrayType)) { SetByteArrayFromAny(NULL, objPtr); } byteArrayPtr = GET_BYTEARRAY(objPtr); + if (len > INT_MAX - byteArrayPtr->used) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } + + needed = byteArrayPtr->used + len; /* * If we need to, resize the allocated space in the byte array. */ - if (byteArrayPtr->used + len > byteArrayPtr->allocated) { - unsigned int attempt, used = byteArrayPtr->used; - ByteArray *tmpByteArrayPtr = NULL; + if (needed > byteArrayPtr->allocated) { + ByteArray *ptr = NULL; + int attempt; - attempt = byteArrayPtr->allocated; - if (attempt < 1) { - /* - * No allocated bytes, so must be none used too. We use this - * method to calculate how many bytes to allocate because we can - * end up with a zero-length buffer otherwise, when doubling can - * cause trouble. [Bug 3067036] - */ - - attempt = len + 1; - } else { - do { - attempt *= 2; - } while (attempt < used+len); + if (needed <= INT_MAX/2) { + /* Try to allocate double the total space that is needed. */ + attempt = 2 * needed; + ptr = attemptckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); } - - if (BYTEARRAY_SIZE(attempt) > BYTEARRAY_SIZE(used)) { - tmpByteArrayPtr = attemptckrealloc(byteArrayPtr, - BYTEARRAY_SIZE(attempt)); + if (ptr == NULL) { + /* Try to allocate double the increment that is needed (plus). */ + unsigned int limit = INT_MAX - needed; + unsigned int extra = len + TCL_MIN_GROWTH; + int growth = (int) ((extra > limit) ? limit : extra); + + attempt = needed + growth; + ptr = attemptckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); } - - if (tmpByteArrayPtr == NULL) { - attempt = used + len; - if (BYTEARRAY_SIZE(attempt) < BYTEARRAY_SIZE(used)) { - Tcl_Panic("attempt to allocate a bigger buffer than we can handle"); - } - tmpByteArrayPtr = ckrealloc(byteArrayPtr, - BYTEARRAY_SIZE(attempt)); + if (ptr == NULL) { + /* Last chance: Try to allocate exactly what is needed. */ + attempt = needed; + ptr = ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); } - - byteArrayPtr = tmpByteArrayPtr; + byteArrayPtr = ptr; byteArrayPtr->allocated = attempt; - byteArrayPtr->used = used; SET_BYTEARRAY(objPtr, byteArrayPtr); } - /* - * Do the append if there's any point. - */ - - if (len > 0) { + if (bytes) { memcpy(byteArrayPtr->bytes + byteArrayPtr->used, bytes, len); - byteArrayPtr->used += len; - TclInvalidateStringRep(objPtr); } + byteArrayPtr->used += len; + TclInvalidateStringRep(objPtr); } /* @@ -1215,10 +1300,10 @@ BinaryFormatCmd( badField: { - Tcl_UniChar ch; + Tcl_UniChar ch = 0; char buf[TCL_UTF_MAX + 1]; - Tcl_UtfToUniChar(errorString, &ch); + TclUtfToUniChar(errorString, &ch); buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad field specifier \"%s\"", buf)); @@ -1585,10 +1670,10 @@ BinaryScanCmd( badField: { - Tcl_UniChar ch; + Tcl_UniChar ch = 0; char buf[TCL_UTF_MAX + 1]; - Tcl_UtfToUniChar(errorString, &ch); + TclUtfToUniChar(errorString, &ch); buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad field specifier \"%s\"", buf)); @@ -1658,7 +1743,15 @@ GetFormatSpec( (*formatPtr)++; *countPtr = BINARY_ALL; } else if (isdigit(UCHAR(**formatPtr))) { /* INTL: digit */ - *countPtr = strtoul(*formatPtr, (char **) formatPtr, 10); + unsigned long int count; + + errno = 0; + count = strtoul(*formatPtr, (char **) formatPtr, 10); + if (errno || (count > (unsigned long) INT_MAX)) { + *countPtr = INT_MAX; + } else { + *countPtr = (int) count; + } } else { *countPtr = BINARY_NOCOUNT; } @@ -2191,7 +2284,7 @@ ScanNumber( Tcl_Obj *bigObj = NULL; mp_int big; - TclBNInitBignumFromWideUInt(&big, uwvalue); + TclInitBignumFromWideUInt(&big, uwvalue); bigObj = Tcl_NewBignumObj(&big); return bigObj; } @@ -2312,7 +2405,6 @@ BinaryEncodeHex( Tcl_Obj *resultObj = NULL; unsigned char *data = NULL; unsigned char *cursor = NULL; - const char *digits = clientData; int offset = 0, count = 0; if (objc != 2) { @@ -2324,8 +2416,8 @@ BinaryEncodeHex( data = Tcl_GetByteArrayFromObj(objv[1], &count); cursor = Tcl_SetByteArrayLength(resultObj, count * 2); for (offset = 0; offset < count; ++offset) { - *cursor++ = digits[((data[offset] >> 4) & 0x0f)]; - *cursor++ = digits[(data[offset] & 0x0f)]; + *cursor++ = HexDigits[((data[offset] >> 4) & 0x0f)]; + *cursor++ = HexDigits[(data[offset] & 0x0f)]; } Tcl_SetObjResult(interp, resultObj); return TCL_OK; @@ -2386,29 +2478,32 @@ BinaryDecodeHex( while (data < dataend) { value = 0; for (i=0 ; i<2 ; i++) { - if (data < dataend) { - c = *data++; - - if (!isxdigit((int) c)) { - if (strict || !isspace(c)) { - goto badChar; - } - i--; - continue; - } + if (data >= dataend) { value <<= 4; - c -= '0'; - if (c > 9) { - c += ('0' - 'A') + 10; - } - if (c > 16) { - c += ('A' - 'a'); + break; + } + + c = *data++; + if (!isxdigit((int) c)) { + if (strict || !isspace(c)) { + goto badChar; } - value |= (c & 0xf); - } else { - value <<= 4; - cut++; + i--; + continue; + } + + value <<= 4; + c -= '0'; + if (c > 9) { + c += ('0' - 'A') + 10; } + if (c > 16) { + c += ('A' - 'a'); + } + value |= (c & 0xf); + } + if (i < 2) { + cut++; } *cursor++ = UCHAR(value); value = 0; @@ -2436,7 +2531,7 @@ BinaryDecodeHex( * This implements a generic 6 bit binary encoding. Input is broken into * 6 bit chunks and a lookup table passed in via clientData is used to * turn these values into output characters. This is used to implement - * base64 and uuencode binary encodings. + * base64 binary encodings. * * Results: * Interp result set to an encoded byte array object @@ -2472,7 +2567,6 @@ BinaryEncode64( { Tcl_Obj *resultObj; unsigned char *data, *cursor, *limit; - const char *digits = clientData; int maxlen = 0; const char *wrapchar = "\n"; int wrapcharlen = 1; @@ -2495,9 +2589,16 @@ BinaryEncode64( if (Tcl_GetIntFromObj(interp, objv[i+1], &maxlen) != TCL_OK) { return TCL_ERROR; } + if (maxlen < 0) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "line length out of range", -1)); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", + "LINE_LENGTH", NULL); + return TCL_ERROR; + } break; case OPT_WRAPCHAR: - wrapchar = Tcl_GetStringFromObj(objv[i+1], &wrapcharlen); + wrapchar = TclGetStringFromObj(objv[i+1], &wrapcharlen); if (wrapcharlen == 0) { maxlen = 0; } @@ -2525,17 +2626,17 @@ BinaryEncode64( for (i = 0; i < 3 && offset+i < count; ++i) { d[i] = data[offset + i]; } - OUTPUT(digits[d[0] >> 2]); - OUTPUT(digits[((d[0] & 0x03) << 4) | (d[1] >> 4)]); + OUTPUT(B64Digits[d[0] >> 2]); + OUTPUT(B64Digits[((d[0] & 0x03) << 4) | (d[1] >> 4)]); if (offset+1 < count) { - OUTPUT(digits[((d[1] & 0x0f) << 2) | (d[2] >> 6)]); + OUTPUT(B64Digits[((d[1] & 0x0f) << 2) | (d[2] >> 6)]); } else { - OUTPUT(digits[64]); + OUTPUT(B64Digits[64]); } if (offset+2 < count) { - OUTPUT(digits[d[2] & 0x3f]); + OUTPUT(B64Digits[d[2] & 0x3f]); } else { - OUTPUT(digits[64]); + OUTPUT(B64Digits[64]); } } } @@ -2547,6 +2648,125 @@ BinaryEncode64( /* *---------------------------------------------------------------------- * + * BinaryEncodeUu -- + * + * This implements the uuencode binary encoding. Input is broken into 6 + * bit chunks and a lookup table is used to turn these values into output + * characters. This differs from the generic code above in that line + * lengths are also encoded. + * + * Results: + * Interp result set to an encoded byte array object + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +static int +BinaryEncodeUu( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *resultObj; + unsigned char *data, *start, *cursor; + int offset, count, rawLength, n, i, j, bits, index; + int lineLength = 61; + const unsigned char SingleNewline[] = { (unsigned char) '\n' }; + const unsigned char *wrapchar = SingleNewline; + int wrapcharlen = sizeof(SingleNewline); + enum { OPT_MAXLEN, OPT_WRAPCHAR }; + static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL }; + + if (objc < 2 || objc%2 != 0) { + Tcl_WrongNumArgs(interp, 1, objv, + "?-maxlen len? ?-wrapchar char? data"); + return TCL_ERROR; + } + for (i = 1; i < objc-1; i += 2) { + if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option", + TCL_EXACT, &index) != TCL_OK) { + return TCL_ERROR; + } + switch (index) { + case OPT_MAXLEN: + if (Tcl_GetIntFromObj(interp, objv[i+1], &lineLength) != TCL_OK) { + return TCL_ERROR; + } + if (lineLength < 3 || lineLength > 85) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "line length out of range", -1)); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", + "LINE_LENGTH", NULL); + return TCL_ERROR; + } + break; + case OPT_WRAPCHAR: + wrapchar = Tcl_GetByteArrayFromObj(objv[i+1], &wrapcharlen); + break; + } + } + + /* + * Allocate the buffer. This is a little bit too long, but is "good + * enough". + */ + + resultObj = Tcl_NewObj(); + offset = 0; + data = Tcl_GetByteArrayFromObj(objv[objc-1], &count); + rawLength = (lineLength - 1) * 3 / 4; + start = cursor = Tcl_SetByteArrayLength(resultObj, + (lineLength + wrapcharlen) * + ((count + (rawLength - 1)) / rawLength)); + n = bits = 0; + + /* + * Encode the data. Each output line first has the length of raw data + * encoded by the output line described in it by one encoded byte, then + * the encoded data follows (encoding each 6 bits as one character). + * Encoded lines are always terminated by a newline. + */ + + while (offset < count) { + int lineLen = count - offset; + + if (lineLen > rawLength) { + lineLen = rawLength; + } + *cursor++ = UueDigits[lineLen]; + for (i=0 ; i<lineLen ; i++) { + n <<= 8; + n |= data[offset++]; + for (bits += 8; bits > 6 ; bits -= 6) { + *cursor++ = UueDigits[(n >> (bits-6)) & 0x3f]; + } + } + if (bits > 0) { + n <<= 8; + *cursor++ = UueDigits[(n >> (bits + 2)) & 0x3f]; + bits = 0; + } + for (j=0 ; j<wrapcharlen ; ++j) { + *cursor++ = wrapchar[j]; + } + } + + /* + * Fix the length of the output bytearray. + */ + + Tcl_SetByteArrayLength(resultObj, cursor-start); + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * BinaryDecodeUu -- * * Decode a uuencoded string. @@ -2570,8 +2790,8 @@ BinaryDecodeUu( Tcl_Obj *resultObj = NULL; unsigned char *data, *datastart, *dataend; unsigned char *begin, *cursor; - int i, index, size, count = 0, cut = 0, strict = 0; - char c; + int i, index, size, count = 0, strict = 0, lineLen; + unsigned char c; enum {OPT_STRICT }; static const char *const optStrings[] = { "-strict", NULL }; @@ -2597,44 +2817,112 @@ BinaryDecodeUu( dataend = data + count; size = ((count + 3) & ~3) * 3 / 4; begin = cursor = Tcl_SetByteArrayLength(resultObj, size); + lineLen = -1; + + /* + * The decoding loop. First, we get the length of line (strictly, the + * number of data bytes we expect to generate from the line) we're + * processing this time round if it is not already known (i.e., when the + * lineLen variable is set to the magic value, -1). + */ + while (data < dataend) { char d[4] = {0, 0, 0, 0}; + if (lineLen < 0) { + c = *data++; + if (c < 32 || c > 96) { + if (strict || !isspace(c)) { + goto badUu; + } + i--; + continue; + } + lineLen = (c - 32) & 0x3f; + } + + /* + * Now we read a four-character grouping. + */ + for (i=0 ; i<4 ; i++) { if (data < dataend) { d[i] = c = *data++; - if (c < 33 || c > 96) { - if (strict || !isspace(UCHAR(c))) { - goto badUu; + if (c < 32 || c > 96) { + if (strict) { + if (!isspace(c)) { + goto badUu; + } else if (c == '\n') { + goto shortUu; + } } i--; continue; } - } else { - cut++; } } - if (cut > 3) { - cut = 3; + + /* + * Translate that grouping into (up to) three binary bytes output. + */ + + if (lineLen > 0) { + *cursor++ = (((d[0] - 0x20) & 0x3f) << 2) + | (((d[1] - 0x20) & 0x3f) >> 4); + if (--lineLen > 0) { + *cursor++ = (((d[1] - 0x20) & 0x3f) << 4) + | (((d[2] - 0x20) & 0x3f) >> 2); + if (--lineLen > 0) { + *cursor++ = (((d[2] - 0x20) & 0x3f) << 6) + | (((d[3] - 0x20) & 0x3f)); + lineLen--; + } + } + } + + /* + * If we've reached the end of the line, skip until we process a + * newline. + */ + + if (lineLen == 0 && data < dataend) { + lineLen = -1; + do { + c = *data++; + if (c == '\n') { + break; + } else if (c >= 32 && c <= 96) { + data--; + break; + } else if (strict || !isspace(c)) { + goto badUu; + } + } while (data < dataend); } - *cursor++ = (((d[0] - 0x20) & 0x3f) << 2) - | (((d[1] - 0x20) & 0x3f) >> 4); - *cursor++ = (((d[1] - 0x20) & 0x3f) << 4) - | (((d[2] - 0x20) & 0x3f) >> 2); - *cursor++ = (((d[2] - 0x20) & 0x3f) << 6) - | (((d[3] - 0x20) & 0x3f)); } - if (cut > size) { - cut = size; + + /* + * Sanity check, clean up and finish. + */ + + if (lineLen > 0 && strict) { + goto shortUu; } - Tcl_SetByteArrayLength(resultObj, cursor - begin - cut); + Tcl_SetByteArrayLength(resultObj, cursor - begin); Tcl_SetObjResult(interp, resultObj); return TCL_OK; + shortUu: + Tcl_SetObjResult(interp, Tcl_ObjPrintf("short uuencode data")); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "SHORT", NULL); + TclDecrRefCount(resultObj); + return TCL_ERROR; + badUu: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid uuencode character \"%c\" at position %d", c, (int) (data - datastart - 1))); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", NULL); TclDecrRefCount(resultObj); return TCL_ERROR; } diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index 70e64f0..e3fb98e 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -34,14 +34,14 @@ */ typedef struct MemTag { - int refCount; /* Number of mem_headers referencing this + size_t refCount; /* Number of mem_headers referencing this * tag. */ char string[1]; /* Actual size of string will be as large as * needed for actual tag. This must be the * last field in the structure. */ } MemTag; -#define TAG_SIZE(bytesInString) ((unsigned) ((TclOffset(MemTag, string) + 1) + bytesInString)) +#define TAG_SIZE(bytesInString) ((TclOffset(MemTag, string) + 1) + bytesInString) static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers (set * by "memory tag" command). */ @@ -52,14 +52,14 @@ static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers (set * to help detect chunk under-runs. */ -#define LOW_GUARD_SIZE (8 + (32 - (sizeof(long) + sizeof(int)))%8) +#define LOW_GUARD_SIZE (8 + (32 - (sizeof(size_t) + sizeof(int)))%8) struct mem_header { struct mem_header *flink; struct mem_header *blink; MemTag *tagPtr; /* Tag from "memory tag" command; may be * NULL. */ const char *file; - long length; + size_t length; int line; unsigned char low_guard[LOW_GUARD_SIZE]; /* Aligns body on 8-byte boundary, plus @@ -89,14 +89,14 @@ static struct mem_header *allocHead = NULL; /* List of allocated structures */ #define BODY_OFFSET \ ((size_t) (&((struct mem_header *) 0)->body)) -static int total_mallocs = 0; -static int total_frees = 0; +static unsigned int total_mallocs = 0; +static unsigned int total_frees = 0; static size_t current_bytes_malloced = 0; static size_t maximum_bytes_malloced = 0; -static int current_malloc_packets = 0; -static int maximum_malloc_packets = 0; -static int break_on_malloc = 0; -static int trace_on_at_malloc = 0; +static unsigned int current_malloc_packets = 0; +static unsigned int maximum_malloc_packets = 0; +static unsigned int break_on_malloc = 0; +static unsigned int trace_on_at_malloc = 0; static int alloc_tracing = FALSE; static int init_malloced_bodies = TRUE; #ifdef MEM_VALIDATE @@ -156,7 +156,7 @@ TclInitDbCkalloc(void) if (!ckallocInit) { ckallocInit = 1; ckallocMutexPtr = Tcl_GetAllocMutex(); -#ifndef TCL_THREADS +#if !TCL_THREADS /* Silence compiler warning */ (void)ckallocMutexPtr; #endif @@ -184,18 +184,18 @@ TclDumpMemoryInfo( return 0; } sprintf(buf, - "total mallocs %10d\n" - "total frees %10d\n" - "current packets allocated %10d\n" - "current bytes allocated %10lu\n" - "maximum packets allocated %10d\n" - "maximum bytes allocated %10lu\n", + "total mallocs %10u\n" + "total frees %10u\n" + "current packets allocated %10u\n" + "current bytes allocated %10" TCL_Z_MODIFIER "u\n" + "maximum packets allocated %10u\n" + "maximum bytes allocated %10" TCL_Z_MODIFIER "u\n", total_mallocs, total_frees, current_malloc_packets, - (unsigned long)current_bytes_malloced, + current_bytes_malloced, maximum_malloc_packets, - (unsigned long)maximum_bytes_malloced); + maximum_bytes_malloced); if (flags == 0) { fprintf((FILE *)clientData, "%s", buf); } else { @@ -251,10 +251,10 @@ ValidateMemory( } if (guard_failed) { TclDumpMemoryInfo((ClientData) stderr, 0); - fprintf(stderr, "low guard failed at %lx, %s %d\n", - (long unsigned) memHeaderP->body, file, line); + fprintf(stderr, "low guard failed at %p, %s %d\n", + memHeaderP->body, file, line); fflush(stderr); /* In case name pointer is bad. */ - fprintf(stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length, + fprintf(stderr, "%" TCL_Z_MODIFIER "u bytes allocated at (%s %d)\n", memHeaderP->length, memHeaderP->file, memHeaderP->line); Tcl_Panic("Memory validation failure"); } @@ -273,10 +273,10 @@ ValidateMemory( if (guard_failed) { TclDumpMemoryInfo((ClientData) stderr, 0); - fprintf(stderr, "high guard failed at %lx, %s %d\n", - (long unsigned) memHeaderP->body, file, line); + fprintf(stderr, "high guard failed at %p, %s %d\n", + memHeaderP->body, file, line); fflush(stderr); /* In case name pointer is bad. */ - fprintf(stderr, "%ld bytes allocated at (%s %d)\n", + fprintf(stderr, "%" TCL_Z_MODIFIER "u bytes allocated at (%s %d)\n", memHeaderP->length, memHeaderP->file, memHeaderP->line); Tcl_Panic("Memory validation failure"); @@ -359,9 +359,8 @@ Tcl_DumpActiveMemory( Tcl_MutexLock(ckallocMutexPtr); for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) { address = &memScanP->body[0]; - fprintf(fileP, "%8lx - %8lx %7ld @ %s %d %s", - (long unsigned) address, - (long unsigned) address + memScanP->length - 1, + fprintf(fileP, "%p - %p %" TCL_Z_MODIFIER "u @ %s %d %s", + address, address + memScanP->length - 1, memScanP->length, memScanP->file, memScanP->line, (memScanP->tagPtr == NULL) ? "" : memScanP->tagPtr->string); (void) fputc('\n', fileP); @@ -450,7 +449,7 @@ Tcl_DbCkalloc( total_mallocs++; if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) { (void) fflush(stdout); - fprintf(stderr, "reached malloc trace enable point (%d)\n", + fprintf(stderr, "reached malloc trace enable point (%u)\n", total_mallocs); fflush(stderr); alloc_tracing = TRUE; @@ -458,14 +457,14 @@ Tcl_DbCkalloc( } if (alloc_tracing) { - fprintf(stderr,"ckalloc %lx %u %s %d\n", - (long unsigned int) result->body, size, file, line); + fprintf(stderr,"ckalloc %p %u %s %d\n", + result->body, size, file, line); } if (break_on_malloc && (total_mallocs >= break_on_malloc)) { break_on_malloc = 0; (void) fflush(stdout); - Tcl_Panic("reached malloc break limit (%d)", total_mallocs); + Tcl_Panic("reached malloc break limit (%u)", total_mallocs); } current_malloc_packets++; @@ -547,8 +546,8 @@ Tcl_AttemptDbCkalloc( } if (alloc_tracing) { - fprintf(stderr,"ckalloc %lx %u %s %d\n", - (long unsigned int) result->body, size, file, line); + fprintf(stderr,"ckalloc %p %u %s %d\n", + result->body, size, file, line); } if (break_on_malloc && (total_mallocs >= break_on_malloc)) { @@ -612,8 +611,8 @@ Tcl_DbCkfree( memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET); if (alloc_tracing) { - fprintf(stderr, "ckfree %lx %ld %s %d\n", - (long unsigned int) memp->body, memp->length, file, line); + fprintf(stderr, "ckfree %p %" TCL_Z_MODIFIER "u %s %d\n", + memp->body, memp->length, file, line); } if (validate_memory) { @@ -623,7 +622,7 @@ Tcl_DbCkfree( Tcl_MutexLock(ckallocMutexPtr); ValidateMemory(memp, file, line, TRUE); if (init_malloced_bodies) { - memset(ptr, GUARD_VALUE, (size_t) memp->length); + memset(ptr, GUARD_VALUE, memp->length); } total_frees++; @@ -631,8 +630,7 @@ Tcl_DbCkfree( current_bytes_malloced -= memp->length; if (memp->tagPtr != NULL) { - memp->tagPtr->refCount--; - if ((memp->tagPtr->refCount == 0) && (curTagPtr != memp->tagPtr)) { + if ((memp->tagPtr->refCount-- <= 1) && (curTagPtr != memp->tagPtr)) { TclpFree((char *) memp->tagPtr); } } @@ -675,7 +673,7 @@ Tcl_DbCkrealloc( int line) { char *newPtr; - unsigned int copySize; + size_t copySize; struct mem_header *memp; if (ptr == NULL) { @@ -689,7 +687,7 @@ Tcl_DbCkrealloc( memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET); copySize = size; - if (copySize > (unsigned int) memp->length) { + if (copySize > memp->length) { copySize = memp->length; } newPtr = Tcl_DbCkalloc(size, file, line); @@ -706,7 +704,7 @@ Tcl_AttemptDbCkrealloc( int line) { char *newPtr; - unsigned int copySize; + size_t copySize; struct mem_header *memp; if (ptr == NULL) { @@ -720,7 +718,7 @@ Tcl_AttemptDbCkrealloc( memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET); copySize = size; - if (copySize > (unsigned int) memp->length) { + if (copySize > memp->length) { copySize = memp->length; } newPtr = Tcl_AttemptDbCkalloc(size, file, line); @@ -849,22 +847,24 @@ MemoryCmd( return TCL_OK; } if (strcmp(argv[1],"break_on_malloc") == 0) { + int value; if (argc != 3) { goto argError; } - if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) { + if (Tcl_GetInt(interp, argv[2], &value) != TCL_OK) { return TCL_ERROR; } + break_on_malloc = (unsigned int) value; return TCL_OK; } if (strcmp(argv[1],"info") == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10lu\n%-25s %10d\n%-25s %10lu\n", + "%-25s %10u\n%-25s %10u\n%-25s %10u\n%-25s %10" TCL_Z_MODIFIER"u\n%-25s %10u\n%-25s %10" TCL_Z_MODIFIER "u\n", "total mallocs", total_mallocs, "total frees", total_frees, "current packets allocated", current_malloc_packets, - "current bytes allocated", (unsigned long)current_bytes_malloced, + "current bytes allocated", current_bytes_malloced, "maximum packets allocated", maximum_malloc_packets, - "maximum bytes allocated", (unsigned long)maximum_bytes_malloced)); + "maximum bytes allocated", maximum_bytes_malloced)); return TCL_OK; } if (strcmp(argv[1], "init") == 0) { @@ -935,12 +935,14 @@ MemoryCmd( } if (strcmp(argv[1],"trace_on_at_malloc") == 0) { + int value; if (argc != 3) { goto argError; } - if (Tcl_GetInt(interp, argv[2], &trace_on_at_malloc) != TCL_OK) { + if (Tcl_GetInt(interp, argv[2], &value) != TCL_OK) { return TCL_ERROR; } + trace_on_at_malloc = value; return TCL_OK; } if (strcmp(argv[1],"validate") == 0) { diff --git a/generic/tclClock.c b/generic/tclClock.c index 6d2976d..bbfc83b 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -19,7 +19,7 @@ * Windows has mktime. The configurators do not check. */ -#ifdef __WIN32__ +#ifdef _WIN32 #define HAVE_MKTIME 1 #endif @@ -91,8 +91,8 @@ static const char *const literals[] = { * Structure containing the client data for [clock] */ -typedef struct ClockClientData { - int refCount; /* Number of live references. */ +typedef struct { + size_t refCount; /* Number of live references. */ Tcl_Obj **literals; /* Pool of object literals. */ } ClockClientData; @@ -208,11 +208,7 @@ struct ClockCommand { }; static const struct ClockCommand clockCommands[] = { - { "clicks", ClockClicksObjCmd }, { "getenv", ClockGetenvObjCmd }, - { "microseconds", ClockMicrosecondsObjCmd }, - { "milliseconds", ClockMillisecondsObjCmd }, - { "seconds", ClockSecondsObjCmd }, { "Oldscan", TclClockOldscanObjCmd }, { "ConvertLocalToUTC", ClockConvertlocaltoutcObjCmd }, { "GetDateFields", ClockGetdatefieldsObjCmd }, @@ -253,6 +249,19 @@ TclClockInit( ClockClientData *data; int i; + /* Structure of the 'clock' ensemble */ + + static const EnsembleImplMap clockImplMap[] = { + {"add", NULL, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, + {"clicks", ClockClicksObjCmd, TclCompileClockClicksCmd, NULL, NULL, 0}, + {"format", NULL, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, + {"microseconds", ClockMicrosecondsObjCmd, TclCompileClockReadingCmd, NULL, INT2PTR(1), 0}, + {"milliseconds", ClockMillisecondsObjCmd, TclCompileClockReadingCmd, NULL, INT2PTR(2), 0}, + {"scan", NULL, TclCompileBasicMin1ArgCmd, NULL, NULL , 0}, + {"seconds", ClockSecondsObjCmd, TclCompileClockReadingCmd, NULL, INT2PTR(3), 0}, + {NULL, NULL, NULL, NULL, NULL, 0} + }; + /* * Safe interps get [::clock] as alias to a master, so do not need their * own copies of the support routines. @@ -276,6 +285,7 @@ TclClockInit( /* * Install the commands. + * TODO - Let Tcl_MakeEnsemble do this? */ #define TCL_CLOCK_PREFIX_LEN 14 /* == strlen("::tcl::clock::") */ @@ -286,6 +296,10 @@ TclClockInit( Tcl_CreateObjCommand(interp, cmdName, clockCmdPtr->objCmdProc, data, ClockDeleteCmdProc); } + + /* Make the clock ensemble */ + + TclMakeEnsemble(interp, "clock", clockImplMap); } /* @@ -349,7 +363,7 @@ ClockConvertlocaltoutcObjCmd( "found in dictionary", -1)); return TCL_ERROR; } - if ((Tcl_GetWideIntFromObj(interp, secondsObj, + if ((TclGetWideIntFromObj(interp, secondsObj, &fields.localSeconds) != TCL_OK) || (TclGetIntFromObj(interp, objv[3], &changeover) != TCL_OK) || ConvertLocalToUTC(interp, &fields, objv[2], changeover)) { @@ -428,7 +442,7 @@ ClockGetdatefieldsObjCmd( Tcl_WrongNumArgs(interp, 1, objv, "seconds tzdata changeover"); return TCL_ERROR; } - if (Tcl_GetWideIntFromObj(interp, objv[1], &fields.seconds) != TCL_OK + if (TclGetWideIntFromObj(interp, objv[1], &fields.seconds) != TCL_OK || TclGetIntFromObj(interp, objv[3], &changeover) != TCL_OK) { return TCL_ERROR; } @@ -522,6 +536,46 @@ ClockGetdatefieldsObjCmd( */ static int +FetchEraField( + Tcl_Interp *interp, + Tcl_Obj *dict, + Tcl_Obj *key, + int *storePtr) +{ + Tcl_Obj *value = NULL; + + if (Tcl_DictObjGet(interp, dict, key, &value) != TCL_OK) { + return TCL_ERROR; + } + if (value == NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "expected key(s) not found in dictionary", -1)); + return TCL_ERROR; + } + return Tcl_GetIndexFromObj(interp, value, eras, "era", TCL_EXACT, storePtr); +} + +static int +FetchIntField( + Tcl_Interp *interp, + Tcl_Obj *dict, + Tcl_Obj *key, + int *storePtr) +{ + Tcl_Obj *value = NULL; + + if (Tcl_DictObjGet(interp, dict, key, &value) != TCL_OK) { + return TCL_ERROR; + } + if (value == NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "expected key(s) not found in dictionary", -1)); + return TCL_ERROR; + } + return TclGetIntFromObj(interp, value, storePtr); +} + +static int ClockGetjuliandayfromerayearmonthdayObjCmd( ClientData clientData, /* Opaque pointer to literal pool, etc. */ Tcl_Interp *interp, /* Tcl interpreter */ @@ -532,7 +586,6 @@ ClockGetjuliandayfromerayearmonthdayObjCmd( Tcl_Obj *dict; ClockClientData *data = clientData; Tcl_Obj *const *literals = data->literals; - Tcl_Obj *fieldPtr; int changeover; int copied = 0; int status; @@ -547,18 +600,13 @@ ClockGetjuliandayfromerayearmonthdayObjCmd( return TCL_ERROR; } dict = objv[1]; - if (Tcl_DictObjGet(interp, dict, literals[LIT_ERA], &fieldPtr) != TCL_OK - || Tcl_GetIndexFromObj(interp, fieldPtr, eras, "era", TCL_EXACT, - &era) != TCL_OK - || Tcl_DictObjGet(interp, dict, literals[LIT_YEAR], - &fieldPtr) != TCL_OK - || TclGetIntFromObj(interp, fieldPtr, &fields.year) != TCL_OK - || Tcl_DictObjGet(interp, dict, literals[LIT_MONTH], - &fieldPtr) != TCL_OK - || TclGetIntFromObj(interp, fieldPtr, &fields.month) != TCL_OK - || Tcl_DictObjGet(interp, dict, literals[LIT_DAYOFMONTH], - &fieldPtr) != TCL_OK - || TclGetIntFromObj(interp, fieldPtr, &fields.dayOfMonth)!=TCL_OK + if (FetchEraField(interp, dict, literals[LIT_ERA], &era) != TCL_OK + || FetchIntField(interp, dict, literals[LIT_YEAR], &fields.year) + != TCL_OK + || FetchIntField(interp, dict, literals[LIT_MONTH], &fields.month) + != TCL_OK + || FetchIntField(interp, dict, literals[LIT_DAYOFMONTH], + &fields.dayOfMonth) != TCL_OK || TclGetIntFromObj(interp, objv[2], &changeover) != TCL_OK) { return TCL_ERROR; } @@ -622,7 +670,6 @@ ClockGetjuliandayfromerayearweekdayObjCmd( Tcl_Obj *dict; ClockClientData *data = clientData; Tcl_Obj *const *literals = data->literals; - Tcl_Obj *fieldPtr; int changeover; int copied = 0; int status; @@ -637,18 +684,13 @@ ClockGetjuliandayfromerayearweekdayObjCmd( return TCL_ERROR; } dict = objv[1]; - if (Tcl_DictObjGet(interp, dict, literals[LIT_ERA], &fieldPtr) != TCL_OK - || Tcl_GetIndexFromObj(interp, fieldPtr, eras, "era", TCL_EXACT, - &era) != TCL_OK - || Tcl_DictObjGet(interp, dict, literals[LIT_ISO8601YEAR], - &fieldPtr) != TCL_OK - || TclGetIntFromObj(interp, fieldPtr, &fields.iso8601Year)!=TCL_OK - || Tcl_DictObjGet(interp, dict, literals[LIT_ISO8601WEEK], - &fieldPtr) != TCL_OK - || TclGetIntFromObj(interp, fieldPtr, &fields.iso8601Week)!=TCL_OK - || Tcl_DictObjGet(interp, dict, literals[LIT_DAYOFWEEK], - &fieldPtr) != TCL_OK - || TclGetIntFromObj(interp, fieldPtr, &fields.dayOfWeek) != TCL_OK + if (FetchEraField(interp, dict, literals[LIT_ERA], &era) != TCL_OK + || FetchIntField(interp, dict, literals[LIT_ISO8601YEAR], + &fields.iso8601Year) != TCL_OK + || FetchIntField(interp, dict, literals[LIT_ISO8601WEEK], + &fields.iso8601Week) != TCL_OK + || FetchIntField(interp, dict, literals[LIT_DAYOFWEEK], + &fields.dayOfWeek) != TCL_OK || TclGetIntFromObj(interp, objv[2], &changeover) != TCL_OK) { return TCL_ERROR; } @@ -1106,7 +1148,7 @@ LookupLastTransition( */ if (Tcl_ListObjIndex(interp, rowv[0], 0, &compObj) != TCL_OK - || Tcl_GetWideIntFromObj(interp, compObj, &compVal) != TCL_OK) { + || TclGetWideIntFromObj(interp, compObj, &compVal) != TCL_OK) { return NULL; } @@ -1129,7 +1171,7 @@ LookupLastTransition( int m = (l + u + 1) / 2; if (Tcl_ListObjIndex(interp, rowv[m], 0, &compObj) != TCL_OK || - Tcl_GetWideIntFromObj(interp, compObj, &compVal) != TCL_OK) { + TclGetWideIntFromObj(interp, compObj, &compVal) != TCL_OK) { return NULL; } if (tick >= compVal) { @@ -1471,7 +1513,19 @@ GetJulianDayFromEraYearMonthDay( * Try an initial conversion in the Gregorian calendar. */ +#if 0 /* BUG http://core.tcl.tk/tcl/tktview?name=da340d4f32 */ ym1o4 = ym1 / 4; +#else + /* + * Have to make sure quotient is truncated towards 0 when negative. + * See above bug for details. The casts are necessary. + */ + if (ym1 >= 0) + ym1o4 = ym1 / 4; + else { + ym1o4 = - (int) (((unsigned int) -ym1) / 4); + } +#endif if (ym1 % 4 < 0) { ym1o4--; } @@ -1524,12 +1578,10 @@ static int IsGregorianLeapYear( TclDateFields *fields) /* Date to test */ { - int year; + int year = fields->year; if (fields->era == BCE) { - year = 1 - fields->year; - } else { - year = fields->year; + year = 1 - year; } if (year%4 != 0) { return 0; @@ -1640,7 +1692,7 @@ ThreadSafeLocalTime( * Get a thread-local buffer to hold the returned time. */ - struct tm *tmPtr = Tcl_GetThreadData(&tmKey, (int) sizeof(struct tm)); + struct tm *tmPtr = Tcl_GetThreadData(&tmKey, sizeof(struct tm)); #ifdef HAVE_LOCALTIME_R localtime_r(timePtr, tmPtr); #else @@ -1697,7 +1749,7 @@ ClockClicksObjCmd( case 1: break; case 2: - if (Tcl_GetIndexFromObj(interp, objv[1], clicksSwitches, "switch", 0, + if (Tcl_GetIndexFromObj(interp, objv[1], clicksSwitches, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } @@ -1867,9 +1919,9 @@ ClockParseformatargsObjCmd( localeObj = litPtr[LIT_C]; timezoneObj = litPtr[LIT__NIL]; for (i = 2; i < objc; i+=2) { - if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", 0, + if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &optionIndex) != TCL_OK) { - Tcl_SetErrorCode(interp, "CLOCK", "badSwitch", + Tcl_SetErrorCode(interp, "CLOCK", "badOption", Tcl_GetString(objv[i]), NULL); return TCL_ERROR; } @@ -1896,7 +1948,7 @@ ClockParseformatargsObjCmd( * Check options. */ - if (Tcl_GetWideIntFromObj(interp, objv[1], &clockVal) != TCL_OK) { + if (TclGetWideIntFromObj(interp, objv[1], &clockVal) != TCL_OK) { return TCL_ERROR; } if ((saw & (1 << CLOCK_FORMAT_GMT)) @@ -1977,22 +2029,23 @@ ClockSecondsObjCmd( static void TzsetIfNecessary(void) { - static char *tzWas = NULL; /* Previous value of TZ, protected by + static char* tzWas = INT2PTR(-1); /* Previous value of TZ, protected by * clockMutex. */ const char *tzIsNow; /* Current value of TZ */ Tcl_MutexLock(&clockMutex); tzIsNow = getenv("TZ"); - if (tzIsNow != NULL && (tzWas == NULL || strcmp(tzIsNow, tzWas) != 0)) { + if (tzIsNow != NULL && (tzWas == NULL || tzWas == INT2PTR(-1) + || strcmp(tzIsNow, tzWas) != 0)) { tzset(); - if (tzWas != NULL) { + if (tzWas != NULL && tzWas != INT2PTR(-1)) { ckfree(tzWas); } tzWas = ckalloc(strlen(tzIsNow) + 1); strcpy(tzWas, tzIsNow); } else if (tzIsNow == NULL && tzWas != NULL) { tzset(); - ckfree(tzWas); + if (tzWas != INT2PTR(-1)) ckfree(tzWas); tzWas = NULL; } Tcl_MutexUnlock(&clockMutex); @@ -2019,8 +2072,7 @@ ClockDeleteCmdProc( ClockClientData *data = clientData; int i; - data->refCount--; - if (data->refCount == 0) { + if (data->refCount-- <= 1) { for (i = 0; i < LIT__END; ++i) { Tcl_DecrRefCount(data->literals[i]); } diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index f90819a..810fac6 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -12,6 +12,9 @@ */ #include "tclInt.h" +#ifdef _WIN32 +# include "tclWinInt.h" +#endif #include <locale.h> /* @@ -43,9 +46,24 @@ struct ForeachState { static int CheckAccess(Tcl_Interp *interp, Tcl_Obj *pathPtr, int mode); +static int BadEncodingSubcommand(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int EncodingConvertfromObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int EncodingConverttoObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); static int EncodingDirsObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static int EncodingNamesObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int EncodingSystemObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); static inline int ForeachAssignments(Tcl_Interp *interp, struct ForeachState *statePtr); static inline void ForeachCleanup(Tcl_Interp *interp, @@ -146,7 +164,7 @@ Tcl_BreakObjCmd( * *---------------------------------------------------------------------- */ - +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 /* ARGSUSED */ int Tcl_CaseObjCmd( @@ -264,6 +282,7 @@ Tcl_CaseObjCmd( return TCL_OK; } +#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -495,122 +514,266 @@ Tcl_ContinueObjCmd( } /* + *----------------------------------------------------------------------------- + * + * TclInitEncodingCmd -- + * + * This function creates the 'encoding' ensemble. + * + * Results: + * Returns the Tcl_Command so created. + * + * Side effects: + * The ensemble is initialized. + * + * This command is hidden in a safe interpreter. + */ + +Tcl_Command +TclInitEncodingCmd( + Tcl_Interp* interp) /* Tcl interpreter */ +{ + static const EnsembleImplMap encodingImplMap[] = { + {"convertfrom", EncodingConvertfromObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, + {"convertto", EncodingConverttoObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, + {"dirs", EncodingDirsObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"names", EncodingNamesObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, + {"system", EncodingSystemObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, NULL, 0} + }; + + return TclMakeEnsemble(interp, "encoding", encodingImplMap); +} + +/* + *----------------------------------------------------------------------------- + * + * TclMakeEncodingCommandSafe -- + * + * This function hides the unsafe 'dirs' and 'system' subcommands of + * the "encoding" Tcl command ensemble. It must be called only from + * TclHideUnsafeCommands. + * + * Results: + * A standard Tcl result + * + * Side effects: + * Adds commands to the table of hidden commands. + * + *----------------------------------------------------------------------------- + */ + +int +TclMakeEncodingCommandSafe( + Tcl_Interp* interp) /* Tcl interpreter */ +{ + static const struct { + const char *cmdName; + int unsafe; + } unsafeInfo[] = { + {"convertfrom", 0}, + {"convertto", 0}, + {"dirs", 1}, + {"names", 0}, + {"system", 0}, + {NULL, 0} + }; + + int i; + Tcl_DString oldBuf, newBuf; + + Tcl_DStringInit(&oldBuf); + TclDStringAppendLiteral(&oldBuf, "::tcl::encoding::"); + Tcl_DStringInit(&newBuf); + TclDStringAppendLiteral(&newBuf, "tcl:encoding:"); + for (i=0 ; unsafeInfo[i].cmdName != NULL ; i++) { + if (unsafeInfo[i].unsafe) { + const char *oldName, *newName; + + Tcl_DStringSetLength(&oldBuf, 17); + oldName = Tcl_DStringAppend(&oldBuf, unsafeInfo[i].cmdName, -1); + Tcl_DStringSetLength(&newBuf, 13); + newName = Tcl_DStringAppend(&newBuf, unsafeInfo[i].cmdName, -1); + if (TclRenameCommand(interp, oldName, "___tmp") != TCL_OK + || Tcl_HideCommand(interp, "___tmp", newName) != TCL_OK) { + Tcl_Panic("problem making 'encoding %s' safe: %s", + unsafeInfo[i].cmdName, + Tcl_GetString(Tcl_GetObjResult(interp))); + } + Tcl_CreateObjCommand(interp, oldName, BadEncodingSubcommand, + (ClientData) unsafeInfo[i].cmdName, NULL); + } + } + Tcl_DStringFree(&oldBuf); + Tcl_DStringFree(&newBuf); + + /* + * Ugh. The [encoding] command is now actually safe, but it is assumed by + * scripts that it is not, which messes up security policies. + */ + + if (Tcl_HideCommand(interp, "encoding", "encoding") != TCL_OK) { + Tcl_Panic("problem making 'encoding' safe: %s", + Tcl_GetString(Tcl_GetObjResult(interp))); + } + return TCL_OK; +} + +/* *---------------------------------------------------------------------- * - * Tcl_EncodingObjCmd -- + * BadEncodingSubcommand -- * - * This command manipulates encodings. + * Command used to act as a backstop implementation when subcommands of + * "encoding" are unsafe (the real implementations of the subcommands are + * hidden). The clientData is always the full official subcommand name. * * Results: - * A standard Tcl result. + * A standard Tcl result (always a TCL_ERROR). * * Side effects: - * See the user documentation. + * None. + * + *---------------------------------------------------------------------- + */ + +static int +BadEncodingSubcommand( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + const char *subcommandName = (const char *) clientData; + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "not allowed to invoke subcommand %s of encoding", subcommandName)); + Tcl_SetErrorCode(interp, "TCL", "SAFE", "SUBCOMMAND", NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * EncodingConvertfromObjCmd -- + * + * This command converts a byte array in an external encoding into a + * Tcl string + * + * Results: + * A standard Tcl result. * *---------------------------------------------------------------------- */ int -Tcl_EncodingObjCmd( +EncodingConvertfromObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int index; - - static const char *const optionStrings[] = { - "convertfrom", "convertto", "dirs", "names", "system", - NULL - }; - enum options { - ENC_CONVERTFROM, ENC_CONVERTTO, ENC_DIRS, ENC_NAMES, ENC_SYSTEM - }; + Tcl_Obj *data; /* Byte array to convert */ + Tcl_DString ds; /* Buffer to hold the string */ + Tcl_Encoding encoding; /* Encoding to use */ + int length; /* Length of the byte array being converted */ + const char *bytesPtr; /* Pointer to the first byte of the array */ - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, - &index) != TCL_OK) { + if (objc == 2) { + encoding = Tcl_GetEncoding(interp, NULL); + data = objv[1]; + } else if (objc == 3) { + if (Tcl_GetEncodingFromObj(interp, objv[1], &encoding) != TCL_OK) { + return TCL_ERROR; + } + data = objv[2]; + } else { + Tcl_WrongNumArgs(interp, 1, objv, "?encoding? data"); return TCL_ERROR; } - switch ((enum options) index) { - case ENC_CONVERTTO: - case ENC_CONVERTFROM: { - Tcl_Obj *data; - Tcl_DString ds; - Tcl_Encoding encoding; - int length; - const char *stringPtr; - - if (objc == 3) { - encoding = Tcl_GetEncoding(interp, NULL); - data = objv[2]; - } else if (objc == 4) { - if (Tcl_GetEncodingFromObj(interp, objv[2], &encoding) != TCL_OK) { - return TCL_ERROR; - } - data = objv[3]; - } else { - Tcl_WrongNumArgs(interp, 2, objv, "?encoding? data"); - return TCL_ERROR; - } + /* + * Convert the string into a byte array in 'ds' + */ + bytesPtr = (char *) Tcl_GetByteArrayFromObj(data, &length); + Tcl_ExternalToUtfDString(encoding, bytesPtr, length, &ds); - if ((enum options) index == ENC_CONVERTFROM) { - /* - * Treat the string as binary data. - */ + /* + * Note that we cannot use Tcl_DStringResult here because it will + * truncate the string at the first null byte. + */ - stringPtr = (char *) Tcl_GetByteArrayFromObj(data, &length); - Tcl_ExternalToUtfDString(encoding, stringPtr, length, &ds); + Tcl_SetObjResult(interp, TclDStringToObj(&ds)); - /* - * Note that we cannot use Tcl_DStringResult here because it will - * truncate the string at the first null byte. - */ + /* + * We're done with the encoding + */ - Tcl_SetObjResult(interp, TclDStringToObj(&ds)); - } else { - /* - * Store the result as binary data. - */ - - stringPtr = TclGetStringFromObj(data, &length); - Tcl_UtfToExternalDString(encoding, stringPtr, length, &ds); - Tcl_SetObjResult(interp, Tcl_NewByteArrayObj( - (unsigned char *) Tcl_DStringValue(&ds), - Tcl_DStringLength(&ds))); - Tcl_DStringFree(&ds); - } + Tcl_FreeEncoding(encoding); + return TCL_OK; - Tcl_FreeEncoding(encoding); - break; - } - case ENC_DIRS: - return EncodingDirsObjCmd(dummy, interp, objc, objv); - case ENC_NAMES: - if (objc > 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return TCL_ERROR; - } - Tcl_GetEncodingNames(interp); - break; - case ENC_SYSTEM: - if (objc > 3) { - Tcl_WrongNumArgs(interp, 2, objv, "?encoding?"); +} + +/* + *---------------------------------------------------------------------- + * + * EncodingConverttoObjCmd -- + * + * This command converts a Tcl string into a byte array that + * encodes the string according to some encoding. + * + * Results: + * A standard Tcl result. + * + *---------------------------------------------------------------------- + */ + +int +EncodingConverttoObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Obj *data; /* String to convert */ + Tcl_DString ds; /* Buffer to hold the byte array */ + Tcl_Encoding encoding; /* Encoding to use */ + int length; /* Length of the string being converted */ + const char *stringPtr; /* Pointer to the first byte of the string */ + + /* TODO - ADJUST OBJ INDICES WHEN ENSEMBLIFYING THIS */ + + if (objc == 2) { + encoding = Tcl_GetEncoding(interp, NULL); + data = objv[1]; + } else if (objc == 3) { + if (Tcl_GetEncodingFromObj(interp, objv[1], &encoding) != TCL_OK) { return TCL_ERROR; } - if (objc == 2) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - Tcl_GetEncodingName(NULL), -1)); - } else { - return Tcl_SetSystemEncoding(interp, TclGetString(objv[2])); - } - break; + data = objv[2]; + } else { + Tcl_WrongNumArgs(interp, 1, objv, "?encoding? data"); + return TCL_ERROR; } + + /* + * Convert the string to a byte array in 'ds' + */ + + stringPtr = TclGetStringFromObj(data, &length); + Tcl_UtfToExternalDString(encoding, stringPtr, length, &ds); + Tcl_SetObjResult(interp, + Tcl_NewByteArrayObj((unsigned char*) Tcl_DStringValue(&ds), + Tcl_DStringLength(&ds))); + Tcl_DStringFree(&ds); + + /* + * We're done with the encoding + */ + + Tcl_FreeEncoding(encoding); return TCL_OK; + } /* @@ -638,16 +801,16 @@ EncodingDirsObjCmd( { Tcl_Obj *dirListObj; - if (objc > 3) { - Tcl_WrongNumArgs(interp, 2, objv, "?dirList?"); + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?dirList?"); return TCL_ERROR; } - if (objc == 2) { + if (objc == 1) { Tcl_SetObjResult(interp, Tcl_GetEncodingSearchPath()); return TCL_OK; } - dirListObj = objv[2]; + dirListObj = objv[1]; if (Tcl_SetEncodingSearchPath(dirListObj) == TCL_ERROR) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected directory list but got \"%s\"", @@ -661,6 +824,68 @@ EncodingDirsObjCmd( } /* + *----------------------------------------------------------------------------- + * + * EncodingNamesObjCmd -- + * + * This command returns a list of the available encoding names + * + * Results: + * Returns a standard Tcl result + * + *----------------------------------------------------------------------------- + */ + +int +EncodingNamesObjCmd(ClientData dummy, /* Unused */ + Tcl_Interp* interp, /* Tcl interpreter */ + int objc, /* Number of command line args */ + Tcl_Obj* const objv[]) /* Vector of command line args */ +{ + if (objc > 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return TCL_ERROR; + } + Tcl_GetEncodingNames(interp); + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * EncodingSystemObjCmd -- + * + * This command retrieves or changes the system encoding + * + * Results: + * Returns a standard Tcl result + * + * Side effects: + * May change the system encoding. + * + *----------------------------------------------------------------------------- + */ + +int +EncodingSystemObjCmd(ClientData dummy, /* Unused */ + Tcl_Interp* interp, /* Tcl interpreter */ + int objc, /* Number of command line args */ + Tcl_Obj* const objv[]) /* Vector of command line args */ +{ + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?encoding?"); + return TCL_ERROR; + } + if (objc == 1) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj(Tcl_GetEncodingName(NULL), -1)); + } else { + return Tcl_SetSystemEncoding(interp, TclGetString(objv[1])); + } + return TCL_OK; +} + +/* *---------------------------------------------------------------------- * * Tcl_ErrorObjCmd -- @@ -748,7 +973,7 @@ Tcl_EvalObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - return Tcl_NRCallObjProc(interp, TclNREvalObjCmd, dummy, objc, objv); + return Tcl_NRCallObjProc(interp, TclNREvalObjCmd, dummy, objc, objv); } int @@ -1157,6 +1382,16 @@ FileAttrAccessTimeCmd( if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } +#if defined(_WIN32) + /* We use a value of 0 to indicate the access time not available */ + if (buf.st_atime == 0) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not get access time for file \"%s\"", + TclGetString(objv[1]))); + return TCL_ERROR; + } +#endif + if (objc == 3) { /* * Need separate variable for reading longs from an object on 64-bit @@ -1229,6 +1464,15 @@ FileAttrModifyTimeCmd( if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } +#if defined(_WIN32) + /* We use a value of 0 to indicate the modification time not available */ + if (buf.st_mtime == 0) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not get modification time for file \"%s\"", + TclGetString(objv[1]))); + return TCL_ERROR; + } +#endif if (objc == 3) { /* * Need separate variable for reading longs from an object on 64-bit @@ -1574,28 +1818,25 @@ FileAttrIsOwnedCmd( int objc, Tcl_Obj *const objv[]) { +#ifdef __CYGWIN__ +#define geteuid() (short)(geteuid)() +#endif +#if !defined(_WIN32) Tcl_StatBuf buf; +#endif int value = 0; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "name"); return TCL_ERROR; } - if (GetStatBuf(NULL, objv[1], Tcl_FSStat, &buf) == TCL_OK) { - /* - * For Windows, there are no user ids associated with a file, so we - * always return 1. - * - * TODO: use GetSecurityInfo to get the real owner of the file and - * test for equivalence to the current user. - */ - -#if defined(__WIN32__) || defined(__CYGWIN__) - value = 1; +#if defined(_WIN32) + value = TclWinFileOwned(objv[1]); #else + if (GetStatBuf(NULL, objv[1], Tcl_FSStat, &buf) == TCL_OK) { value = (geteuid() == buf.st_uid); -#endif } +#endif Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); return TCL_OK; } diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 789f506..c95f1f2 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -29,7 +29,7 @@ typedef struct SortElement { union { /* The value that we sorting by. */ const char *strValuePtr; - long intValue; + Tcl_WideInt wideValue; double doubleValue; Tcl_Obj *objValuePtr; } collationKey; @@ -64,8 +64,9 @@ typedef struct SortInfo { * SORTMODE_COMMAND. Pre-initialized to hold * base of command. */ int *indexv; /* If the -index option was specified, this - * holds the indexes contained in the list - * supplied as an argument to that option. + * holds an encoding of the indexes contained + * in the list supplied as an argument to + * that option. * NULL if no indexes supplied, and points to * singleIndex field when only one * supplied. */ @@ -93,20 +94,11 @@ typedef struct SortInfo { #define SORTMODE_ASCII_NC 8 /* - * 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 int DictionaryCompare(const char *left, const char *right); -static int IfConditionCallback(ClientData data[], - Tcl_Interp *interp, int result); +static Tcl_NRPostProc IfConditionCallback; static int InfoArgsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int InfoBodyCmd(ClientData dummy, Tcl_Interp *interp, @@ -1150,41 +1142,38 @@ InfoFrameCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Interp *iPtr = (Interp *) interp; - int level, topLevel, code = TCL_OK; - CmdFrame *runPtr, *framePtr; + int level, code = TCL_OK; + CmdFrame *framePtr, **cmdFramePtrPtr = &iPtr->cmdFramePtr; CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; + int topLevel = 0; if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "?number?"); return TCL_ERROR; } - topLevel = ((iPtr->cmdFramePtr == NULL) - ? 0 - : iPtr->cmdFramePtr->level); - - if (corPtr) { - /* - * A coroutine: must fix the level computations AND the cmdFrame chain, - * which is interrupted at the base. - */ - - CmdFrame *lastPtr = NULL; - - runPtr = iPtr->cmdFramePtr; + while (corPtr) { + while (*cmdFramePtrPtr) { + topLevel++; + cmdFramePtrPtr = &((*cmdFramePtrPtr)->nextPtr); + } + if (corPtr->caller.cmdFramePtr) { + *cmdFramePtrPtr = corPtr->caller.cmdFramePtr; + } + corPtr = corPtr->callerEEPtr->corPtr; + } + topLevel += (*cmdFramePtrPtr)->level; - /* TODO - deal with overflow */ - topLevel += corPtr->caller.cmdFramePtr->level; - while (runPtr) { - runPtr->level += corPtr->caller.cmdFramePtr->level; - lastPtr = runPtr; - runPtr = runPtr->nextPtr; + if (topLevel != iPtr->cmdFramePtr->level) { + framePtr = iPtr->cmdFramePtr; + while (framePtr) { + framePtr->level = topLevel--; + framePtr = framePtr->nextPtr; } - if (lastPtr) { - lastPtr->nextPtr = corPtr->caller.cmdFramePtr; - } else { - iPtr->cmdFramePtr = corPtr->caller.cmdFramePtr; + if (topLevel) { + Tcl_Panic("Broken frame level calculation"); } + topLevel = iPtr->cmdFramePtr->level; } if (objc == 1) { @@ -1209,7 +1198,7 @@ InfoFrameCmd( levelError: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad level \"%s\"", TclGetString(objv[1]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_FRAME", + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", TclGetString(objv[1]), NULL); code = TCL_ERROR; goto done; @@ -1234,20 +1223,27 @@ InfoFrameCmd( Tcl_SetObjResult(interp, TclInfoFrame(interp, framePtr)); done: - if (corPtr) { + cmdFramePtrPtr = &iPtr->cmdFramePtr; + corPtr = iPtr->execEnvPtr->corPtr; + while (corPtr) { + CmdFrame *endPtr = corPtr->caller.cmdFramePtr; + + if (endPtr) { + if (*cmdFramePtrPtr == endPtr) { + *cmdFramePtrPtr = NULL; + } else { + CmdFrame *runPtr = *cmdFramePtrPtr; - if (iPtr->cmdFramePtr == corPtr->caller.cmdFramePtr) { - iPtr->cmdFramePtr = NULL; - } else { - runPtr = iPtr->cmdFramePtr; - while (runPtr->nextPtr != corPtr->caller.cmdFramePtr) { - runPtr->level -= corPtr->caller.cmdFramePtr->level; - runPtr = runPtr->nextPtr; + while (runPtr->nextPtr != endPtr) { + runPtr->level -= endPtr->level; + runPtr = runPtr->nextPtr; + } + runPtr->level = 1; + runPtr->nextPtr = NULL; } - runPtr->level = 1; - runPtr->nextPtr = NULL; + cmdFramePtrPtr = &corPtr->caller.cmdFramePtr; } - + corPtr = corPtr->callerEEPtr->corPtr; } return code; } @@ -1286,6 +1282,7 @@ TclInfoFrame( "eval", "eval", "eval", "precompiled", "source", "proc" }; Proc *procPtr = framePtr->framePtr ? framePtr->framePtr->procPtr : NULL; + int needsFree = -1; /* * Pull the information and construct the dictionary to return, as list. @@ -1310,7 +1307,7 @@ TclInfoFrame( } else { ADD_PAIR("line", Tcl_NewIntObj(1)); } - ADD_PAIR("cmd", Tcl_NewStringObj(framePtr->cmd, framePtr->len)); + ADD_PAIR("cmd", TclGetSourceFromFrame(framePtr, 0, NULL)); break; case TCL_LOCATION_PREBC: @@ -1358,7 +1355,10 @@ TclInfoFrame( Tcl_DecrRefCount(fPtr->data.eval.path); } - ADD_PAIR("cmd", Tcl_NewStringObj(fPtr->cmd, fPtr->len)); + ADD_PAIR("cmd", TclGetSourceFromFrame(fPtr, 0, NULL)); + if (fPtr->cmdObj && framePtr->cmdObj == NULL) { + needsFree = lc - 1; + } TclStackFree(interp, fPtr); break; } @@ -1377,7 +1377,7 @@ TclInfoFrame( * the result list object. */ - ADD_PAIR("cmd", Tcl_NewStringObj(framePtr->cmd, framePtr->len)); + ADD_PAIR("cmd", TclGetSourceFromFrame(framePtr, 0, NULL)); break; case TCL_LOCATION_PROC: @@ -1446,7 +1446,11 @@ TclInfoFrame( } } - return Tcl_NewListObj(lc, lv); + tmpObj = Tcl_NewListObj(lc, lv); + if (needsFree >= 0) { + Tcl_DecrRefCount(lv[needsFree]); + } + return tmpObj; } /* @@ -1629,7 +1633,7 @@ InfoLevelCmd( levelError: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad level \"%s\"", TclGetString(objv[1]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_LEVEL", + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", TclGetString(objv[1]), NULL); return TCL_ERROR; } @@ -1669,7 +1673,7 @@ InfoLibraryCmd( return TCL_ERROR; } - libDirName = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY); + libDirName = Tcl_GetVar2(interp, "tcl_library", NULL, TCL_GLOBAL_ONLY); if (libDirName != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj(libDirName, -1)); return TCL_OK; @@ -1709,19 +1713,24 @@ InfoLoadedCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - const char *interpName; + const char *interpName, *packageName; - if ((objc != 1) && (objc != 2)) { - Tcl_WrongNumArgs(interp, 1, objv, "?interp?"); + if (objc > 3) { + Tcl_WrongNumArgs(interp, 1, objv, "?interp? ?packageName?"); return TCL_ERROR; } - if (objc == 1) { /* Get loaded pkgs in all interpreters. */ + if (objc < 2) { /* Get loaded pkgs in all interpreters. */ interpName = NULL; } else { /* Get pkgs just in specified interp. */ interpName = TclGetString(objv[1]); } - return TclGetLoadedPackages(interp, interpName); + if (objc < 3) { /* Get loaded files in all packages. */ + packageName = NULL; + } else { /* Get pkgs just in specified interp. */ + packageName = TclGetString(objv[2]); + } + return TclGetLoadedPackagesEx(interp, interpName, packageName); } /* @@ -1795,7 +1804,7 @@ InfoPatchLevelCmd( return TCL_ERROR; } - patchlevel = Tcl_GetVar(interp, "tcl_patchLevel", + patchlevel = Tcl_GetVar2(interp, "tcl_patchLevel", NULL, (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); if (patchlevel != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj(patchlevel, -1)); @@ -2191,8 +2200,8 @@ Tcl_JoinObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { - int listLen, i; - Tcl_Obj *resObjPtr, *joinObjPtr, **elemPtrs; + int length, listLen; + Tcl_Obj *resObjPtr = NULL, *joinObjPtr, **elemPtrs; if ((objc < 2) || (objc > 3)) { Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?"); @@ -2209,19 +2218,47 @@ Tcl_JoinObjCmd( return TCL_ERROR; } + if (listLen == 0) { + /* No elements to join; default empty result is correct. */ + return TCL_OK; + } + if (listLen == 1) { + /* One element; return it */ + Tcl_SetObjResult(interp, elemPtrs[0]); + return TCL_OK; + } + joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2]; Tcl_IncrRefCount(joinObjPtr); - resObjPtr = Tcl_NewObj(); - for (i = 0; i < listLen; i++) { - if (i > 0) { - Tcl_AppendObjToObj(resObjPtr, joinObjPtr); + (void) Tcl_GetStringFromObj(joinObjPtr, &length); + if (length == 0) { + resObjPtr = TclStringCat(interp, listLen, elemPtrs, 0); + } else { + int i; + + resObjPtr = Tcl_NewObj(); + for (i = 0; i < listLen; i++) { + if (i > 0) { + + /* + * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT** + * to shimmer joinObjPtr. If it did, then the case where + * objv[1] and objv[2] are the same value would not be safe. + * Accessing elemPtrs would crash. + */ + + Tcl_AppendObjToObj(resObjPtr, joinObjPtr); + } + Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]); } - Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]); } Tcl_DecrRefCount(joinObjPtr); - Tcl_SetObjResult(interp, resObjPtr); - return TCL_OK; + if (resObjPtr) { + Tcl_SetObjResult(interp, resObjPtr); + return TCL_OK; + } + return TCL_ERROR; } /* @@ -2425,7 +2462,10 @@ Tcl_LinsertObjCmd( Tcl_ListObjAppendElement(NULL, listPtr, objv[3]); } else { - Tcl_ListObjReplace(NULL, listPtr, index, 0, (objc-3), &(objv[3])); + if (TCL_OK != Tcl_ListObjReplace(interp, listPtr, index, 0, + (objc-3), &(objv[3]))) { + return TCL_ERROR; + } } /* @@ -2543,7 +2583,6 @@ Tcl_LrangeObjCmd( register Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Obj **elemPtrs; int listLen, first, last, result; if (objc != 4) { @@ -2561,55 +2600,14 @@ Tcl_LrangeObjCmd( if (result != TCL_OK) { return result; } - if (first < 0) { - first = 0; - } result = TclGetIntForIndexM(interp, objv[3], /*endValue*/ listLen - 1, &last); if (result != TCL_OK) { return result; } - if (last >= listLen) { - last = listLen - 1; - } - - if (first > last) { - /* - * Returning an empty list is easy. - */ - - return TCL_OK; - } - - result = TclListObjGetElements(interp, objv[1], &listLen, &elemPtrs); - if (result != TCL_OK) { - return result; - } - - if (Tcl_IsShared(objv[1]) || - ((ListRepPtr(objv[1])->refCount > 1))) { - Tcl_SetObjResult(interp, Tcl_NewListObj(last - first + 1, - &elemPtrs[first])); - } else { - /* - * In-place is possible. - */ - - if (last < (listLen - 1)) { - Tcl_ListObjReplace(interp, objv[1], last + 1, listLen - 1 - last, - 0, NULL); - } - - /* - * This one is not conditioned on (first > 0) in order to preserve the - * string-canonizing effect of [lrange 0 end]. - */ - - Tcl_ListObjReplace(interp, objv[1], 0, first, 0, NULL); - Tcl_SetObjResult(interp, objv[1]); - } + Tcl_SetObjResult(interp, TclListObjRange(objv[1], first, last)); return TCL_OK; } @@ -2698,7 +2696,7 @@ Tcl_LrepeatObjCmd( * number of times. */ - CLANG_ASSERT(dataArray); + CLANG_ASSERT(dataArray || totalElems == 0 ); if (objc == 1) { register Tcl_Obj *tmpPtr = objv[0]; @@ -2821,7 +2819,10 @@ Tcl_LreplaceObjCmd( * optimize this case away. */ - Tcl_ListObjReplace(NULL, listPtr, first, numToDelete, objc-4, objv+4); + if (TCL_OK != Tcl_ListObjReplace(interp, listPtr, first, numToDelete, + objc-4, objv+4)) { + return TCL_ERROR; + } /* * Set the interpreter's object result. @@ -2935,19 +2936,21 @@ Tcl_LsearchObjCmd( Tcl_Obj *const objv[]) /* Argument values. */ { const char *bytes, *patternBytes; - int i, match, index, result, listc, length, elemLen, bisect; - int dataType, isIncreasing, lower, upper, patInt, objInt, offset; + int i, match, index, result=TCL_OK, listc, length, elemLen, bisect; + int allocatedIndexVector = 0; + int dataType, isIncreasing, lower, upper, start, groupSize, groupOffset; + Tcl_WideInt patWide, objWide; int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase; double patDouble, objDouble; SortInfo sortInfo; Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr; - SortStrCmpFn_t strCmpFn = strcmp; + SortStrCmpFn_t strCmpFn = TclUtfCmp; Tcl_RegExp regexp = NULL; static const char *const options[] = { "-all", "-ascii", "-bisect", "-decreasing", "-dictionary", "-exact", "-glob", "-increasing", "-index", "-inline", "-integer", "-nocase", "-not", - "-real", "-regexp", "-sorted", "-start", + "-real", "-regexp", "-sorted", "-start", "-stride", "-subindices", NULL }; enum options { @@ -2955,7 +2958,7 @@ Tcl_LsearchObjCmd( LSEARCH_DICTIONARY, LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_INCREASING, LSEARCH_INDEX, LSEARCH_INLINE, LSEARCH_INTEGER, LSEARCH_NOCASE, LSEARCH_NOT, LSEARCH_REAL, LSEARCH_REGEXP, LSEARCH_SORTED, - LSEARCH_START, LSEARCH_SUBINDICES + LSEARCH_START, LSEARCH_STRIDE, LSEARCH_SUBINDICES }; enum datatypes { ASCII, DICTIONARY, INTEGER, REAL @@ -2975,7 +2978,9 @@ Tcl_LsearchObjCmd( bisect = 0; listPtr = NULL; startPtr = NULL; - offset = 0; + groupSize = 1; + groupOffset = 0; + start = 0; noCase = 0; sortInfo.compareCmdPtr = NULL; sortInfo.isIncreasing = 1; @@ -2993,9 +2998,6 @@ Tcl_LsearchObjCmd( for (i = 1; i < objc-2; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) != TCL_OK) { - if (startPtr != NULL) { - Tcl_DecrRefCount(startPtr); - } result = TCL_ERROR; goto done; } @@ -3060,6 +3062,7 @@ Tcl_LsearchObjCmd( if (startPtr != NULL) { Tcl_DecrRefCount(startPtr); + startPtr = NULL; } if (i > objc-4) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -3080,25 +3083,47 @@ Tcl_LsearchObjCmd( startPtr = Tcl_DuplicateObj(objv[i]); } else { startPtr = objv[i]; - Tcl_IncrRefCount(startPtr); } + Tcl_IncrRefCount(startPtr); + break; + case LSEARCH_STRIDE: /* -stride */ + if (i > objc-4) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\"-stride\" option must be " + "followed by stride length", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); + result = TCL_ERROR; + goto done; + } + if (Tcl_GetIntFromObj(interp, objv[i+1], &groupSize) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + if (groupSize < 1) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "stride length must be at least 1", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", + "BADSTRIDE", NULL); + result = TCL_ERROR; + goto done; + } + i++; break; case LSEARCH_INDEX: { /* -index */ Tcl_Obj **indices; int j; - if (sortInfo.indexc > 1) { + if (allocatedIndexVector) { TclStackFree(interp, sortInfo.indexv); + allocatedIndexVector = 0; } if (i > objc-4) { - if (startPtr != NULL) { - Tcl_DecrRefCount(startPtr); - } Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-index\" option must be followed by list index", -1)); Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); - return TCL_ERROR; + result = TCL_ERROR; + goto done; } /* @@ -3110,10 +3135,8 @@ Tcl_LsearchObjCmd( i++; if (TclListObjGetElements(interp, objv[i], &sortInfo.indexc, &indices) != TCL_OK) { - if (startPtr != NULL) { - Tcl_DecrRefCount(startPtr); - } - return TCL_ERROR; + result = TCL_ERROR; + goto done; } switch (sortInfo.indexc) { case 0: @@ -3125,6 +3148,8 @@ Tcl_LsearchObjCmd( default: sortInfo.indexv = TclStackAlloc(interp, sizeof(int) * sortInfo.indexc); + allocatedIndexVector = 1; /* Cannot use indexc field, as it + * might be decreased by 1 later. */ } /* @@ -3134,13 +3159,26 @@ Tcl_LsearchObjCmd( */ for (j=0 ; j<sortInfo.indexc ; j++) { - if (TclGetIntForIndexM(interp, indices[j], SORTIDX_END, - &sortInfo.indexv[j]) != TCL_OK) { + int encoded = 0; + if (TclIndexEncode(interp, indices[j], TCL_INDEX_BEFORE, + TCL_INDEX_AFTER, &encoded) != TCL_OK) { + result = TCL_ERROR; + } + if ((encoded == TCL_INDEX_BEFORE) + || (encoded == TCL_INDEX_AFTER)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "index \"%s\" cannot select an element " + "from any list", Tcl_GetString(indices[j]))); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX" + "OUTOFRANGE", NULL); + result = TCL_ERROR; + } + if (result == TCL_ERROR) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (-index option item number %d)", j)); - result = TCL_ERROR; goto done; } + sortInfo.indexv[j] = encoded; } break; } @@ -3152,14 +3190,12 @@ Tcl_LsearchObjCmd( */ if (returnSubindices && sortInfo.indexc==0) { - if (startPtr != NULL) { - Tcl_DecrRefCount(startPtr); - } Tcl_SetObjResult(interp, Tcl_NewStringObj( "-subindices cannot be used without -index option", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", "BAD_OPTION_MIX", NULL); - return TCL_ERROR; + result = TCL_ERROR; + goto done; } if (bisect && (allMatches || negatedMatch)) { @@ -3167,7 +3203,8 @@ Tcl_LsearchObjCmd( "-bisect is not compatible with -all or -not", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", "BAD_OPTION_MIX", NULL); - return TCL_ERROR; + result = TCL_ERROR; + goto done; } if (mode == REGEXP) { @@ -3193,9 +3230,6 @@ Tcl_LsearchObjCmd( } if (regexp == NULL) { - if (startPtr != NULL) { - Tcl_DecrRefCount(startPtr); - } result = TCL_ERROR; goto done; } @@ -3208,24 +3242,64 @@ Tcl_LsearchObjCmd( result = TclListObjGetElements(interp, objv[objc - 2], &listc, &listv); if (result != TCL_OK) { - if (startPtr != NULL) { - Tcl_DecrRefCount(startPtr); - } goto done; } /* + * Check for sanity when grouping elements of the overall list together + * because of the -stride option. [TIP #351] + */ + + if (groupSize > 1) { + if (listc % groupSize) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "list size must be a multiple of the stride length", + -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", "BADSTRIDE", + NULL); + result = TCL_ERROR; + goto done; + } + if (sortInfo.indexc > 0) { + /* + * Use the first value in the list supplied to -index as the + * offset of the element within each group by which to sort. + */ + + groupOffset = TclIndexDecode(sortInfo.indexv[0], groupSize - 1); + if (groupOffset < 0 || groupOffset >= groupSize) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "when used with \"-stride\", the leading \"-index\"" + " value must be within the group", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", + "BADINDEX", NULL); + result = TCL_ERROR; + goto done; + } + if (sortInfo.indexc == 1) { + sortInfo.indexc = 0; + sortInfo.indexv = NULL; + } else { + sortInfo.indexc--; + + for (i = 0; i < sortInfo.indexc; i++) { + sortInfo.indexv[i] = sortInfo.indexv[i+1]; + } + } + } + } + + /* * Get the user-specified start offset. */ if (startPtr) { - result = TclGetIntForIndexM(interp, startPtr, listc-1, &offset); - Tcl_DecrRefCount(startPtr); + result = TclGetIntForIndexM(interp, startPtr, listc-1, &start); if (result != TCL_OK) { goto done; } - if (offset < 0) { - offset = 0; + if (start < 0) { + start = 0; } /* @@ -3233,16 +3307,21 @@ Tcl_LsearchObjCmd( * "did not match anything at all" result straight away. [Bug 1374778] */ - if (offset > listc-1) { - if (sortInfo.indexc > 1) { - TclStackFree(interp, sortInfo.indexv); - } + if (start > listc-1) { if (allMatches || inlineReturn) { Tcl_ResetResult(interp); } else { Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); } - return TCL_OK; + goto done; + } + + /* + * If start points within a group, it points to the start of the group. + */ + + if (groupSize > 1) { + start -= (start % groupSize); } } @@ -3255,7 +3334,7 @@ Tcl_LsearchObjCmd( patternBytes = TclGetStringFromObj(patObj, &length); break; case INTEGER: - result = TclGetIntFromObj(interp, patObj, &patInt); + result = TclGetWideIntFromObj(interp, patObj, &patWide); if (result != TCL_OK) { goto done; } @@ -3301,18 +3380,23 @@ Tcl_LsearchObjCmd( * sense in doing this when the match sense is inverted. */ - lower = offset - 1; + /* + * With -stride, lower, upper and i are kept as multiples of groupSize. + */ + + lower = start - groupSize; upper = listc; - while (lower + 1 != upper && sortInfo.resultCode == TCL_OK) { + while (lower + groupSize != upper && sortInfo.resultCode == TCL_OK) { i = (lower + upper)/2; + i -= i % groupSize; if (sortInfo.indexc != 0) { - itemPtr = SelectObjFromSublist(listv[i], &sortInfo); + itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo); if (sortInfo.resultCode != TCL_OK) { result = sortInfo.resultCode; goto done; } } else { - itemPtr = listv[i]; + itemPtr = listv[i+groupOffset]; } switch ((enum datatypes) dataType) { case ASCII: @@ -3324,13 +3408,13 @@ Tcl_LsearchObjCmd( match = DictionaryCompare(patternBytes, bytes); break; case INTEGER: - result = TclGetIntFromObj(interp, itemPtr, &objInt); + result = TclGetWideIntFromObj(interp, itemPtr, &objWide); if (result != TCL_OK) { goto done; } - if (patInt == objInt) { + if (patWide == objWide) { match = 0; - } else if (patInt < objInt) { + } else if (patWide < objWide) { match = -1; } else { match = 1; @@ -3401,10 +3485,10 @@ Tcl_LsearchObjCmd( if (allMatches) { listPtr = Tcl_NewListObj(0, NULL); } - for (i = offset; i < listc; i++) { + for (i = start; i < listc; i += groupSize) { match = 0; if (sortInfo.indexc != 0) { - itemPtr = SelectObjFromSublist(listv[i], &sortInfo); + itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo); if (sortInfo.resultCode != TCL_OK) { if (listPtr != NULL) { Tcl_DecrRefCount(listPtr); @@ -3413,7 +3497,7 @@ Tcl_LsearchObjCmd( goto done; } } else { - itemPtr = listv[i]; + itemPtr = listv[i+groupOffset]; } switch (mode) { @@ -3443,14 +3527,14 @@ Tcl_LsearchObjCmd( break; case INTEGER: - result = TclGetIntFromObj(interp, itemPtr, &objInt); + result = TclGetWideIntFromObj(interp, itemPtr, &objWide); if (result != TCL_OK) { if (listPtr != NULL) { Tcl_DecrRefCount(listPtr); } goto done; } - match = (objInt == patInt); + match = (objWide == patWide); break; case REAL: @@ -3503,18 +3587,23 @@ Tcl_LsearchObjCmd( */ if (returnSubindices && (sortInfo.indexc != 0)) { - itemPtr = SelectObjFromSublist(listv[i], &sortInfo); + itemPtr = SelectObjFromSublist(listv[i+groupOffset], + &sortInfo); + Tcl_ListObjAppendElement(interp, listPtr, itemPtr); + } else if (groupSize > 1) { + Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0, + groupSize, &listv[i]); } else { itemPtr = listv[i]; + Tcl_ListObjAppendElement(interp, listPtr, itemPtr); } - Tcl_ListObjAppendElement(interp, listPtr, itemPtr); } else if (returnSubindices) { int j; - itemPtr = Tcl_NewIntObj(i); + itemPtr = Tcl_NewIntObj(i+groupOffset); for (j=0 ; j<sortInfo.indexc ; j++) { - Tcl_ListObjAppendElement(interp, itemPtr, - Tcl_NewIntObj(sortInfo.indexv[j])); + Tcl_ListObjAppendElement(interp, itemPtr, Tcl_NewIntObj( + TclIndexDecode(sortInfo.indexv[j], listc))); } Tcl_ListObjAppendElement(interp, listPtr, itemPtr); } else { @@ -3533,10 +3622,10 @@ Tcl_LsearchObjCmd( if (returnSubindices) { int j; - itemPtr = Tcl_NewIntObj(index); + itemPtr = Tcl_NewIntObj(index+groupOffset); for (j=0 ; j<sortInfo.indexc ; j++) { - Tcl_ListObjAppendElement(interp, itemPtr, - Tcl_NewIntObj(sortInfo.indexv[j])); + Tcl_ListObjAppendElement(interp, itemPtr, Tcl_NewIntObj( + TclIndexDecode(sortInfo.indexv[j], listc))); } Tcl_SetObjResult(interp, itemPtr); } else { @@ -3550,7 +3639,14 @@ Tcl_LsearchObjCmd( Tcl_SetObjResult(interp, Tcl_NewObj()); } else { - Tcl_SetObjResult(interp, listv[index]); + if (returnSubindices) { + Tcl_SetObjResult(interp, SelectObjFromSublist(listv[i+groupOffset], + &sortInfo)); + } else if (groupSize > 1) { + Tcl_SetObjResult(interp, Tcl_NewListObj(groupSize, &listv[index])); + } else { + Tcl_SetObjResult(interp, listv[index]); + } } result = TCL_OK; @@ -3559,7 +3655,10 @@ Tcl_LsearchObjCmd( */ done: - if (sortInfo.indexc > 1) { + if (startPtr != NULL) { + Tcl_DecrRefCount(startPtr); + } + if (allocatedIndexVector) { TclStackFree(interp, sortInfo.indexv); } return result; @@ -3678,7 +3777,7 @@ Tcl_LsortObjCmd( int sortMode = SORTMODE_ASCII; int group, groupSize, groupOffset, idx, allocatedIndexVector = 0; Tcl_Obj *resultPtr, *cmdPtr, **listObjPtrs, *listObj, *indexPtr; - SortElement *elementArray, *elementPtr; + SortElement *elementArray = NULL, *elementPtr; SortInfo sortInfo; /* Information about this sort that needs to * be passed to the comparison function. */ # define NUM_LISTS 30 @@ -3724,7 +3823,7 @@ Tcl_LsortObjCmd( if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, &index) != TCL_OK) { sortInfo.resultCode = TCL_ERROR; - goto done2; + goto done; } switch ((enum Lsort_Switches) index) { case LSORT_ASCII: @@ -3737,7 +3836,7 @@ Tcl_LsortObjCmd( "by comparison command", -1)); Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); sortInfo.resultCode = TCL_ERROR; - goto done2; + goto done; } sortInfo.sortMode = SORTMODE_COMMAND; cmdPtr = objv[i+1]; @@ -3753,7 +3852,7 @@ Tcl_LsortObjCmd( sortInfo.isIncreasing = 1; break; case LSORT_INDEX: { - int indexc, dummy; + int indexc; Tcl_Obj **indexv; if (i == objc-2) { @@ -3762,12 +3861,12 @@ Tcl_LsortObjCmd( -1)); Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); sortInfo.resultCode = TCL_ERROR; - goto done2; + goto done; } if (TclListObjGetElements(interp, objv[i+1], &indexc, &indexv) != TCL_OK) { sortInfo.resultCode = TCL_ERROR; - goto done2; + goto done; } /* @@ -3779,12 +3878,24 @@ Tcl_LsortObjCmd( */ for (j=0 ; j<indexc ; j++) { - if (TclGetIntForIndexM(interp, indexv[j], SORTIDX_END, - &dummy) != TCL_OK) { + int encoded = 0; + int result = TclIndexEncode(interp, indexv[j], + TCL_INDEX_BEFORE, TCL_INDEX_AFTER, &encoded); + + if ((result == TCL_OK) && ((encoded == TCL_INDEX_BEFORE) + || (encoded == TCL_INDEX_AFTER))) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "index \"%s\" cannot select an element " + "from any list", Tcl_GetString(indexv[j]))); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX" + "OUTOFRANGE", NULL); + result = TCL_ERROR; + } + if (result == TCL_ERROR) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (-index option item number %d)", j)); sortInfo.resultCode = TCL_ERROR; - goto done2; + goto done; } } indexPtr = objv[i+1]; @@ -3813,11 +3924,11 @@ Tcl_LsortObjCmd( "followed by stride length", -1)); Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); sortInfo.resultCode = TCL_ERROR; - goto done2; + goto done; } if (Tcl_GetIntFromObj(interp, objv[i+1], &groupSize) != TCL_OK) { sortInfo.resultCode = TCL_ERROR; - goto done2; + goto done; } if (groupSize < 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -3825,7 +3936,7 @@ Tcl_LsortObjCmd( Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", "BADSTRIDE", NULL); sortInfo.resultCode = TCL_ERROR; - goto done2; + goto done; } group = 1; i++; @@ -3860,8 +3971,8 @@ Tcl_LsortObjCmd( * might be decreased by 1 later. */ } for (j=0 ; j<sortInfo.indexc ; j++) { - TclGetIntForIndexM(interp, indexv[j], SORTIDX_END, - &sortInfo.indexv[j]); + /* Prescreened values, no errors or out of range possible */ + TclIndexEncode(NULL, indexv[j], 0, 0, &sortInfo.indexv[j]); } } @@ -3880,7 +3991,7 @@ Tcl_LsortObjCmd( listObj = TclListObjCopy(interp, listObj); if (listObj == NULL) { sortInfo.resultCode = TCL_ERROR; - goto done2; + goto done; } /* @@ -3898,7 +4009,7 @@ Tcl_LsortObjCmd( Tcl_IncrRefCount(newObjPtr); TclDecrRefCount(newObjPtr); sortInfo.resultCode = TCL_ERROR; - goto done2; + goto done; } Tcl_ListObjAppendElement(interp, newCommandPtr, Tcl_NewObj()); sortInfo.compareCmdPtr = newCommandPtr; @@ -3932,10 +4043,7 @@ Tcl_LsortObjCmd( * offset of the element within each group by which to sort. */ - groupOffset = sortInfo.indexv[0]; - if (groupOffset <= SORTIDX_END) { - groupOffset = (groupOffset - SORTIDX_END) + groupSize - 1; - } + groupOffset = TclIndexDecode(sortInfo.indexv[0], groupSize - 1); if (groupOffset < 0 || groupOffset >= groupSize) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "when used with \"-stride\", the leading \"-index\"" @@ -3954,6 +4062,9 @@ Tcl_LsortObjCmd( /* * Do not shrink the actual memory block used; that doesn't * work with TclStackAlloc-allocated memory. [Bug 2918962] + * + * TODO: Consider a pointer increment to replace this + * array shift. */ for (i = 0; i < sortInfo.indexc; i++) { @@ -3991,7 +4102,7 @@ Tcl_LsortObjCmd( * begins sorting it into the sublists as it appears. */ - elementArray = TclStackAlloc(interp, length * sizeof(SortElement)); + elementArray = ckalloc(length * sizeof(SortElement)); for (i=0; i < length; i++){ idx = groupSize * i + groupOffset; @@ -4001,7 +4112,7 @@ Tcl_LsortObjCmd( */ indexPtr = SelectObjFromSublist(listObjPtrs[idx], &sortInfo); if (sortInfo.resultCode != TCL_OK) { - goto done1; + goto done; } } else { indexPtr = listObjPtrs[idx]; @@ -4014,20 +4125,20 @@ Tcl_LsortObjCmd( if (sortMode == SORTMODE_ASCII) { elementArray[i].collationKey.strValuePtr = TclGetString(indexPtr); } else if (sortMode == SORTMODE_INTEGER) { - long a; + Tcl_WideInt a; - if (TclGetLongFromObj(sortInfo.interp, indexPtr, &a) != TCL_OK) { + if (TclGetWideIntFromObj(sortInfo.interp, indexPtr, &a) != TCL_OK) { sortInfo.resultCode = TCL_ERROR; - goto done1; + goto done; } - elementArray[i].collationKey.intValue = a; + elementArray[i].collationKey.wideValue = a; } else if (sortMode == SORTMODE_REAL) { double a; if (Tcl_GetDoubleFromObj(sortInfo.interp, indexPtr, &a) != TCL_OK) { sortInfo.resultCode = TCL_ERROR; - goto done1; + goto done; } elementArray[i].collationKey.doubleValue = a; } else { @@ -4114,19 +4225,18 @@ Tcl_LsortObjCmd( Tcl_SetObjResult(interp, resultPtr); } - done1: - TclStackFree(interp, elementArray); - done: if (sortMode == SORTMODE_COMMAND) { TclDecrRefCount(sortInfo.compareCmdPtr); TclDecrRefCount(listObj); sortInfo.compareCmdPtr = NULL; } - done2: if (allocatedIndexVector) { TclStackFree(interp, sortInfo.indexv); } + if (elementArray) { + ckfree(elementArray); + } return sortInfo.resultCode; } @@ -4260,7 +4370,7 @@ SortCompare( int order = 0; if (infoPtr->sortMode == SORTMODE_ASCII) { - order = strcmp(elemPtr1->collationKey.strValuePtr, + order = TclUtfCmp(elemPtr1->collationKey.strValuePtr, elemPtr2->collationKey.strValuePtr); } else if (infoPtr->sortMode == SORTMODE_ASCII_NC) { order = TclUtfCasecmp(elemPtr1->collationKey.strValuePtr, @@ -4269,10 +4379,10 @@ SortCompare( order = DictionaryCompare(elemPtr1->collationKey.strValuePtr, elemPtr2->collationKey.strValuePtr); } else if (infoPtr->sortMode == SORTMODE_INTEGER) { - long a, b; + Tcl_WideInt a, b; - a = elemPtr1->collationKey.intValue; - b = elemPtr2->collationKey.intValue; + a = elemPtr1->collationKey.wideValue; + b = elemPtr2->collationKey.wideValue; order = ((a >= b) - (a <= b)); } else if (infoPtr->sortMode == SORTMODE_REAL) { double a, b; @@ -4367,7 +4477,7 @@ static int DictionaryCompare( const char *left, const char *right) /* The strings to compare. */ { - Tcl_UniChar uniLeft, uniRight, uniLeftLower, uniRightLower; + Tcl_UniChar uniLeft = 0, uniRight = 0, uniLeftLower, uniRightLower; int diff, zeros; int secondaryDiff = 0; @@ -4436,8 +4546,8 @@ DictionaryCompare( */ if ((*left != '\0') && (*right != '\0')) { - left += Tcl_UtfToUniChar(left, &uniLeft); - right += Tcl_UtfToUniChar(right, &uniRight); + left += TclUtfToUniChar(left, &uniLeft); + right += TclUtfToUniChar(right, &uniRight); /* * Convert both chars to lower for the comparison, because @@ -4523,15 +4633,8 @@ SelectObjFromSublist( infoPtr->resultCode = TCL_ERROR; return NULL; } - index = infoPtr->indexv[i]; - - /* - * Adjust for end-based indexing. - */ - if (index < SORTIDX_NONE) { - index += listLen + 1; - } + index = TclIndexDecode(infoPtr->indexv[i], listLen - 1); if (Tcl_ListObjIndex(infoPtr->interp, objPtr, index, ¤tObj) != TCL_OK) { diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 5087fbb..0bd6cb4 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -18,17 +18,14 @@ #include "tclInt.h" #include "tclRegexp.h" +#include "tclStringTrim.h" static inline Tcl_Obj * During(Tcl_Interp *interp, int resultCode, Tcl_Obj *oldOptions, Tcl_Obj *errorInfo); -static int SwitchPostProc(ClientData data[], Tcl_Interp *interp, - int result); -static int TryPostBody(ClientData data[], Tcl_Interp *interp, - int result); -static int TryPostFinal(ClientData data[], Tcl_Interp *interp, - int result); -static int TryPostHandler(ClientData data[], Tcl_Interp *interp, - int result); +static Tcl_NRPostProc SwitchPostProc; +static Tcl_NRPostProc TryPostBody; +static Tcl_NRPostProc TryPostFinal; +static Tcl_NRPostProc TryPostHandler; static int UniCharIsAscii(int character); static int UniCharIsHexDigit(int character); @@ -37,32 +34,33 @@ static int UniCharIsHexDigit(int character); * UTF-8 literal string containing all Unicode space characters [TIP #413] */ -#define DEFAULT_TRIM_SET \ - "\x09\x0a\x0b\x0c\x0d " /* ASCII */\ - "\xc0\x80" /* nul (U+0000) */\ - "\xc2\x85" /* next line (U+0085) */\ - "\xc2\xa0" /* non-breaking space (U+00a0) */\ - "\xe1\x9a\x80" /* ogham space mark (U+1680) */ \ - "\xe1\xa0\x8e" /* mongolian vowel separator (U+180e) */\ - "\xe2\x80\x80" /* en quad (U+2000) */\ - "\xe2\x80\x81" /* em quad (U+2001) */\ - "\xe2\x80\x82" /* en space (U+2002) */\ - "\xe2\x80\x83" /* em space (U+2003) */\ - "\xe2\x80\x84" /* three-per-em space (U+2004) */\ - "\xe2\x80\x85" /* four-per-em space (U+2005) */\ - "\xe2\x80\x86" /* six-per-em space (U+2006) */\ - "\xe2\x80\x87" /* figure space (U+2007) */\ - "\xe2\x80\x88" /* punctuation space (U+2008) */\ - "\xe2\x80\x89" /* thin space (U+2009) */\ - "\xe2\x80\x8a" /* hair space (U+200a) */\ - "\xe2\x80\x8b" /* zero width space (U+200b) */\ - "\xe2\x80\xa8" /* line separator (U+2028) */\ - "\xe2\x80\xa9" /* paragraph separator (U+2029) */\ - "\xe2\x80\xaf" /* narrow no-break space (U+202f) */\ - "\xe2\x81\x9f" /* medium mathematical space (U+205f) */\ - "\xe2\x81\xa0" /* word joiner (U+2060) */\ - "\xe3\x80\x80" /* ideographic space (U+3000) */\ +const char tclDefaultTrimSet[] = + "\x09\x0a\x0b\x0c\x0d " /* ASCII */ + "\xc0\x80" /* nul (U+0000) */ + "\xc2\x85" /* next line (U+0085) */ + "\xc2\xa0" /* non-breaking space (U+00a0) */ + "\xe1\x9a\x80" /* ogham space mark (U+1680) */ + "\xe1\xa0\x8e" /* mongolian vowel separator (U+180e) */ + "\xe2\x80\x80" /* en quad (U+2000) */ + "\xe2\x80\x81" /* em quad (U+2001) */ + "\xe2\x80\x82" /* en space (U+2002) */ + "\xe2\x80\x83" /* em space (U+2003) */ + "\xe2\x80\x84" /* three-per-em space (U+2004) */ + "\xe2\x80\x85" /* four-per-em space (U+2005) */ + "\xe2\x80\x86" /* six-per-em space (U+2006) */ + "\xe2\x80\x87" /* figure space (U+2007) */ + "\xe2\x80\x88" /* punctuation space (U+2008) */ + "\xe2\x80\x89" /* thin space (U+2009) */ + "\xe2\x80\x8a" /* hair space (U+200a) */ + "\xe2\x80\x8b" /* zero width space (U+200b) */ + "\xe2\x80\xa8" /* line separator (U+2028) */ + "\xe2\x80\xa9" /* paragraph separator (U+2029) */ + "\xe2\x80\xaf" /* narrow no-break space (U+202f) */ + "\xe2\x81\x9f" /* medium mathematical space (U+205f) */ + "\xe2\x81\xa0" /* word joiner (U+2060) */ + "\xe3\x80\x80" /* ideographic space (U+3000) */ "\xef\xbb\xbf" /* zero width no-break space (U+feff) */ +; /* *---------------------------------------------------------------------- @@ -159,7 +157,7 @@ Tcl_RegexpObjCmd( if (name[0] != '-') { break; } - if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT, + if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", TCL_EXACT, &index) != TCL_OK) { goto optionError; } @@ -215,7 +213,7 @@ Tcl_RegexpObjCmd( endOfForLoop: if ((objc - i) < (2 - about)) { Tcl_WrongNumArgs(interp, 1, objv, - "?-switch ...? exp string ?matchVar? ?subMatchVar ...?"); + "?-option ...? exp string ?matchVar? ?subMatchVar ...?"); goto optionError; } objc -= i; @@ -229,6 +227,8 @@ Tcl_RegexpObjCmd( if (doinline && ((objc - 2) != 0)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "regexp match variables not allowed when using -inline", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "REGEXP", + "MIX_VAR_INLINE", NULL); goto optionError; } @@ -309,7 +309,7 @@ Tcl_RegexpObjCmd( eflags = 0; } else if (offset > stringLength) { eflags = TCL_REG_NOTBOL; - } else if (Tcl_GetUniChar(objPtr, offset-1) == (Tcl_UniChar)'\n') { + } else if (Tcl_GetUniChar(objPtr, offset-1) == '\n') { eflags = 0; } else { eflags = TCL_REG_NOTBOL; @@ -323,7 +323,7 @@ Tcl_RegexpObjCmd( if (match == 0) { /* - * We want to set the value of the intepreter result only when + * We want to set the value of the interpreter result only when * this is the first time through the loop. */ @@ -487,26 +487,27 @@ Tcl_RegsubObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { int idx, result, cflags, all, wlen, wsublen, numMatches, offset; - int start, end, subStart, subEnd, match; + int start, end, subStart, subEnd, match, command, numParts; Tcl_RegExp regExpr; Tcl_RegExpInfo info; Tcl_Obj *resultPtr, *subPtr, *objPtr, *startIndex = NULL; - Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec, *wend; + Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec = 0, *wend; static const char *const options[] = { - "-all", "-nocase", "-expanded", - "-line", "-linestop", "-lineanchor", "-start", + "-all", "-command", "-expanded", "-line", + "-linestop", "-lineanchor", "-nocase", "-start", "--", NULL }; enum options { - REGSUB_ALL, REGSUB_NOCASE, REGSUB_EXPANDED, - REGSUB_LINE, REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_START, + REGSUB_ALL, REGSUB_COMMAND, REGSUB_EXPANDED, REGSUB_LINE, + REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_NOCASE, REGSUB_START, REGSUB_LAST }; cflags = TCL_REG_ADVANCED; all = 0; offset = 0; + command = 0; resultPtr = NULL; for (idx = 1; idx < objc; idx++) { @@ -517,7 +518,7 @@ Tcl_RegsubObjCmd( if (name[0] != '-') { break; } - if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch", + if (Tcl_GetIndexFromObj(interp, objv[idx], options, "option", TCL_EXACT, &index) != TCL_OK) { goto optionError; } @@ -528,6 +529,9 @@ Tcl_RegsubObjCmd( case REGSUB_NOCASE: cflags |= TCL_REG_NOCASE; break; + case REGSUB_COMMAND: + command = 1; + break; case REGSUB_EXPANDED: cflags |= TCL_REG_EXPANDED; break; @@ -564,7 +568,7 @@ Tcl_RegsubObjCmd( endOfForLoop: if (objc-idx < 3 || objc-idx > 4) { Tcl_WrongNumArgs(interp, 1, objv, - "?-switch ...? exp string subSpec ?varName?"); + "?-option ...? exp string subSpec ?varName?"); optionError: if (startIndex) { Tcl_DecrRefCount(startIndex); @@ -585,7 +589,7 @@ Tcl_RegsubObjCmd( } } - if (all && (offset == 0) + if (all && (offset == 0) && (command == 0) && (strpbrk(TclGetString(objv[2]), "&\\") == NULL) && (strpbrk(TclGetString(objv[0]), "*+?{}()[].\\|^$") == NULL)) { /* @@ -593,9 +597,9 @@ Tcl_RegsubObjCmd( * slightly modified version of the one pair STR_MAP code. */ - int slen, nocase; + int slen, nocase, wsrclc; int (*strCmpFn)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long); - Tcl_UniChar *p, wsrclc; + Tcl_UniChar *p; numMatches = 0; nocase = (cflags & TCL_REG_NOCASE); @@ -661,6 +665,28 @@ Tcl_RegsubObjCmd( return TCL_ERROR; } + if (command) { + /* + * In command-prefix mode, we require that the third non-option + * argument be a list, so we enforce that here. Afterwards, we fetch + * the RE compilation again in case objv[0] and objv[2] are the same + * object. (If they aren't, that's cheap to do.) + */ + + if (Tcl_ListObjLength(interp, objv[2], &numParts) != TCL_OK) { + return TCL_ERROR; + } + if (numParts < 1) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command prefix must be a list of at least one element", + -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "REGSUB", + "CMDEMPTY", NULL); + return TCL_ERROR; + } + regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); + } + /* * Make sure to avoid problems where the objects are shared. This can * cause RegExpObj <> UnicodeObj shimmering that causes data corruption. @@ -678,7 +704,9 @@ Tcl_RegsubObjCmd( } else { subPtr = objv[2]; } - wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen); + if (!command) { + wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen); + } result = TCL_OK; @@ -737,6 +765,90 @@ Tcl_RegsubObjCmd( Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, start); /* + * In command-prefix mode, the substitutions are added as quoted + * arguments to the subSpec to form a command, that is then executed + * and the result used as the string to substitute in. Actually, + * everything is passed through Tcl_EvalObjv, as that's much faster. + */ + + if (command) { + Tcl_Obj **args = NULL, **parts; + int numArgs; + + Tcl_ListObjGetElements(interp, subPtr, &numParts, &parts); + numArgs = numParts + info.nsubs + 1; + args = ckalloc(sizeof(Tcl_Obj*) * numArgs); + memcpy(args, parts, sizeof(Tcl_Obj*) * numParts); + + for (idx = 0 ; idx <= info.nsubs ; idx++) { + subStart = info.matches[idx].start; + subEnd = info.matches[idx].end; + if ((subStart >= 0) && (subEnd >= 0)) { + args[idx + numParts] = Tcl_NewUnicodeObj( + wstring + offset + subStart, subEnd - subStart); + } else { + args[idx + numParts] = Tcl_NewObj(); + } + Tcl_IncrRefCount(args[idx + numParts]); + } + + /* + * At this point, we're locally holding the references to the + * argument words we added for this time round the loop, and the + * subPtr is holding the references to the words that the user + * supplied directly. None are zero-refcount, which is important + * because Tcl_EvalObjv is "hairy monster" in terms of refcount + * handling, being able to optionally add references to any of its + * argument words. We'll drop the local refs immediately + * afterwards; subPtr is handled in the main exit stanza. + */ + + result = Tcl_EvalObjv(interp, numArgs, args, 0); + for (idx = 0 ; idx <= info.nsubs ; idx++) { + TclDecrRefCount(args[idx + numParts]); + } + ckfree(args); + if (result != TCL_OK) { + if (result == TCL_ERROR) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (%s substitution computation script)", + options[REGSUB_COMMAND])); + } + goto done; + } + + Tcl_AppendObjToObj(resultPtr, Tcl_GetObjResult(interp)); + Tcl_ResetResult(interp); + + /* + * Refetch the unicode, in case the representation was smashed by + * the user code. + */ + + wstring = Tcl_GetUnicodeFromObj(objPtr, &wlen); + + offset += end; + if (end == 0 || start == end) { + /* + * Always consume at least one character of the input string + * in order to prevent infinite loops, even when we + * technically matched the empty string; we must not match + * again at the same spot. + */ + + if (offset < wlen) { + Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); + } + offset++; + } + if (all) { + continue; + } else { + break; + } + } + + /* * Append the subSpec argument to the variable, making appropriate * substitutions. This code is a bit hairy because of the backslash * conventions and because the code saves up ranges of characters in @@ -989,8 +1101,11 @@ TclNRSourceObjCmd( { const char *encodingName = NULL; Tcl_Obj *fileName; + int result; + void **pkgFiles = NULL; + void *names = NULL; - if (objc != 2 && objc !=4) { + if (objc < 2 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "?-encoding name? fileName"); return TCL_ERROR; } @@ -1008,9 +1123,30 @@ TclNRSourceObjCmd( return TCL_ERROR; } encodingName = TclGetString(objv[2]); - } + } else if (objc == 3) { + /* Handle undocumented -nopkg option. This should only be + * used by the internal ::tcl::Pkg::source utility function. */ + static const char *const nopkgoptions[] = { + "-nopkg", NULL + }; + int index; - return TclNREvalFile(interp, fileName, encodingName); + if (TCL_ERROR == Tcl_GetIndexFromObj(interp, objv[1], nopkgoptions, + "option", TCL_EXACT, &index)) { + return TCL_ERROR; + } + pkgFiles = Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + /* Make sure that during the following TclNREvalFile no filenames + * are recorded for inclusion in the "package files" command */ + names = *pkgFiles; + *pkgFiles = NULL; + } + result = TclNREvalFile(interp, fileName, encodingName); + if (pkgFiles) { + /* restore "tclPkgFiles" assocdata to how it was. */ + *pkgFiles = names; + } + return result; } /* @@ -1037,7 +1173,7 @@ Tcl_SplitObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar ch; + Tcl_UniChar ch = 0; int len; const char *splitChars; const char *stringPtr; @@ -1080,13 +1216,22 @@ Tcl_SplitObjCmd( Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS); for ( ; stringPtr < end; stringPtr += len) { + int fullchar; len = TclUtfToUniChar(stringPtr, &ch); + fullchar = ch; + +#if TCL_UTF_MAX <= 4 + if (!len) { + len += TclUtfToUniChar(stringPtr, &ch); + fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; + } +#endif /* * Assume Tcl_UniChar is an integral type... */ - hPtr = Tcl_CreateHashEntry(&charReuseTable, INT2PTR((int) ch), + hPtr = Tcl_CreateHashEntry(&charReuseTable, INT2PTR(fullchar), &isNew); if (isNew) { TclNewStringObj(objPtr, stringPtr, len); @@ -1122,7 +1267,7 @@ Tcl_SplitObjCmd( } else { const char *element, *p, *splitEnd; int splitLen; - Tcl_UniChar splitChar; + Tcl_UniChar splitChar = 0; /* * Normal case: split on any of a given set of characters. Discard @@ -1176,8 +1321,7 @@ StringFirstCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar *needleStr, *haystackStr; - int match, start, needleLen, haystackLen; + int start = 0; if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, @@ -1185,82 +1329,15 @@ StringFirstCmd( return TCL_ERROR; } - /* - * We are searching haystackStr for the sequence needleStr. - */ - - match = -1; - start = 0; - haystackLen = -1; - - needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen); - haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen); - if (objc == 4) { - /* - * If a startIndex is specified, we will need to fast forward to that - * point in the string before we think about a match. - */ + int size = Tcl_GetCharLength(objv[2]); - if (TclGetIntForIndexM(interp, objv[3], haystackLen-1, - &start) != TCL_OK){ + if (TCL_OK != TclGetIntForIndexM(interp, objv[3], size - 1, &start)) { return TCL_ERROR; } - - /* - * Reread to prevent shimmering problems. - */ - - needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen); - haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen); - - if (start >= haystackLen) { - goto str_first_done; - } else if (start > 0) { - haystackStr += start; - haystackLen -= start; - } else if (start < 0) { - /* - * Invalid start index mapped to string start; Bug #423581 - */ - - start = 0; - } - } - - /* - * If the length of the needle is more than the length of the haystack, it - * cannot be contained in there so we can avoid searching. [Bug 2960021] - */ - - if (needleLen > 0 && needleLen <= haystackLen) { - register Tcl_UniChar *p, *end; - - end = haystackStr + haystackLen - needleLen + 1; - for (p = haystackStr; p < end; p++) { - /* - * Scan forward to find the first character. - */ - - if ((*p == *needleStr) && (TclUniCharNcmp(needleStr, p, - (unsigned long) needleLen) == 0)) { - match = p - haystackStr; - break; - } - } - } - - /* - * Compute the character index of the matching string by counting the - * number of characters before the match. - */ - - if ((match != -1) && (objc == 4)) { - match += start; } - - str_first_done: - Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(TclStringFirst(objv[1], + objv[2], start))); return TCL_OK; } @@ -1289,76 +1366,23 @@ StringLastCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar *needleStr, *haystackStr, *p; - int match, start, needleLen, haystackLen; + int last = INT_MAX - 1; if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, - "needleString haystackString ?startIndex?"); + "needleString haystackString ?lastIndex?"); return TCL_ERROR; } - /* - * We are searching haystackString for the sequence needleString. - */ - - match = -1; - start = 0; - haystackLen = -1; - - needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen); - haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen); - if (objc == 4) { - /* - * If a startIndex is specified, we will need to restrict the string - * range to that char index in the string - */ + int size = Tcl_GetCharLength(objv[2]); - if (TclGetIntForIndexM(interp, objv[3], haystackLen-1, - &start) != TCL_OK){ + if (TCL_OK != TclGetIntForIndexM(interp, objv[3], size - 1, &last)) { return TCL_ERROR; } - - /* - * Reread to prevent shimmering problems. - */ - - needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen); - haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen); - - if (start < 0) { - goto str_last_done; - } else if (start < haystackLen) { - p = haystackStr + start + 1 - needleLen; - } else { - p = haystackStr + haystackLen - needleLen; - } - } else { - p = haystackStr + haystackLen - needleLen; - } - - /* - * If the length of the needle is more than the length of the haystack, it - * cannot be contained in there so we can avoid searching. [Bug 2960021] - */ - - if (needleLen > 0 && needleLen <= haystackLen) { - for (; p >= haystackStr; p--) { - /* - * Scan backwards to find the first character. - */ - - if ((*p == *needleStr) && !memcmp(needleStr, p, - sizeof(Tcl_UniChar) * (size_t)needleLen)) { - match = p - haystackStr; - break; - } - } } - - str_last_done: - Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(TclStringLast(objv[1], + objv[2], last))); return TCL_OK; } @@ -1395,7 +1419,7 @@ StringIndexCmd( } /* - * Get the char length to calulate what 'end' means. + * Get the char length to calculate what 'end' means. */ length = Tcl_GetCharLength(objv[1]); @@ -1404,7 +1428,11 @@ StringIndexCmd( } if ((index >= 0) && (index < length)) { - Tcl_UniChar ch = Tcl_GetUniChar(objv[1], index); + int ch = Tcl_GetUniChar(objv[1], index); + + if (ch == -1) { + return TCL_OK; + } /* * If we have a ByteArray object, we're careful to generate a new @@ -1416,9 +1444,12 @@ StringIndexCmd( Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(&uch, 1)); } else { - char buf[TCL_UTF_MAX]; + char buf[4]; length = Tcl_UniCharToUtf(ch, buf); + if (!length) { + length = Tcl_UniCharToUtf(-1, buf); + } Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, length)); } } @@ -1451,7 +1482,7 @@ StringIsCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { const char *string1, *end, *stop; - Tcl_UniChar ch; + Tcl_UniChar ch = 0; int (*chcomp)(int) = NULL; /* The UniChar comparison function. */ int i, failat = 0, result = 1, strict = 0, index, length1, length2; Tcl_Obj *objPtr, *failVarObj = NULL; @@ -1548,11 +1579,11 @@ StringIsCmd( string1 = TclGetStringFromObj(objPtr, &length1); result = length1 == 0; } - } else if (((index == STR_IS_TRUE) && - objPtr->internalRep.longValue == 0) - || ((index == STR_IS_FALSE) && - objPtr->internalRep.longValue != 0)) { - result = 0; + } else if (index != STR_IS_BOOL) { + TclGetBooleanFromObj(NULL, objPtr, &i); + if ((index == STR_IS_TRUE) ^ i) { + result = 0; + } } break; case STR_IS_CONTROL: @@ -1562,12 +1593,8 @@ StringIsCmd( chcomp = Tcl_UniCharIsDigit; break; case STR_IS_DOUBLE: { - /* TODO */ if ((objPtr->typePtr == &tclDoubleType) || (objPtr->typePtr == &tclIntType) || -#ifndef TCL_WIDE_INT_IS_LONG - (objPtr->typePtr == &tclWideIntType) || -#endif (objPtr->typePtr == &tclBignumType)) { break; } @@ -1602,9 +1629,6 @@ StringIsCmd( goto failedIntParse; case STR_IS_ENTIER: if ((objPtr->typePtr == &tclIntType) || -#ifndef TCL_WIDE_INT_IS_LONG - (objPtr->typePtr == &tclWideIntType) || -#endif (objPtr->typePtr == &tclBignumType)) { break; } @@ -1646,7 +1670,7 @@ StringIsCmd( } break; case STR_IS_WIDE: - if (TCL_OK == Tcl_GetWideIntFromObj(NULL, objPtr, &w)) { + if (TCL_OK == TclGetWideIntFromObj(NULL, objPtr, &w)) { break; } @@ -1783,8 +1807,16 @@ StringIsCmd( } end = string1 + length1; for (; string1 < end; string1 += length2, failat++) { + int fullchar; length2 = TclUtfToUniChar(string1, &ch); - if (!chcomp(ch)) { + fullchar = ch; +#if TCL_UTF_MAX <= 4 + if (!length2) { + length2 = TclUtfToUniChar(string1, &ch); + fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; + } +#endif + if (!chcomp(fullchar)) { result = 0; break; } @@ -1873,7 +1905,7 @@ StringMapCmd( /* * This test is tricky, but has to be that way or you get other strange - * inconsistencies (see test string-10.20 for illustration why!) + * inconsistencies (see test string-10.20.1 for illustration why!) */ if (objv[objc-2]->typePtr == &tclDictType && objv[objc-2]->bytes == NULL){ @@ -1972,8 +2004,8 @@ StringMapCmd( * larger strings. */ - int mapLen; - Tcl_UniChar *mapString, u2lc; + int mapLen, u2lc; + Tcl_UniChar *mapString; ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2); p = ustring1; @@ -2004,8 +2036,8 @@ StringMapCmd( } } } else { - Tcl_UniChar **mapStrings, *u2lc = NULL; - int *mapLens; + Tcl_UniChar **mapStrings; + int *mapLens, *u2lc = NULL; /* * Precompute pointers to the unicode string and length. This saves us @@ -2017,7 +2049,7 @@ StringMapCmd( mapStrings = TclStackAlloc(interp, mapElemc*2*sizeof(Tcl_UniChar *)); mapLens = TclStackAlloc(interp, mapElemc * 2 * sizeof(int)); if (nocase) { - u2lc = TclStackAlloc(interp, mapElemc * sizeof(Tcl_UniChar)); + u2lc = TclStackAlloc(interp, mapElemc * sizeof(int)); } for (index = 0; index < mapElemc; index++) { mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index], @@ -2223,9 +2255,7 @@ StringReptCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - const char *string1; - char *string2; - int count, index, length1, length2; + int count; Tcl_Obj *resultPtr; if (objc != 3) { @@ -2243,71 +2273,17 @@ StringReptCmd( if (count == 1) { Tcl_SetObjResult(interp, objv[1]); - goto done; + return TCL_OK; } else if (count < 1) { - goto done; - } - string1 = TclGetStringFromObj(objv[1], &length1); - if (length1 <= 0) { - goto done; - } - - /* - * Only build up a string that has data. Instead of building it up with - * repeated appends, we just allocate the necessary space once and copy - * the string value in. - * - * We have to worry about overflow [Bugs 714106, 2561746]. - * At this point we know 1 <= length1 <= INT_MAX and 2 <= count <= INT_MAX. - * We need to keep 2 <= length2 <= INT_MAX. - */ - - if (count > INT_MAX/length1) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "result exceeds max size for a Tcl value (%d bytes)", - INT_MAX)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - return TCL_ERROR; + return TCL_OK; } - length2 = length1 * count; - /* - * Include space for the NUL. - */ - - string2 = attemptckalloc((unsigned) length2 + 1); - if (string2 == NULL) { - /* - * Alloc failed. Note that in this case we try to do an error message - * since this is a case that's most likely when the alloc is large and - * that's easy to do with this API. Note that if we fail allocating a - * short string, this will likely keel over too (and fatally). - */ - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "string size overflow, out of memory allocating %u bytes", - length2 + 1)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - return TCL_ERROR; - } - for (index = 0; index < count; index++) { - memcpy(string2 + (length1 * index), string1, (size_t) length1); + resultPtr = TclStringRepeat(interp, objv[1], count, TCL_STRING_IN_PLACE); + if (resultPtr) { + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; } - string2[length2] = '\0'; - - /* - * We have to directly assign this instead of using Tcl_SetStringObj (and - * indirectly TclInitStringRep) because that makes another copy of the - * data. - */ - - TclNewObj(resultPtr); - resultPtr->bytes = string2; - resultPtr->length = length2; - Tcl_SetObjResult(interp, resultPtr); - - done: - return TCL_OK; + return TCL_ERROR; } /* @@ -2335,42 +2311,50 @@ StringRplcCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar *ustring; - int first, last, length; + int first, last, length, end; if (objc < 4 || objc > 5) { Tcl_WrongNumArgs(interp, 1, objv, "string first last ?string?"); return TCL_ERROR; } - ustring = Tcl_GetUnicodeFromObj(objv[1], &length); - length--; + length = Tcl_GetCharLength(objv[1]); + end = length - 1; - if (TclGetIntForIndexM(interp, objv[2], length, &first) != TCL_OK || - TclGetIntForIndexM(interp, objv[3], length, &last) != TCL_OK){ + if (TclGetIntForIndexM(interp, objv[2], end, &first) != TCL_OK || + TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK){ return TCL_ERROR; } - if ((last < first) || (last < 0) || (first > length)) { + /* + * The following test screens out most empty substrings as + * candidates for replacement. When they are detected, no + * replacement is done, and the result is the original string, + */ + if ((last < 0) || /* Range ends before start of string */ + (first > end) || /* Range begins after end of string */ + (last < first)) { /* Range begins after it starts */ + + /* + * BUT!!! when (end < 0) -- an empty original string -- we can + * have (first <= end < 0 <= last) and an empty string is permitted + * to be replaced. + */ Tcl_SetObjResult(interp, objv[1]); } else { Tcl_Obj *resultPtr; - ustring = Tcl_GetUnicodeFromObj(objv[1], &length); - length--; - if (first < 0) { first = 0; } - - resultPtr = Tcl_NewUnicodeObj(ustring, first); - if (objc == 5) { - Tcl_AppendObjToObj(resultPtr, objv[4]); - } - if (last < length) { - Tcl_AppendUnicodeToObj(resultPtr, ustring + last + 1, - length - last); + if (last > end) { + last = end; } + + resultPtr = TclStringReplace(interp, objv[1], first, + last + 1 - first, (objc == 5) ? objv[4] : NULL, + TCL_STRING_IN_PLACE); + Tcl_SetObjResult(interp, resultPtr); } return TCL_OK; @@ -2406,7 +2390,7 @@ StringRevCmd( return TCL_ERROR; } - Tcl_SetObjResult(interp, TclStringObjReverse(objv[1])); + Tcl_SetObjResult(interp, TclStringReverse(objv[1], TCL_STRING_IN_PLACE)); return TCL_OK; } @@ -2436,7 +2420,7 @@ StringStartCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar ch; + Tcl_UniChar ch = 0; const char *p, *string; int cur, index, length, numChars; @@ -2497,7 +2481,7 @@ StringEndCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar ch; + Tcl_UniChar ch = 0; const char *p, *end, *string; int cur, index, length, numChars; @@ -2565,10 +2549,8 @@ StringEqualCmd( * the expr string comparison in INST_EQ/INST_NEQ/INST_LT/...). */ - const char *string1, *string2; - int length1, length2, i, match, length, nocase = 0, reqlength = -1; - typedef int (*strCmpFn_t)(const char *, const char *, unsigned int); - strCmpFn_t strCmpFn; + const char *string2; + int length, i, match, nocase = 0, reqlength = -1; if (objc < 3 || objc > 6) { str_cmp_args: @@ -2578,11 +2560,11 @@ StringEqualCmd( } for (i = 1; i < objc-2; i++) { - string2 = TclGetStringFromObj(objv[i], &length2); - if ((length2 > 1) && !strncmp(string2, "-nocase", (size_t)length2)) { + string2 = TclGetStringFromObj(objv[i], &length); + if ((length > 1) && !strncmp(string2, "-nocase", (size_t)length)) { nocase = 1; - } else if ((length2 > 1) - && !strncmp(string2, "-length", (size_t)length2)) { + } else if ((length > 1) + && !strncmp(string2, "-length", (size_t)length)) { if (i+1 >= objc-2) { goto str_cmp_args; } @@ -2607,78 +2589,7 @@ StringEqualCmd( objv += objc-2; - if ((reqlength == 0) || (objv[0] == objv[1])) { - /* - * Always match at 0 chars of if it is the same obj. - */ - - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); - return TCL_OK; - } - - if (!nocase && TclIsPureByteArray(objv[0]) && - TclIsPureByteArray(objv[1])) { - /* - * Use binary versions of comparisons since that won't cause undue - * type conversions and it is much faster. Only do this if we're - * case-sensitive (which is all that really makes sense with byte - * arrays anyway, and we have no memcasecmp() for some reason... :^) - */ - - string1 = (char *) Tcl_GetByteArrayFromObj(objv[0], &length1); - string2 = (char *) Tcl_GetByteArrayFromObj(objv[1], &length2); - strCmpFn = (strCmpFn_t) memcmp; - } else if ((objv[0]->typePtr == &tclStringType) - && (objv[1]->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. - */ - - string1 = (char *) Tcl_GetUnicodeFromObj(objv[0], &length1); - string2 = (char *) Tcl_GetUnicodeFromObj(objv[1], &length2); - strCmpFn = (strCmpFn_t) - (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 NUL (\xC0\x80 in Tcl's - * utf rep). We can use the more efficient TclpUtfNcmp2 if we are - * case-sensitive and no specific length was requested. - */ - - string1 = (char *) TclGetStringFromObj(objv[0], &length1); - string2 = (char *) TclGetStringFromObj(objv[1], &length2); - if ((reqlength < 0) && !nocase) { - strCmpFn = (strCmpFn_t) TclpUtfNcmp2; - } else { - length1 = Tcl_NumUtfChars(string1, length1); - length2 = Tcl_NumUtfChars(string2, length2); - strCmpFn = (strCmpFn_t) (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp); - } - } - - if ((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 length + 1 so we correct the match var. - */ - - reqlength = length + 1; - } - - match = strCmpFn(string1, string2, (unsigned) length); - if ((match == 0) && (reqlength > length)) { - match = length1 - length2; - } - } + match = TclStringCmp(objv[0], objv[1], 0, nocase, reqlength); Tcl_SetObjResult(interp, Tcl_NewBooleanObj(match ? 0 : 1)); return TCL_OK; @@ -2715,11 +2626,31 @@ StringCmpCmd( * the expr string comparison in INST_EQ/INST_NEQ/INST_LT/...). */ - const char *string1, *string2; - int length1, length2, i, match, length, nocase = 0, reqlength = -1; - typedef int (*strCmpFn_t)(const char *, const char *, unsigned int); - strCmpFn_t strCmpFn; + int match, nocase, reqlength, status; + + status = TclStringCmpOpts(interp, objc, objv, &nocase, &reqlength); + if (status != TCL_OK) { + return status; + } + + objv += objc-2; + match = TclStringCmp(objv[0], objv[1], 0, nocase, reqlength); + Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); + return TCL_OK; +} + +int TclStringCmpOpts( + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[], /* Argument objects. */ + int *nocase, + int *reqlength) +{ + int i, length; + const char *string; + *reqlength = -1; + *nocase = 0; if (objc < 3 || objc > 6) { str_cmp_args: Tcl_WrongNumArgs(interp, 1, objv, @@ -2728,107 +2659,72 @@ StringCmpCmd( } for (i = 1; i < objc-2; i++) { - string2 = TclGetStringFromObj(objv[i], &length2); - if ((length2 > 1) && !strncmp(string2, "-nocase", (size_t)length2)) { - nocase = 1; - } else if ((length2 > 1) - && !strncmp(string2, "-length", (size_t)length2)) { + string = TclGetStringFromObj(objv[i], &length); + if ((length > 1) && !strncmp(string, "-nocase", (size_t)length)) { + *nocase = 1; + } else if ((length > 1) + && !strncmp(string, "-length", (size_t)length)) { if (i+1 >= objc-2) { goto str_cmp_args; } i++; - if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) { + if (TclGetIntFromObj(interp, objv[i], reqlength) != TCL_OK) { return TCL_ERROR; } } else { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad option \"%s\": must be -nocase or -length", - string2)); + string)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", - string2, NULL); + string, NULL); return TCL_ERROR; } } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * StringCatCmd -- + * + * This procedure is invoked to process the "string cat" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ - /* - * From now on, we only access the two objects at the end of the argument - * array. - */ - - objv += objc-2; +static int +StringCatCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Obj *objResultPtr; - if ((reqlength == 0) || (objv[0] == objv[1])) { + if (objc < 2) { /* - * Always match at 0 chars of if it is the same obj. + * If there are no args, the result is an empty object. + * Just leave the preset empty interp result. */ - - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); return TCL_OK; } - if (!nocase && TclIsPureByteArray(objv[0]) && - TclIsPureByteArray(objv[1])) { - /* - * Use binary versions of comparisons since that won't cause undue - * type conversions and it is much faster. Only do this if we're - * case-sensitive (which is all that really makes sense with byte - * arrays anyway, and we have no memcasecmp() for some reason... :^) - */ - - string1 = (char *) Tcl_GetByteArrayFromObj(objv[0], &length1); - string2 = (char *) Tcl_GetByteArrayFromObj(objv[1], &length2); - strCmpFn = (strCmpFn_t) memcmp; - } else if ((objv[0]->typePtr == &tclStringType) - && (objv[1]->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. - */ - - string1 = (char *) Tcl_GetUnicodeFromObj(objv[0], &length1); - string2 = (char *) Tcl_GetUnicodeFromObj(objv[1], &length2); - strCmpFn = (strCmpFn_t) - (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 NUL (\xC0\x80 in Tcl's - * utf rep). We can use the more efficient TclpUtfNcmp2 if we are - * case-sensitive and no specific length was requested. - */ - - string1 = (char *) TclGetStringFromObj(objv[0], &length1); - string2 = (char *) TclGetStringFromObj(objv[1], &length2); - if ((reqlength < 0) && !nocase) { - strCmpFn = (strCmpFn_t) TclpUtfNcmp2; - } else { - length1 = Tcl_NumUtfChars(string1, length1); - length2 = Tcl_NumUtfChars(string2, length2); - strCmpFn = (strCmpFn_t) (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp); - } - } - - 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 - * length + 1 so we correct the match var. - */ - - reqlength = length + 1; - } + objResultPtr = TclStringCat(interp, objc-1, objv+1, TCL_STRING_IN_PLACE); - match = strCmpFn(string1, string2, (unsigned) length); - if ((match == 0) && (reqlength > length)) { - match = length1 - length2; + if (objResultPtr) { + Tcl_SetObjResult(interp, objResultPtr); + return TCL_OK; } - Tcl_SetObjResult(interp, - Tcl_NewIntObj((match > 0) ? 1 : (match < 0) ? -1 : 0)); - return TCL_OK; + return TCL_ERROR; } /* @@ -2849,7 +2745,6 @@ StringCmpCmd( * *---------------------------------------------------------------------- */ - static int StringBytesCmd( ClientData dummy, /* Not used. */ @@ -3189,16 +3084,15 @@ StringTrimCmd( if (objc == 3) { string2 = TclGetStringFromObj(objv[2], &length2); } else if (objc == 2) { - string2 = DEFAULT_TRIM_SET; - length2 = strlen(DEFAULT_TRIM_SET); + string2 = tclDefaultTrimSet; + length2 = strlen(tclDefaultTrimSet); } else { Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?"); return TCL_ERROR; } string1 = TclGetStringFromObj(objv[1], &length1); - triml = TclTrimLeft(string1, length1, string2, length2); - trimr = TclTrimRight(string1 + triml, length1 - triml, string2, length2); + triml = TclTrim(string1, length1, string2, length2, &trimr); Tcl_SetObjResult(interp, Tcl_NewStringObj(string1 + triml, length1 - triml - trimr)); @@ -3237,8 +3131,8 @@ StringTrimLCmd( if (objc == 3) { string2 = TclGetStringFromObj(objv[2], &length2); } else if (objc == 2) { - string2 = DEFAULT_TRIM_SET; - length2 = strlen(DEFAULT_TRIM_SET); + string2 = tclDefaultTrimSet; + length2 = strlen(tclDefaultTrimSet); } else { Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?"); return TCL_ERROR; @@ -3283,8 +3177,8 @@ StringTrimRCmd( if (objc == 3) { string2 = TclGetStringFromObj(objv[2], &length2); } else if (objc == 2) { - string2 = DEFAULT_TRIM_SET; - length2 = strlen(DEFAULT_TRIM_SET); + string2 = tclDefaultTrimSet; + length2 = strlen(tclDefaultTrimSet); } else { Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?"); return TCL_ERROR; @@ -3326,25 +3220,26 @@ TclInitStringCmd( { static const EnsembleImplMap stringImplMap[] = { {"bytelength", StringBytesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"cat", StringCatCmd, TclCompileStringCatCmd, NULL, NULL, 0}, {"compare", StringCmpCmd, TclCompileStringCmpCmd, NULL, NULL, 0}, {"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0}, {"first", StringFirstCmd, TclCompileStringFirstCmd, NULL, NULL, 0}, {"index", StringIndexCmd, TclCompileStringIndexCmd, NULL, NULL, 0}, - {"is", StringIsCmd, NULL, NULL, NULL, 0}, + {"is", StringIsCmd, TclCompileStringIsCmd, NULL, NULL, 0}, {"last", StringLastCmd, TclCompileStringLastCmd, NULL, NULL, 0}, {"length", StringLenCmd, TclCompileStringLenCmd, NULL, NULL, 0}, {"map", StringMapCmd, TclCompileStringMapCmd, NULL, NULL, 0}, {"match", StringMatchCmd, TclCompileStringMatchCmd, NULL, NULL, 0}, {"range", StringRangeCmd, TclCompileStringRangeCmd, NULL, NULL, 0}, {"repeat", StringReptCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"replace", StringRplcCmd, NULL, NULL, NULL, 0}, + {"replace", StringRplcCmd, TclCompileStringReplaceCmd, NULL, NULL, 0}, {"reverse", StringRevCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"tolower", StringLowerCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, - {"toupper", StringUpperCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, - {"totitle", StringTitleCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, - {"trim", StringTrimCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {"trimleft", StringTrimLCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {"trimright", StringTrimRCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, + {"tolower", StringLowerCmd, TclCompileStringToLowerCmd, NULL, NULL, 0}, + {"toupper", StringUpperCmd, TclCompileStringToUpperCmd, NULL, NULL, 0}, + {"totitle", StringTitleCmd, TclCompileStringToTitleCmd, NULL, NULL, 0}, + {"trim", StringTrimCmd, TclCompileStringTrimCmd, NULL, NULL, 0}, + {"trimleft", StringTrimLCmd, TclCompileStringTrimLCmd, NULL, NULL, 0}, + {"trimright", StringTrimRCmd, TclCompileStringTrimRCmd, NULL, NULL, 0}, {"wordend", StringEndCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"wordstart", StringStartCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} @@ -3389,7 +3284,7 @@ TclSubstOptions( for (i = 0; i < numOpts; i++) { int optionIndex; - if (Tcl_GetIndexFromObj(interp, opts[i], substOptions, "switch", 0, + if (Tcl_GetIndexFromObj(interp, opts[i], substOptions, "option", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } @@ -3502,7 +3397,7 @@ TclNRSwitchObjCmd( OPT_LAST }; typedef int (*strCmpFn_t)(const char *, const char *); - strCmpFn_t strCmpFn = strcmp; + strCmpFn_t strCmpFn = TclUtfCmp; mode = OPT_EXACT; foundmode = 0; @@ -3589,7 +3484,7 @@ TclNRSwitchObjCmd( finishedOptions: if (objc - i < 2) { Tcl_WrongNumArgs(interp, 1, objv, - "?-switch ...? string ?pattern body ...? ?default body?"); + "?-option ...? string ?pattern body ...? ?default body?"); return TCL_ERROR; } if (indexVarObj != NULL && mode != OPT_REGEXP) { @@ -3636,7 +3531,7 @@ TclNRSwitchObjCmd( if (objc < 1) { Tcl_WrongNumArgs(interp, 1, savedObjv, - "?-switch ...? string {?pattern body ...? ?default body?}"); + "?-option ...? string {?pattern body ...? ?default body?}"); return TCL_ERROR; } objv = listv; diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 8edb2d9..3a162cc 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -26,11 +26,23 @@ static void FreeDictUpdateInfo(ClientData clientData); static void PrintDictUpdateInfo(ClientData clientData, Tcl_Obj *appendObj, ByteCode *codePtr, unsigned int pcOffset); +static void DisassembleDictUpdateInfo(ClientData clientData, + Tcl_Obj *dictObj, ByteCode *codePtr, + unsigned int pcOffset); static ClientData DupForeachInfo(ClientData clientData); static void FreeForeachInfo(ClientData clientData); static void PrintForeachInfo(ClientData clientData, Tcl_Obj *appendObj, ByteCode *codePtr, unsigned int pcOffset); +static void DisassembleForeachInfo(ClientData clientData, + Tcl_Obj *dictObj, ByteCode *codePtr, + unsigned int pcOffset); +static void PrintNewForeachInfo(ClientData clientData, + Tcl_Obj *appendObj, ByteCode *codePtr, + unsigned int pcOffset); +static void DisassembleNewForeachInfo(ClientData clientData, + Tcl_Obj *dictObj, ByteCode *codePtr, + unsigned int pcOffset); static int CompileEachloopCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, CompileEnv *envPtr, int collect); @@ -42,23 +54,66 @@ static int CompileDictEachCmd(Tcl_Interp *interp, * The structures below define the AuxData types defined in this file. */ -const AuxDataType tclForeachInfoType = { +static const AuxDataType foreachInfoType = { "ForeachInfo", /* name */ DupForeachInfo, /* dupProc */ FreeForeachInfo, /* freeProc */ - PrintForeachInfo /* printProc */ + PrintForeachInfo, /* printProc */ + DisassembleForeachInfo /* disassembleProc */ }; -const AuxDataType tclDictUpdateInfoType = { +static const AuxDataType newForeachInfoType = { + "NewForeachInfo", /* name */ + DupForeachInfo, /* dupProc */ + FreeForeachInfo, /* freeProc */ + PrintNewForeachInfo, /* printProc */ + DisassembleNewForeachInfo /* disassembleProc */ +}; + +static const AuxDataType dictUpdateInfoType = { "DictUpdateInfo", /* name */ DupDictUpdateInfo, /* dupProc */ FreeDictUpdateInfo, /* freeProc */ - PrintDictUpdateInfo /* printProc */ + PrintDictUpdateInfo, /* printProc */ + DisassembleDictUpdateInfo /* disassembleProc */ }; /* *---------------------------------------------------------------------- * + * TclGetAuxDataType -- + * + * This procedure looks up an Auxdata type by name. + * + * Results: + * If an AuxData type with name matching "typeName" is found, a pointer + * to its AuxDataType structure is returned; otherwise, NULL is returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +const AuxDataType * +TclGetAuxDataType( + const char *typeName) /* Name of AuxData type to look up. */ +{ + if (!strcmp(typeName, foreachInfoType.name)) { + return &foreachInfoType; + } else if (!strcmp(typeName, newForeachInfoType.name)) { + return &newForeachInfoType; + } else if (!strcmp(typeName, dictUpdateInfoType.name)) { + return &dictUpdateInfoType; + } else if (!strcmp(typeName, tclJumptableInfoType.name)) { + return &tclJumptableInfoType; + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileAppendCmd -- * * Procedure called to compile the "append" command. @@ -155,9 +210,9 @@ TclCompileAppendCmd( */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT, - &localIndex, &isScalar, 1); - if (!isScalar || localIndex < 0) { + + localIndex = LocalScalarFromToken(varTokenPtr, envPtr); + if (localIndex < 0) { return TCL_ERROR; } @@ -245,8 +300,8 @@ TclCompileArraySetCmd( Tcl_Token *varTokenPtr, *dataTokenPtr; int isScalar, localIndex, code = TCL_OK; int isDataLiteral, isDataValid, isDataEven, len; - int dataVar, iterVar, keyVar, valVar, infoIndex; - int back, fwd, offsetBack, offsetFwd; + int keyVar, valVar, infoIndex; + int fwd, offsetBack, offsetFwd; Tcl_Obj *literalObj; ForeachInfo *infoPtr; @@ -267,11 +322,22 @@ TclCompileArraySetCmd( */ if (isDataValid && !isDataEven) { + /* Abandon custom compile and let invocation raise the error */ + code = TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); + goto done; + + /* + * We used to compile to the bytecode that would throw the error, + * but that was wrong because it would not invoke the array trace + * on the variable. + * PushStringLiteral(envPtr, "list must have an even number of elements"); - PushStringLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}"); - TclEmitInstInt4(INST_RETURN_IMM, 1, envPtr); + PushStringLiteral(envPtr, "-errorcode {TCL ARGUMENT FORMAT}"); + TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR, envPtr); TclEmitInt4( 0, envPtr); goto done; + * + */ } /* @@ -279,7 +345,8 @@ TclCompileArraySetCmd( * a proc, we cannot do a better compile than generic. */ - if (envPtr->procPtr == NULL && !(isDataEven && len == 0)) { + if ((varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) || + (envPtr->procPtr == NULL && !(isDataEven && len == 0))) { code = TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); goto done; } @@ -290,6 +357,7 @@ TclCompileArraySetCmd( code = TCL_ERROR; goto done; } + /* * Special case: literal empty value argument is just an "ensure array" * operation. @@ -314,29 +382,43 @@ TclCompileArraySetCmd( goto done; } + if (localIndex < 0) { + /* + * a non-local variable: upvar from a local one! This consumes the + * variable name that was left at stacktop. + */ + + localIndex = TclFindCompiledLocal(varTokenPtr->start, + varTokenPtr->size, 1, envPtr); + PushStringLiteral(envPtr, "0"); + TclEmitInstInt4(INST_REVERSE, 2, envPtr); + TclEmitInstInt4(INST_UPVAR, localIndex, envPtr); + TclEmitOpcode(INST_POP, envPtr); + } + /* * Prepare for the internal foreach. */ - dataVar = AnonymousLocal(envPtr); - iterVar = AnonymousLocal(envPtr); keyVar = AnonymousLocal(envPtr); valVar = AnonymousLocal(envPtr); - infoPtr = ckalloc(sizeof(ForeachInfo) + sizeof(ForeachVarList *)); + infoPtr = ckalloc(sizeof(ForeachInfo)); infoPtr->numLists = 1; - infoPtr->firstValueTemp = dataVar; - infoPtr->loopCtTemp = iterVar; - infoPtr->varLists[0] = ckalloc(sizeof(ForeachVarList) * 2*sizeof(int)); + infoPtr->varLists[0] = ckalloc(sizeof(ForeachVarList) + sizeof(int)); infoPtr->varLists[0]->numVars = 2; infoPtr->varLists[0]->varIndexes[0] = keyVar; infoPtr->varLists[0]->varIndexes[1] = valVar; - infoIndex = TclCreateAuxData(infoPtr, &tclForeachInfoType, envPtr); + infoIndex = TclCreateAuxData(infoPtr, &newForeachInfoType, envPtr); /* * Start issuing instructions to write to the array. */ + TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); + TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr); + TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr); + CompileWord(envPtr, dataTokenPtr, interp, 2); if (!isDataLiteral || !isDataValid) { /* @@ -353,61 +435,27 @@ TclCompileArraySetCmd( offsetFwd = CurrentOffset(envPtr); TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); PushStringLiteral(envPtr, "list must have an even number of elements"); - PushStringLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}"); - TclEmitInstInt4(INST_RETURN_IMM, 1, envPtr); + PushStringLiteral(envPtr, "-errorcode {TCL ARGUMENT FORMAT}"); + TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR, envPtr); TclEmitInt4( 0, envPtr); TclAdjustStackDepth(-1, envPtr); fwd = CurrentOffset(envPtr) - offsetFwd; TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); } - Emit14Inst( INST_STORE_SCALAR, dataVar, envPtr); - TclEmitOpcode( INST_POP, envPtr); - if (localIndex >= 0) { - TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); - TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr); - TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr); - TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr); - offsetBack = CurrentOffset(envPtr); - TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr); - offsetFwd = CurrentOffset(envPtr); - TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); - Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr); - Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr); - Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); - back = offsetBack - CurrentOffset(envPtr); - TclEmitInstInt1(INST_JUMP1, back, envPtr); - fwd = CurrentOffset(envPtr) - offsetFwd; - TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); - } else { - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); - TclEmitInstInt1(INST_JUMP_TRUE1, 4, envPtr); - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_ARRAY_MAKE_STK, envPtr); - TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr); - offsetBack = CurrentOffset(envPtr); - TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr); - offsetFwd = CurrentOffset(envPtr); - TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); - TclEmitOpcode( INST_DUP, envPtr); - Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr); - Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr); - TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr); - TclEmitOpcode( INST_POP, envPtr); - back = offsetBack - CurrentOffset(envPtr); - TclEmitInstInt1(INST_JUMP1, back, envPtr); - fwd = CurrentOffset(envPtr) - offsetFwd; - TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); - TclEmitOpcode( INST_POP, envPtr); - } - if (!isDataLiteral) { - TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( dataVar, envPtr); - } + TclEmitInstInt4(INST_FOREACH_START, infoIndex, envPtr); + offsetBack = CurrentOffset(envPtr); + Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr); + Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr); + Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); + infoPtr->loopCtTemp = offsetBack - CurrentOffset(envPtr); /*misuse */ + TclEmitOpcode( INST_FOREACH_STEP, envPtr); + TclEmitOpcode( INST_FOREACH_END, envPtr); + TclAdjustStackDepth(-3, envPtr); PushStringLiteral(envPtr, ""); - done: + + done: Tcl_DecrRefCount(literalObj); return code; } @@ -500,17 +548,14 @@ TclCompileBreakCmd( TclCleanupStackForBreakContinue(envPtr, auxPtr); TclAddLoopBreakFixup(envPtr, auxPtr); - TclAdjustStackDepth(1, envPtr); } else { /* * Emit a real break. */ - PushStringLiteral(envPtr, ""); - TclEmitOpcode(INST_DUP, envPtr); - TclEmitInstInt4(INST_RETURN_IMM, TCL_BREAK, envPtr); - TclEmitInt4(0, envPtr); + TclEmitOpcode(INST_BREAK, envPtr); } + TclAdjustStackDepth(1, envPtr); return TCL_OK; } @@ -544,8 +589,9 @@ TclCompileCatchCmd( { JumpFixup jumpFixup; Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr; - int resultIndex, optsIndex, range; + int resultIndex, optsIndex, range, dropScript = 0; DefineLineInformation; /* TIP #280 */ + int depth = TclGetStackDepth(envPtr); /* * If syntax does not match what we expect for [catch], do not compile. @@ -593,11 +639,7 @@ TclCompileCatchCmd( /* * We will compile the catch command. Declare the exception range that it * uses. - */ - - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - - /* + * * If the body is a simple word, compile a BEGIN_CATCH instruction, * followed by the instructions to eval the body. * Otherwise, compile instructions to substitute the body text before @@ -610,6 +652,7 @@ TclCompileCatchCmd( * begin by undeflowing the stack below the mark set by BEGIN_CATCH4. */ + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); @@ -620,71 +663,51 @@ TclCompileCatchCmd( TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_EVAL_STK, envPtr); - } - /* Stack at this point: - * nonsimple: script <mark> result - * simple: <mark> result - */ - - if (resultIndex == -1) { - /* - * Special case when neither result nor options are being saved. In - * that case, we can skip quite a bit of the command epilogue; all we - * have to do is drop the result and push the return code (and, of - * course, finish the catch context). - */ - + TclEmitInvoke(envPtr, INST_EVAL_STK); + /* drop the script */ + dropScript = 1; + TclEmitInstInt4( INST_REVERSE, 2, envPtr); TclEmitOpcode( INST_POP, envPtr); - PushStringLiteral(envPtr, "0"); - TclEmitInstInt1( INST_JUMP1, 3, envPtr); - TclAdjustStackDepth(-1, envPtr); - ExceptionRangeTarget(envPtr, range, catchOffset); - TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr); - ExceptionRangeEnds(envPtr, range); - TclEmitOpcode( INST_END_CATCH, envPtr); - - /* - * Stack at this point: - * nonsimple: script <mark> returnCode - * simple: <mark> returnCode - */ - - goto dropScriptAtEnd; } + ExceptionRangeEnds(envPtr, range); + /* * Emit the "no errors" epilogue: push "0" (TCL_OK) as the catch result, * and jump around the "error case" code. */ + TclCheckStackDepth(depth+1, envPtr); PushStringLiteral(envPtr, "0"); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); - /* Stack at this point: ?script? <mark> result TCL_OK */ - /* + /* * Emit the "error case" epilogue. Push the interpreter result and the * return code. */ - TclAdjustStackDepth(-2, envPtr); ExceptionRangeTarget(envPtr, range, catchOffset); - /* Stack at this point: ?script? */ + TclSetStackDepth(depth + dropScript, envPtr); + + if (dropScript) { + TclEmitOpcode( INST_POP, envPtr); + } + + + /* Stack at this point is empty */ TclEmitOpcode( INST_PUSH_RESULT, envPtr); TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr); - /* - * Update the target of the jump after the "no errors" code. - */ + /* Stack at this point on both branches: result returnCode */ - /* Stack at this point: ?script? result returnCode */ if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { Tcl_Panic("TclCompileCatchCmd: bad jump distance %d", (int)(CurrentOffset(envPtr) - jumpFixup.codeOffset)); } /* - * Push the return options if the caller wants them. + * Push the return options if the caller wants them. This needs to happen + * before INST_END_CATCH */ if (optsIndex != -1) { @@ -695,53 +718,217 @@ TclCompileCatchCmd( * End the catch */ - ExceptionRangeEnds(envPtr, range); TclEmitOpcode( INST_END_CATCH, envPtr); /* - * At this point, the top of the stack is inconveniently ordered: - * ?script? result returnCode ?returnOptions? - * Reverse the stack to bring the result to the top. + * Save the result and return options if the caller wants them. This needs + * to happen after INST_END_CATCH (compile-3.6/7). */ if (optsIndex != -1) { - TclEmitInstInt4( INST_REVERSE, 3, envPtr); - } else { - TclEmitInstInt4( INST_REVERSE, 2, envPtr); + Emit14Inst( INST_STORE_SCALAR, optsIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); } /* - * Store the result and remove it from the stack. + * At this point, the top of the stack is inconveniently ordered: + * result returnCode + * Reverse the stack to store the result. */ - Emit14Inst( INST_STORE_SCALAR, resultIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + if (resultIndex != -1) { + Emit14Inst( INST_STORE_SCALAR, resultIndex, envPtr); + } + TclEmitOpcode( INST_POP, envPtr); + + TclCheckStackDepth(depth+1, envPtr); + return TCL_OK; +} + +/*---------------------------------------------------------------------- + * + * TclCompileClockClicksCmd -- + * + * Procedure called to compile the "tcl::clock::clicks" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to run time. + * + * Side effects: + * Instructions are added to envPtr to execute the "clock clicks" + * command at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileClockClicksCmd( + Tcl_Interp* interp, /* Tcl interpreter */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token* tokenPtr; + + switch (parsePtr->numWords) { + case 1: + /* + * No args + */ + TclEmitInstInt1(INST_CLOCK_READ, 0, envPtr); + break; + case 2: + /* + * -milliseconds or -microseconds + */ + tokenPtr = TokenAfter(parsePtr->tokenPtr); + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD + || tokenPtr[1].size < 4 + || tokenPtr[1].size > 13) { + return TCL_ERROR; + } else if (!strncmp(tokenPtr[1].start, "-microseconds", + tokenPtr[1].size)) { + TclEmitInstInt1(INST_CLOCK_READ, 1, envPtr); + break; + } else if (!strncmp(tokenPtr[1].start, "-milliseconds", + tokenPtr[1].size)) { + TclEmitInstInt1(INST_CLOCK_READ, 2, envPtr); + break; + } else { + return TCL_ERROR; + } + default: + return TCL_ERROR; + } + return TCL_OK; +} + + +/*---------------------------------------------------------------------- + * + * TclCompileClockReadingCmd -- + * + * Procedure called to compile the "tcl::clock::microseconds", + * "tcl::clock::milliseconds" and "tcl::clock::seconds" commands. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to run time. + * + * Side effects: + * Instructions are added to envPtr to execute the "clock clicks" + * command at runtime. + * + * Client data is 1 for microseconds, 2 for milliseconds, 3 for seconds. + *---------------------------------------------------------------------- + */ + +int +TclCompileClockReadingCmd( + Tcl_Interp* interp, /* Tcl interpreter */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + if (parsePtr->numWords != 1) { + return TCL_ERROR; + } + + TclEmitInstInt1(INST_CLOCK_READ, PTR2INT(cmdPtr->objClientData), envPtr); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileConcatCmd -- + * + * Procedure called to compile the "concat" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "concat" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileConcatCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Obj *objPtr, *listObj; + Tcl_Token *tokenPtr; + int i; + + /* TODO: Consider compiling expansion case. */ + if (parsePtr->numWords == 1) { + /* + * [concat] without arguments just pushes an empty object. + */ + + PushStringLiteral(envPtr, ""); + return TCL_OK; + } /* - * Stack is now ?script? ?returnOptions? returnCode. - * If the options dict has been requested, it is buried on the stack under - * the return code. Reverse the stack to bring it to the top, store it and - * remove it from the stack. + * Test if all arguments are compile-time known. If they are, we can + * implement with a simple push. */ - if (optsIndex != -1) { - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - Emit14Inst( INST_STORE_SCALAR, optsIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); + listObj = Tcl_NewObj(); + for (i = 1, tokenPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++) { + tokenPtr = TokenAfter(tokenPtr); + objPtr = Tcl_NewObj(); + if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) { + Tcl_DecrRefCount(objPtr); + Tcl_DecrRefCount(listObj); + listObj = NULL; + break; + } + (void) Tcl_ListObjAppendElement(NULL, listObj, objPtr); } + if (listObj != NULL) { + Tcl_Obj **objs; + const char *bytes; + int len; - dropScriptAtEnd: + Tcl_ListObjGetElements(NULL, listObj, &len, &objs); + objPtr = Tcl_ConcatObj(len, objs); + Tcl_DecrRefCount(listObj); + bytes = TclGetStringFromObj(objPtr, &len); + PushLiteral(envPtr, bytes, len); + Tcl_DecrRefCount(objPtr); + return TCL_OK; + } /* - * Stack is now ?script? result. Get rid of the subst'ed script if it's - * hanging arond. + * General case: runtime concat. */ - if (cmdTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - TclEmitOpcode( INST_POP, envPtr); + for (i = 1, tokenPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++) { + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, i); } + TclEmitInstInt4( INST_CONCAT_STK, i-1, envPtr); + return TCL_OK; } @@ -796,17 +983,14 @@ TclCompileContinueCmd( TclCleanupStackForBreakContinue(envPtr, auxPtr); TclAddLoopContinueFixup(envPtr, auxPtr); - TclAdjustStackDepth(1, envPtr); } else { /* * Emit a real continue. */ - PushStringLiteral(envPtr, ""); - TclEmitOpcode(INST_DUP, envPtr); - TclEmitInstInt4(INST_RETURN_IMM, TCL_CONTINUE, envPtr); - TclEmitInt4(0, envPtr); + TclEmitOpcode(INST_CONTINUE, envPtr); } + TclAdjustStackDepth(1, envPtr); return TCL_OK; } @@ -839,7 +1023,7 @@ TclCompileDictSetCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *tokenPtr; - int numWords, i, dictVarIndex; + int i, dictVarIndex; DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr; @@ -868,8 +1052,7 @@ TclCompileDictSetCmd( */ tokenPtr = TokenAfter(varTokenPtr); - numWords = parsePtr->numWords-1; - for (i=1 ; i<numWords ; i++) { + for (i=2 ; i< parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } @@ -878,7 +1061,7 @@ TclCompileDictSetCmd( * Now emit the instruction to do the dict manipulation. */ - TclEmitInstInt4( INST_DICT_SET, numWords-2, envPtr); + TclEmitInstInt4( INST_DICT_SET, parsePtr->numWords-3, envPtr); TclEmitInt4( dictVarIndex, envPtr); TclAdjustStackDepth(-1, envPtr); return TCL_OK; @@ -950,7 +1133,7 @@ TclCompileDictIncrCmd( * Emit the key and the code to actually do the increment. */ - CompileWord(envPtr, keyTokenPtr, interp, 3); + CompileWord(envPtr, keyTokenPtr, interp, 2); TclEmitInstInt4( INST_DICT_INCR_IMM, incrAmount, envPtr); TclEmitInt4( dictVarIndex, envPtr); return TCL_OK; @@ -966,7 +1149,7 @@ TclCompileDictGetCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *tokenPtr; - int numWords, i; + int i; DefineLineInformation; /* TIP #280 */ /* @@ -979,17 +1162,16 @@ TclCompileDictGetCmd( return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - numWords = parsePtr->numWords-1; /* * Only compile this because we need INST_DICT_GET anyway. */ - for (i=0 ; i<numWords ; i++) { + for (i=1 ; i<parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_DICT_GET, numWords-1, envPtr); + TclEmitInstInt4(INST_DICT_GET, parsePtr->numWords-2, envPtr); TclAdjustStackDepth(-1, envPtr); return TCL_OK; } @@ -1004,7 +1186,7 @@ TclCompileDictExistsCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *tokenPtr; - int numWords, i; + int i; DefineLineInformation; /* TIP #280 */ /* @@ -1017,17 +1199,16 @@ TclCompileDictExistsCmd( return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - numWords = parsePtr->numWords-1; /* * Now we do the code generation. */ - for (i=0 ; i<numWords ; i++) { + for (i=1 ; i<parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_DICT_EXISTS, numWords-1, envPtr); + TclEmitInstInt4(INST_DICT_EXISTS, parsePtr->numWords-2, envPtr); TclAdjustStackDepth(-1, envPtr); return TCL_OK; } @@ -1139,7 +1320,7 @@ TclCompileDictCreateCmd( * We did! Excellent. The "verifyDict" is to do type forcing. */ - bytes = Tcl_GetStringFromObj(dictObj, &len); + bytes = TclGetStringFromObj(dictObj, &len); PushLiteral(envPtr, bytes, len); TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_DICT_VERIFY, envPtr); @@ -1426,7 +1607,7 @@ CompileDictEachCmd( * this point. */ - CompileWord(envPtr, dictTokenPtr, interp, 3); + CompileWord(envPtr, dictTokenPtr, interp, 2); /* * Now we catch errors from here on so that we can finalize the search @@ -1632,10 +1813,10 @@ TclCompileDictUpdateCmd( * can't be snagged by literal sharing and forced to shimmer dangerously. */ - infoIndex = TclCreateAuxData(duiPtr, &tclDictUpdateInfoType, envPtr); + infoIndex = TclCreateAuxData(duiPtr, &dictUpdateInfoType, envPtr); for (i=0 ; i<numVars ; i++) { - CompileWord(envPtr, keyTokenPtrs[i], interp, i); + CompileWord(envPtr, keyTokenPtrs[i], interp, 2*i+2); } TclEmitInstInt4( INST_LIST, numVars, envPtr); TclEmitInstInt4( INST_DICT_UPDATE_START, dictIndex, envPtr); @@ -1678,7 +1859,7 @@ TclCompileDictUpdateCmd( TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr); TclEmitInt4( infoIndex, envPtr); - TclEmitOpcode( INST_RETURN_STK, envPtr); + TclEmitInvoke(envPtr,INST_RETURN_STK); if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d", @@ -1742,7 +1923,7 @@ TclCompileDictAppendCmd( tokenPtr = TokenAfter(tokenPtr); } if (parsePtr->numWords > 4) { - TclEmitInstInt1(INST_CONCAT1, parsePtr->numWords-3, envPtr); + TclEmitInstInt1(INST_STR_CONCAT1, parsePtr->numWords-3, envPtr); } /* @@ -1792,8 +1973,8 @@ TclCompileDictLappendCmd( * Issue the implementation. */ - CompileWord(envPtr, keyTokenPtr, interp, 3); - CompileWord(envPtr, valueTokenPtr, interp, 4); + CompileWord(envPtr, keyTokenPtr, interp, 2); + CompileWord(envPtr, valueTokenPtr, interp, 3); TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr); return TCL_OK; } @@ -1878,7 +2059,7 @@ TclCompileDictWithCmd( tokenPtr = TokenAfter(varTokenPtr); for (i=2 ; i<parsePtr->numWords-1 ; i++) { - CompileWord(envPtr, tokenPtr, interp, i-1); + CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr); @@ -1905,7 +2086,7 @@ TclCompileDictWithCmd( tokenPtr = varTokenPtr; for (i=1 ; i<parsePtr->numWords-1 ; i++) { - CompileWord(envPtr, tokenPtr, interp, i-1); + CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr); @@ -1919,7 +2100,7 @@ TclCompileDictWithCmd( * Case: Direct dict in non-simple var with empty body. */ - CompileWord(envPtr, varTokenPtr, interp, 0); + CompileWord(envPtr, varTokenPtr, interp, 1); TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_LOAD_STK, envPtr); PushStringLiteral(envPtr, ""); @@ -1954,13 +2135,13 @@ TclCompileDictWithCmd( */ if (dictVar == -1) { - CompileWord(envPtr, varTokenPtr, interp, 0); + CompileWord(envPtr, varTokenPtr, interp, 1); Emit14Inst( INST_STORE_SCALAR, varNameTmp, envPtr); } tokenPtr = TokenAfter(varTokenPtr); if (gotPath) { for (i=2 ; i<parsePtr->numWords-1 ; i++) { - CompileWord(envPtr, tokenPtr, interp, i-1); + CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt4( INST_LIST, parsePtr->numWords-3,envPtr); @@ -2036,7 +2217,7 @@ TclCompileDictWithCmd( } else { TclEmitInstInt4( INST_DICT_RECOMBINE_IMM, dictVar, envPtr); } - TclEmitOpcode( INST_RETURN_STK, envPtr); + TclEmitInvoke(envPtr, INST_RETURN_STK); /* * Prepare for the start of the next command. @@ -2061,11 +2242,13 @@ TclCompileDictWithCmd( * DupDictUpdateInfo: a copy of the auxiliary data * FreeDictUpdateInfo: none * PrintDictUpdateInfo: none + * DisassembleDictUpdateInfo: none * * Side effects: * DupDictUpdateInfo: allocates memory * FreeDictUpdateInfo: releases memory * PrintDictUpdateInfo: none + * DisassembleDictUpdateInfo: none * *---------------------------------------------------------------------- */ @@ -2108,6 +2291,25 @@ PrintDictUpdateInfo( Tcl_AppendPrintfToObj(appendObj, "%%v%u", duiPtr->varIndices[i]); } } + +static void +DisassembleDictUpdateInfo( + ClientData clientData, + Tcl_Obj *dictObj, + ByteCode *codePtr, + unsigned int pcOffset) +{ + DictUpdateInfo *duiPtr = clientData; + int i; + Tcl_Obj *variables = Tcl_NewObj(); + + for (i=0 ; i<duiPtr->length ; i++) { + Tcl_ListObjAppendElement(NULL, variables, + Tcl_NewIntObj(duiPtr->varIndices[i])); + } + Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("variables", -1), + variables); +} /* *---------------------------------------------------------------------- @@ -2138,19 +2340,48 @@ TclCompileErrorCmd( { /* * General syntax: [error message ?errorInfo? ?errorCode?] - * However, we only deal with the case where there is just a message. */ - Tcl_Token *messageTokenPtr; + + Tcl_Token *tokenPtr; DefineLineInformation; /* TIP #280 */ - if (parsePtr->numWords != 2) { + if (parsePtr->numWords < 2 || parsePtr->numWords > 4) { return TCL_ERROR; } - messageTokenPtr = TokenAfter(parsePtr->tokenPtr); - PushStringLiteral(envPtr, "-code error -level 0"); - CompileWord(envPtr, messageTokenPtr, interp, 1); - TclEmitOpcode(INST_RETURN_STK, envPtr); + /* + * Handle the message. + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + + /* + * Construct the options. Note that -code and -level are not here. + */ + + if (parsePtr->numWords == 2) { + PushStringLiteral(envPtr, ""); + } else { + PushStringLiteral(envPtr, "-errorinfo"); + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 2); + if (parsePtr->numWords == 3) { + TclEmitInstInt4( INST_LIST, 2, envPtr); + } else { + PushStringLiteral(envPtr, "-errorcode"); + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 3); + TclEmitInstInt4( INST_LIST, 4, envPtr); + } + } + + /* + * Issue the error via 'returnImm error 0'. + */ + + TclEmitInstInt4( INST_RETURN_IMM, TCL_ERROR, envPtr); + TclEmitInt4( 0, envPtr); return TCL_OK; } @@ -2228,7 +2459,7 @@ TclCompileForCmd( { Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr; JumpFixup jumpEvalCondFixup; - int testCodeOffset, bodyCodeOffset, nextCodeOffset, jumpDist; + int bodyCodeOffset, nextCodeOffset, jumpDist; int bodyRange, nextRange; DefineLineInformation; /* TIP #280 */ @@ -2309,13 +2540,9 @@ TclCompileForCmd( * terminates the for. */ - testCodeOffset = CurrentOffset(envPtr); - - jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset; - if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) { + if (TclFixupForwardJumpToHere(envPtr, &jumpEvalCondFixup, 127)) { bodyCodeOffset += 3; nextCodeOffset += 3; - testCodeOffset += 3; } SetLineInformation(2); @@ -2444,33 +2671,17 @@ CompileEachloopCmd( * (TCL_EACH_*) */ { Proc *procPtr = envPtr->procPtr; - ForeachInfo *infoPtr; /* Points to the structure describing this + ForeachInfo *infoPtr=NULL; /* Points to the structure describing this * foreach command. Stored in a AuxData * record in the ByteCode. */ - int firstValueTemp; /* Index of the first temp var in the frame - * used to point to a value list. */ - int loopCtTemp; /* Index of temp var holding the loop's - * iteration count. */ - int collectVar = -1; /* Index of temp var holding the result var - * index. */ Tcl_Token *tokenPtr, *bodyTokenPtr; - unsigned char *jumpPc; - JumpFixup jumpFalseFixup; - int jumpBackDist, jumpBackOffset, infoIndex, range; - int numWords, numLists, numVars, loopIndex, tempVar, i, j, code; + int jumpBackOffset, infoIndex, range; + int numWords, numLists, i, j, code = TCL_OK; + Tcl_Obj *varListObj = NULL; DefineLineInformation; /* TIP #280 */ /* - * We parse the variable list argument words and create two arrays: - * varcList[i] is number of variables in i-th var list. - * varvList[i] points to array of var names in i-th var list. - */ - - int *varcList; - const char ***varvList; - - /* * If the foreach command isn't in a procedure, don't compile it inline: * the payoff is too small. */ @@ -2498,260 +2709,148 @@ CompileEachloopCmd( } /* - * Allocate storage for the varcList and varvList arrays if necessary. + * Create and initialize the ForeachInfo and ForeachVarList data + * structures describing this command. Then create a AuxData record + * pointing to the ForeachInfo structure. */ numLists = (numWords - 2)/2; - varcList = TclStackAlloc(interp, numLists * sizeof(int)); - memset(varcList, 0, numLists * sizeof(int)); - varvList = (const char ***) TclStackAlloc(interp, - numLists * sizeof(const char **)); - memset((char*) varvList, 0, numLists * sizeof(const char **)); + infoPtr = ckalloc(sizeof(ForeachInfo) + + (numLists - 1) * sizeof(ForeachVarList *)); + infoPtr->numLists = 0; /* Count this up as we go */ /* - * Break up each var list and set the varcList and varvList arrays. Don't + * Parse each var list into sequence of var names. Don't * compile the foreach inline if any var name needs substitutions or isn't * a scalar, or if any var list needs substitutions. */ - loopIndex = 0; + varListObj = Tcl_NewObj(); for (i = 0, tokenPtr = parsePtr->tokenPtr; i < numWords-1; i++, tokenPtr = TokenAfter(tokenPtr)) { - Tcl_DString varList; + ForeachVarList *varListPtr; + int numVars; if (i%2 != 1) { continue; } - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - code = TCL_ERROR; - goto done; - } - - /* - * Lots of copying going on here. Need a ListObj wizard to show a - * better way. - */ - - Tcl_DStringInit(&varList); - TclDStringAppendToken(&varList, &tokenPtr[1]); - code = Tcl_SplitList(NULL, Tcl_DStringValue(&varList), - &varcList[loopIndex], &varvList[loopIndex]); - Tcl_DStringFree(&varList); - if (code != TCL_OK) { - code = TCL_ERROR; - goto done; - } - numVars = varcList[loopIndex]; /* * If the variable list is empty, we can enter an infinite loop when - * the interpreted version would not. Take care to ensure this does - * not happen. [Bug 1671138] + * the interpreted version would not. Take care to ensure this does + * not happen. [Bug 1671138] */ - if (numVars == 0) { + if (!TclWordKnownAtCompileTime(tokenPtr, varListObj) || + TCL_OK != Tcl_ListObjLength(NULL, varListObj, &numVars) || + numVars == 0) { code = TCL_ERROR; goto done; } - for (j = 0; j < numVars; j++) { - const char *varName = varvList[loopIndex][j]; + varListPtr = ckalloc(sizeof(ForeachVarList) + + (numVars - 1) * sizeof(int)); + varListPtr->numVars = numVars; + infoPtr->varLists[i/2] = varListPtr; + infoPtr->numLists++; - if (!TclIsLocalScalar(varName, (int) strlen(varName))) { + for (j = 0; j < numVars; j++) { + Tcl_Obj *varNameObj; + const char *bytes; + int numBytes, varIndex; + + Tcl_ListObjIndex(NULL, varListObj, j, &varNameObj); + bytes = TclGetStringFromObj(varNameObj, &numBytes); + varIndex = LocalScalar(bytes, numBytes, envPtr); + if (varIndex < 0) { code = TCL_ERROR; goto done; } + varListPtr->varIndexes[j] = varIndex; } - loopIndex++; + Tcl_SetObjLength(varListObj, 0); } - if (collect == TCL_EACH_COLLECT) { - collectVar = AnonymousLocal(envPtr); - if (collectVar < 0) { - return TCL_ERROR; - } - } - /* - * We will compile the foreach command. Reserve (numLists + 1) temporary - * variables: - * - numLists temps to hold each value list - * - 1 temp for the loop counter (index of next element in each list) - * - * At this time we don't try to reuse temporaries; if there are two - * nonoverlapping foreach loops, they don't share any temps. + * We will compile the foreach command. */ - code = TCL_OK; - firstValueTemp = -1; - for (loopIndex = 0; loopIndex < numLists; loopIndex++) { - tempVar = AnonymousLocal(envPtr); - if (loopIndex == 0) { - firstValueTemp = tempVar; - } - } - loopCtTemp = AnonymousLocal(envPtr); + infoIndex = TclCreateAuxData(infoPtr, &newForeachInfoType, envPtr); /* - * Create and initialize the ForeachInfo and ForeachVarList data - * structures describing this command. Then create a AuxData record - * pointing to the ForeachInfo structure. + * Create the collecting object, unshared. */ - infoPtr = ckalloc(sizeof(ForeachInfo) - + numLists * sizeof(ForeachVarList *)); - infoPtr->numLists = numLists; - infoPtr->firstValueTemp = firstValueTemp; - infoPtr->loopCtTemp = loopCtTemp; - for (loopIndex = 0; loopIndex < numLists; loopIndex++) { - ForeachVarList *varListPtr; - - numVars = varcList[loopIndex]; - varListPtr = ckalloc(sizeof(ForeachVarList) - + numVars * sizeof(int)); - varListPtr->numVars = numVars; - for (j = 0; j < numVars; j++) { - const char *varName = varvList[loopIndex][j]; - int nameChars = strlen(varName); - - varListPtr->varIndexes[j] = TclFindCompiledLocal(varName, - nameChars, /*create*/ 1, envPtr); - } - infoPtr->varLists[loopIndex] = varListPtr; + if (collect == TCL_EACH_COLLECT) { + TclEmitInstInt4(INST_LIST, 0, envPtr); } - infoIndex = TclCreateAuxData(infoPtr, &tclForeachInfoType, envPtr); - - /* - * Create an exception record to handle [break] and [continue]. - */ - - range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); /* - * Evaluate then store each value list in the associated temporary. + * Evaluate each value list and leave it on stack. */ - loopIndex = 0; for (i = 0, tokenPtr = parsePtr->tokenPtr; i < numWords-1; i++, tokenPtr = TokenAfter(tokenPtr)) { if ((i%2 == 0) && (i > 0)) { CompileWord(envPtr, tokenPtr, interp, i); - tempVar = (firstValueTemp + loopIndex); - Emit14Inst( INST_STORE_SCALAR, tempVar, envPtr); - TclEmitOpcode( INST_POP, envPtr); - loopIndex++; } } - /* - * Create temporary variable to capture return values from loop body. - */ - - if (collect == TCL_EACH_COLLECT) { - PushStringLiteral(envPtr, ""); - Emit14Inst( INST_STORE_SCALAR, collectVar, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - - /* - * Initialize the temporary var that holds the count of loop iterations. - */ - - TclEmitInstInt4( INST_FOREACH_START4, infoIndex, envPtr); - - /* - * Top of loop code: assign each loop variable and check whether - * to terminate the loop. - */ - - ExceptionRangeTarget(envPtr, range, continueOffset); - TclEmitInstInt4( INST_FOREACH_STEP4, infoIndex, envPtr); - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup); + TclEmitInstInt4(INST_FOREACH_START, infoIndex, envPtr); /* * Inline compile the loop body. */ + range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + ExceptionRangeStarts(envPtr, range); BODY(bodyTokenPtr, numWords - 1); ExceptionRangeEnds(envPtr, range); if (collect == TCL_EACH_COLLECT) { - Emit14Inst( INST_LAPPEND_SCALAR, collectVar,envPtr); - } - TclEmitOpcode( INST_POP, envPtr); - - /* - * Jump back to the test at the top of the loop. Generate a 4 byte jump if - * the distance to the test is > 120 bytes. This is conservative and - * ensures that we won't have to replace this jump if we later need to - * replace the ifFalse jump with a 4 byte jump. - */ - - jumpBackOffset = CurrentOffset(envPtr); - jumpBackDist = jumpBackOffset-envPtr->exceptArrayPtr[range].continueOffset; - if (jumpBackDist > 120) { - TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr); + TclEmitOpcode(INST_LMAP_COLLECT, envPtr); } else { - TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr); + TclEmitOpcode( INST_POP, envPtr); } /* - * Fix the target of the jump after the foreach_step test. + * Bottom of loop code: assign each loop variable and check whether + * to terminate the loop. Set the loop's break target. */ - if (TclFixupForwardJumpToHere(envPtr, &jumpFalseFixup, 127)) { - /* - * Update the loop body's starting PC offset since it moved down. - */ - - envPtr->exceptArrayPtr[range].codeOffset += 3; - - /* - * Update the jump back to the test at the top of the loop since it - * also moved down 3 bytes. - */ - - jumpBackOffset += 3; - jumpPc = (envPtr->codeStart + jumpBackOffset); - jumpBackDist += 3; - if (jumpBackDist > 120) { - TclUpdateInstInt4AtPc(INST_JUMP4, -jumpBackDist, jumpPc); - } else { - TclUpdateInstInt1AtPc(INST_JUMP1, -jumpBackDist, jumpPc); - } - } + ExceptionRangeTarget(envPtr, range, continueOffset); + TclEmitOpcode(INST_FOREACH_STEP, envPtr); + ExceptionRangeTarget(envPtr, range, breakOffset); + TclFinalizeLoopExceptionRange(envPtr, range); + TclEmitOpcode(INST_FOREACH_END, envPtr); + TclAdjustStackDepth(-(numLists+2), envPtr); /* - * Set the loop's break target. + * Set the jumpback distance from INST_FOREACH_STEP to the start of the + * body's code. Misuse loopCtTemp for storing the jump size. */ - ExceptionRangeTarget(envPtr, range, breakOffset); - TclFinalizeLoopExceptionRange(envPtr, range); + jumpBackOffset = envPtr->exceptArrayPtr[range].continueOffset - + envPtr->exceptArrayPtr[range].codeOffset; + infoPtr->loopCtTemp = -jumpBackOffset; /* - * The command's result is an empty string if not collecting, or the - * list of results from evaluating the loop body. + * The command's result is an empty string if not collecting. If + * collecting, it is automatically left on stack after FOREACH_END. */ - if (collect == TCL_EACH_COLLECT) { - Emit14Inst( INST_LOAD_SCALAR, collectVar, envPtr); - TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( collectVar, envPtr); - } else { + if (collect != TCL_EACH_COLLECT) { PushStringLiteral(envPtr, ""); } - done: - for (loopIndex = 0; loopIndex < numLists; loopIndex++) { - if (varvList[loopIndex] != NULL) { - ckfree(varvList[loopIndex]); - } + done: + if (code == TCL_ERROR) { + FreeForeachInfo(infoPtr); } - TclStackFree(interp, (void *)varvList); - TclStackFree(interp, varcList); + Tcl_DecrRefCount(varListObj); return code; } @@ -2845,10 +2944,10 @@ FreeForeachInfo( /* *---------------------------------------------------------------------- * - * PrintForeachInfo -- + * PrintForeachInfo, DisassembleForeachInfo -- * - * Function to write a human-readable representation of a ForeachInfo - * structure to stdout for debugging. + * Functions to write a human-readable or script-readablerepresentation + * of a ForeachInfo structure to a Tcl_Obj for debugging. * * Results: * None. @@ -2898,6 +2997,119 @@ PrintForeachInfo( Tcl_AppendToObj(appendObj, "]", -1); } } + +static void +PrintNewForeachInfo( + ClientData clientData, + Tcl_Obj *appendObj, + ByteCode *codePtr, + unsigned int pcOffset) +{ + register ForeachInfo *infoPtr = clientData; + register ForeachVarList *varsPtr; + int i, j; + + Tcl_AppendPrintfToObj(appendObj, "jumpOffset=%+d, vars=", + infoPtr->loopCtTemp); + for (i=0 ; i<infoPtr->numLists ; i++) { + if (i) { + Tcl_AppendToObj(appendObj, ",", -1); + } + Tcl_AppendToObj(appendObj, "[", -1); + varsPtr = infoPtr->varLists[i]; + for (j=0 ; j<varsPtr->numVars ; j++) { + if (j) { + Tcl_AppendToObj(appendObj, ",", -1); + } + Tcl_AppendPrintfToObj(appendObj, "%%v%u", + (unsigned) varsPtr->varIndexes[j]); + } + Tcl_AppendToObj(appendObj, "]", -1); + } +} + +static void +DisassembleForeachInfo( + ClientData clientData, + Tcl_Obj *dictObj, + ByteCode *codePtr, + unsigned int pcOffset) +{ + register ForeachInfo *infoPtr = clientData; + register ForeachVarList *varsPtr; + int i, j; + Tcl_Obj *objPtr, *innerPtr; + + /* + * Data stores. + */ + + objPtr = Tcl_NewObj(); + for (i=0 ; i<infoPtr->numLists ; i++) { + Tcl_ListObjAppendElement(NULL, objPtr, + Tcl_NewIntObj(infoPtr->firstValueTemp + i)); + } + Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("data", -1), objPtr); + + /* + * Loop counter. + */ + + Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("loop", -1), + Tcl_NewIntObj(infoPtr->loopCtTemp)); + + /* + * Assignment targets. + */ + + objPtr = Tcl_NewObj(); + for (i=0 ; i<infoPtr->numLists ; i++) { + innerPtr = Tcl_NewObj(); + varsPtr = infoPtr->varLists[i]; + for (j=0 ; j<varsPtr->numVars ; j++) { + Tcl_ListObjAppendElement(NULL, innerPtr, + Tcl_NewIntObj(varsPtr->varIndexes[j])); + } + Tcl_ListObjAppendElement(NULL, objPtr, innerPtr); + } + Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("assign", -1), objPtr); +} + +static void +DisassembleNewForeachInfo( + ClientData clientData, + Tcl_Obj *dictObj, + ByteCode *codePtr, + unsigned int pcOffset) +{ + register ForeachInfo *infoPtr = clientData; + register ForeachVarList *varsPtr; + int i, j; + Tcl_Obj *objPtr, *innerPtr; + + /* + * Jump offset. + */ + + Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("jumpOffset", -1), + Tcl_NewIntObj(infoPtr->loopCtTemp)); + + /* + * Assignment targets. + */ + + objPtr = Tcl_NewObj(); + for (i=0 ; i<infoPtr->numLists ; i++) { + innerPtr = Tcl_NewObj(); + varsPtr = infoPtr->varLists[i]; + for (j=0 ; j<varsPtr->numVars ; j++) { + Tcl_ListObjAppendElement(NULL, innerPtr, + Tcl_NewIntObj(varsPtr->varIndexes[j])); + } + Tcl_ListObjAppendElement(NULL, objPtr, innerPtr); + } + Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("assign", -1), objPtr); +} /* *---------------------------------------------------------------------- @@ -2986,7 +3198,7 @@ TclCompileFormatCmd( * literal. Job done. */ - bytes = Tcl_GetStringFromObj(tmpObj, &len); + bytes = TclGetStringFromObj(tmpObj, &len); PushLiteral(envPtr, bytes, len); Tcl_DecrRefCount(tmpObj); return TCL_OK; @@ -3057,7 +3269,7 @@ TclCompileFormatCmd( if (*++bytes == '%') { Tcl_AppendToObj(tmpObj, "%", 1); } else { - char *b = Tcl_GetStringFromObj(tmpObj, &len); + char *b = TclGetStringFromObj(tmpObj, &len); /* * If there is a non-empty literal from the format string, @@ -3091,7 +3303,7 @@ TclCompileFormatCmd( */ Tcl_AppendToObj(tmpObj, start, bytes - start); - bytes = Tcl_GetStringFromObj(tmpObj, &len); + bytes = TclGetStringFromObj(tmpObj, &len); if (len > 0) { PushLiteral(envPtr, bytes, len); i++; @@ -3104,18 +3316,7 @@ TclCompileFormatCmd( * Do the concatenation, which produces the result. */ - TclEmitInstInt1(INST_CONCAT1, i, envPtr); - } else { - /* - * EVIL HACK! Force there to be a string representation in the case - * where there's just a "%s" in the format; case covered by the test - * format-20.1 (and it is horrible...) - */ - - TclEmitOpcode(INST_DUP, envPtr); - PushStringLiteral(envPtr, ""); - TclEmitOpcode(INST_STR_EQ, envPtr); - TclEmitOpcode(INST_POP, envPtr); + TclEmitInstInt1(INST_STR_CONCAT1, i, envPtr); } return TCL_OK; } @@ -3123,6 +3324,54 @@ TclCompileFormatCmd( /* *---------------------------------------------------------------------- * + * TclLocalScalarFromToken -- + * + * Get the index into the table of compiled locals that corresponds + * to a local scalar variable name. + * + * Results: + * Returns the non-negative integer index value into the table of + * compiled locals corresponding to a local scalar variable name. + * If the arguments passed in do not identify a local scalar variable + * then return -1. + * + * Side effects: + * May add an entery into the table of compiled locals. + * + *---------------------------------------------------------------------- + */ + +int +TclLocalScalarFromToken( + Tcl_Token *tokenPtr, + CompileEnv *envPtr) +{ + int isScalar, index; + + TclPushVarName(NULL, tokenPtr, envPtr, TCL_NO_ELEMENT, &index, &isScalar); + if (!isScalar) { + index = -1; + } + return index; +} + +int +TclLocalScalar( + const char *bytes, + int numBytes, + CompileEnv *envPtr) +{ + Tcl_Token token[2] = {{TCL_TOKEN_SIMPLE_WORD, NULL, 0, 1}, + {TCL_TOKEN_TEXT, NULL, 0, 0}}; + + token[1].start = bytes; + token[1].size = numBytes; + return TclLocalScalarFromToken(token, envPtr); +} + +/* + *---------------------------------------------------------------------- + * * TclPushVarName -- * * Procedure used in the compiling where pushing a variable name is @@ -3178,16 +3427,7 @@ TclPushVarName( 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] != '{')) { + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { /* * A simple variable name. Divide it up into "name" and "elName" * strings. If it is not a local variable, look it up at runtime. @@ -3211,7 +3451,7 @@ TclPushVarName( } } - if ((elName != NULL) && elNameChars) { + if (!(flags & TCL_NO_ELEMENT) && (elName != NULL) && elNameChars) { /* * An array element, the element name is a simple string: * assemble the corresponding token. @@ -3226,7 +3466,7 @@ TclPushVarName( elemTokenCount = 1; } } - } else if (((n = varTokenPtr->numComponents) > 1) + } else if (interp && ((n = varTokenPtr->numComponents) > 1) && (varTokenPtr[1].type == TCL_TOKEN_TEXT) && (varTokenPtr[n].type == TCL_TOKEN_TEXT) && (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) { @@ -3262,9 +3502,10 @@ TclPushVarName( nameChars = p - varTokenPtr[1].start; elName = p + 1; remainingChars = (varTokenPtr[2].start - p) - 1; - elNameChars = (varTokenPtr[n].start-p) + varTokenPtr[n].size - 2; + elNameChars = (varTokenPtr[n].start-p) + varTokenPtr[n].size - 1; - if (remainingChars) { + if (!(flags & TCL_NO_ELEMENT)) { + if (remainingChars) { /* * Make a first token with the extra characters in the first * token. @@ -3284,13 +3525,14 @@ TclPushVarName( memcpy(elemTokenPtr+1, varTokenPtr+2, (n-1) * sizeof(Tcl_Token)); - } else { + } else { /* * Use the already available tokens. */ elemTokenPtr = &varTokenPtr[2]; elemTokenCount = n - 1; + } } } } @@ -3325,7 +3567,7 @@ TclPushVarName( localIndex = -1; } } - if (localIndex < 0) { + if (interp && localIndex < 0) { PushLiteral(envPtr, name, nameChars); } @@ -3342,7 +3584,7 @@ TclPushVarName( PushStringLiteral(envPtr, ""); } } - } else { + } else if (interp) { /* * The var name isn't simple: compile and push it. */ diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 150c378..1209caf 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -27,7 +27,41 @@ static void CompileReturnInternal(CompileEnv *envPtr, Tcl_Obj *returnOpts); static int IndexTailVarIfKnown(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr); + +/* + *---------------------------------------------------------------------- + * + * TclGetIndexFromToken -- + * + * Parse a token to determine if an index value is known at + * compile time. + * + * Returns: + * TCL_OK if parsing succeeded, and TCL_ERROR if it failed. + * + * Side effects: + * When TCL_OK is returned, the encoded index value is written + * to *index. + * + *---------------------------------------------------------------------- + */ + +int +TclGetIndexFromToken( + Tcl_Token *tokenPtr, + int before, + int after, + int *indexPtr) +{ + Tcl_Obj *tmpObj = Tcl_NewObj(); + int result = TCL_ERROR; + if (TclWordKnownAtCompileTime(tokenPtr, tmpObj)) { + result = TclIndexEncode(NULL, tmpObj, before, after, indexPtr); + } + Tcl_DecrRefCount(tmpObj); + return result; +} /* *---------------------------------------------------------------------- @@ -85,14 +119,20 @@ TclCompileGlobalCmd( */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); - for (i=2; i<=numWords; varTokenPtr = TokenAfter(varTokenPtr),i++) { + for (i=1; i<numWords; varTokenPtr = TokenAfter(varTokenPtr),i++) { localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr); if (localIndex < 0) { return TCL_ERROR; } - CompileWord(envPtr, varTokenPtr, interp, 1); + /* + * TODO: Consider what value can pass through the + * IndexTailVarIfKnown() screen. Full CompileWord() likely does not + * apply here. Push known value instead. + */ + + CompileWord(envPtr, varTokenPtr, interp, i); TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr); } @@ -232,7 +272,7 @@ TclCompileIfCmd( jumpIndex = jumpFalseFixupArray.next; jumpFalseFixupArray.next++; TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, - jumpFalseFixupArray.fixup+jumpIndex); + jumpFalseFixupArray.fixup + jumpIndex); } code = TCL_OK; } @@ -279,7 +319,7 @@ TclCompileIfCmd( } jumpEndFixupArray.next++; TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - jumpEndFixupArray.fixup+jumpIndex); + jumpEndFixupArray.fixup + jumpIndex); /* * Fix the target of the jumpFalse after the test. Generate a 4 @@ -291,7 +331,7 @@ TclCompileIfCmd( TclAdjustStackDepth(-1, envPtr); if (TclFixupForwardJumpToHere(envPtr, - jumpFalseFixupArray.fixup+jumpIndex, 120)) { + jumpFalseFixupArray.fixup + jumpIndex, 120)) { /* * Adjust the code offset for the proceeding jump to the end * of the "if" command. @@ -374,7 +414,7 @@ TclCompileIfCmd( for (j = jumpEndFixupArray.next; j > 0; j--) { jumpIndex = (j - 1); /* i.e. process the closest jump first. */ if (TclFixupForwardJumpToHere(envPtr, - jumpEndFixupArray.fixup+jumpIndex, 127)) { + jumpEndFixupArray.fixup + jumpIndex, 127)) { /* * Adjust the immediately preceeding "ifFalse" jump. We moved it's * target (just after this jump) down three bytes. @@ -584,6 +624,7 @@ TclCompileInfoCommandsCmd( * that the result needs to be list-ified. */ + /* TODO: Just push the known value */ CompileWord(envPtr, tokenPtr, interp, 1); TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr); TclEmitOpcode( INST_DUP, envPtr); @@ -810,28 +851,16 @@ TclCompileLappendCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr, *valueTokenPtr; - int isScalar, localIndex, numWords, i, fwd, offsetFwd; + int isScalar, localIndex, numWords, i; DefineLineInformation; /* TIP #280 */ - /* - * If we're not in a procedure, don't compile. - */ - - if (envPtr->procPtr == NULL) { - return TCL_ERROR; - } - /* TODO: Consider support for compiling expanded args. */ numWords = parsePtr->numWords; - if (numWords == 1) { + if (numWords < 3) { return TCL_ERROR; } - if (numWords != 3) { - /* - * LAPPEND instructions currently only handle one value, but we can - * handle some multi-value cases by stringing them together. - */ + if (numWords != 3 || envPtr->procPtr == NULL) { goto lappendMultiple; } @@ -885,42 +914,28 @@ TclCompileLappendCmd( return TCL_OK; lappendMultiple: - /* - * Can only handle the case where we are appending to a local scalar when - * there are multiple values to append. Fortunately, this is common. - */ - - if (envPtr->procPtr == NULL) { - return TCL_ERROR; - } varTokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT, + PushVarNameWord(interp, varTokenPtr, envPtr, 0, &localIndex, &isScalar, 1); - if (!isScalar || localIndex < 0) { - return TCL_ERROR; - } - - /* - * Definitely appending to a local scalar; generate the words and append - * them. - */ - valueTokenPtr = TokenAfter(varTokenPtr); for (i = 2 ; i < numWords ; i++) { CompileWord(envPtr, valueTokenPtr, interp, i); valueTokenPtr = TokenAfter(valueTokenPtr); } - TclEmitInstInt4( INST_LIST, numWords-2, envPtr); - TclEmitInstInt4( INST_EXIST_SCALAR, localIndex, envPtr); - offsetFwd = CurrentOffset(envPtr); - TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr); - Emit14Inst( INST_LOAD_SCALAR, localIndex, envPtr); - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - TclEmitOpcode( INST_LIST_CONCAT, envPtr); - fwd = CurrentOffset(envPtr) - offsetFwd; - TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); - Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); - + TclEmitInstInt4( INST_LIST, numWords - 2, envPtr); + if (isScalar) { + if (localIndex < 0) { + TclEmitOpcode( INST_LAPPEND_LIST_STK, envPtr); + } else { + TclEmitInstInt4(INST_LAPPEND_LIST, localIndex, envPtr); + } + } else { + if (localIndex < 0) { + TclEmitOpcode( INST_LAPPEND_LIST_ARRAY_STK, envPtr); + } else { + TclEmitInstInt4(INST_LAPPEND_LIST_ARRAY, localIndex,envPtr); + } + } return TCL_OK; } @@ -984,7 +999,7 @@ TclCompileLassignCmd( */ PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex, - &isScalar, idx+2); + &isScalar, idx + 2); /* * Emit instructions to get the idx'th item out of the list value on @@ -1023,7 +1038,7 @@ TclCompileLassignCmd( */ TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr); - TclEmitInt4( -2 /* == "end" */, envPtr); + TclEmitInt4( TCL_INDEX_END, envPtr); return TCL_OK; } @@ -1056,7 +1071,7 @@ TclCompileLindexCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *idxTokenPtr, *valTokenPtr; - int i, numWords = parsePtr->numWords; + int i, idx, numWords = parsePtr->numWords; DefineLineInformation; /* TIP #280 */ /* @@ -1074,46 +1089,28 @@ TclCompileLindexCmd( } idxTokenPtr = TokenAfter(valTokenPtr); - if (idxTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - Tcl_Obj *tmpObj; - int idx, result; - - tmpObj = Tcl_NewStringObj(idxTokenPtr[1].start, idxTokenPtr[1].size); - result = TclGetIntFromObj(NULL, tmpObj, &idx); - if (result == TCL_OK) { - if (idx < 0) { - result = TCL_ERROR; - } - } else { - result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx); - if (result == TCL_OK && idx > -2) { - result = TCL_ERROR; - } - } - TclDecrRefCount(tmpObj); - - if (result == TCL_OK) { - /* - * All checks have been completed, and we have exactly one of - * these constructs: - * lindex <arbitraryValue> <posInt> - * lindex <arbitraryValue> end-<posInt> - * This is best compiled as a push of the arbitrary value followed - * by an "immediate lindex" which is the most efficient variety. - */ - - CompileWord(envPtr, valTokenPtr, interp, 1); - TclEmitInstInt4( INST_LIST_INDEX_IMM, idx, envPtr); - return TCL_OK; - } - + if (TclGetIndexFromToken(idxTokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_BEFORE, + &idx) == TCL_OK) { /* - * If the conversion failed or the value was negative, we just keep on - * going with the more complex compilation. + * The idxTokenPtr parsed as a valid index value and was + * encoded as expected by INST_LIST_INDEX_IMM. + * + * NOTE: that we rely on indexing before a list producing the + * same result as indexing after a list. */ + + CompileWord(envPtr, valTokenPtr, interp, 1); + TclEmitInstInt4( INST_LIST_INDEX_IMM, idx, envPtr); + return TCL_OK; } /* + * If the value was not known at compile time, the conversion failed or + * the value was negative, we just keep on going with the more complex + * compilation. + */ + + /* * Push the operands onto the stack. */ @@ -1198,20 +1195,7 @@ TclCompileListCmd( valueTokenPtr = TokenAfter(valueTokenPtr); } if (listObj != NULL) { - int len; - const char *bytes = Tcl_GetStringFromObj(listObj, &len); - - PushLiteral(envPtr, bytes, len); - Tcl_DecrRefCount(listObj); - if (len > 0) { - /* - * Force list interpretation! - */ - - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_LIST_LENGTH, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } + TclEmitPush(TclAddLiteralObj(envPtr, listObj, NULL), envPtr); return TCL_OK; } @@ -1259,7 +1243,7 @@ TclCompileListCmd( if (concat && numWords == 2) { TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); - TclEmitInt4( -2, envPtr); + TclEmitInt4( TCL_INDEX_END, envPtr); } return TCL_OK; } @@ -1326,67 +1310,32 @@ TclCompileLrangeCmd( { Tcl_Token *tokenPtr, *listTokenPtr; DefineLineInformation; /* TIP #280 */ - Tcl_Obj *tmpObj; - int idx1, idx2, result; + int idx1, idx2; if (parsePtr->numWords != 4) { return TCL_ERROR; } listTokenPtr = TokenAfter(parsePtr->tokenPtr); - /* - * Parse the first index. Will only compile if it is constant and not an - * _integer_ less than zero (since we reserve negative indices here for - * end-relative indexing). - */ - tokenPtr = TokenAfter(listTokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_AFTER, + &idx1) != TCL_OK) { return TCL_ERROR; } - tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size); - result = TclGetIntFromObj(NULL, tmpObj, &idx1); - if (result == TCL_OK) { - if (idx1 < 0) { - result = TCL_ERROR; - } - } else { - result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx1); - if (result == TCL_OK && idx1 > -2) { - result = TCL_ERROR; - } - } - TclDecrRefCount(tmpObj); - if (result != TCL_OK) { - return TCL_ERROR; - } - /* - * Parse the second index. Will only compile if it is constant and not an - * _integer_ less than zero (since we reserve negative indices here for - * end-relative indexing). + * Token was an index value, and we treat all "first" indices + * before the list same as the start of the list. */ tokenPtr = TokenAfter(tokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size); - result = TclGetIntFromObj(NULL, tmpObj, &idx2); - if (result == TCL_OK) { - if (idx2 < 0) { - result = TCL_ERROR; - } - } else { - result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx2); - if (result == TCL_OK && idx2 > -2) { - result = TCL_ERROR; - } - } - TclDecrRefCount(tmpObj); - if (result != TCL_OK) { + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END, + &idx2) != TCL_OK) { return TCL_ERROR; } + /* + * Token was an index value, and we treat all "last" indices + * after the list same as the end of the list. + */ /* * Issue instructions. It's not safe to skip doing the LIST_RANGE, as @@ -1403,19 +1352,16 @@ TclCompileLrangeCmd( /* *---------------------------------------------------------------------- * - * TclCompileLreplaceCmd -- + * TclCompileLinsertCmd -- * - * How to compile the "lreplace" command. We only bother with the case - * where there are no elements to insert and where both the 'first' and - * 'last' arguments are constant and one can be deterined to be at the - * end of the list. (This is the case that could also be written with - * "lrange".) + * How to compile the "linsert" command. We only bother with the case + * where the index is constant. * *---------------------------------------------------------------------- */ int -TclCompileLreplaceCmd( +TclCompileLinsertCmd( Tcl_Interp *interp, /* Tcl interpreter for context. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the * command. */ @@ -1425,102 +1371,270 @@ TclCompileLreplaceCmd( { Tcl_Token *tokenPtr, *listTokenPtr; DefineLineInformation; /* TIP #280 */ - Tcl_Obj *tmpObj; - int idx1, idx2, result, guaranteedDropAll = 0; + int idx, i; - if (parsePtr->numWords != 4) { + if (parsePtr->numWords < 3) { return TCL_ERROR; } listTokenPtr = TokenAfter(parsePtr->tokenPtr); /* - * Parse the first index. Will only compile if it is constant and not an + * Parse the index. Will only compile if it is constant and not an * _integer_ less than zero (since we reserve negative indices here for - * end-relative indexing). + * end-relative indexing) or an end-based index greater than 'end' itself. */ tokenPtr = TokenAfter(listTokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + + /* + * NOTE: This command treats all inserts at indices before the list + * the same as inserts at the start of the list, and all inserts + * after the list the same as inserts at the end of the list. We + * make that transformation here so we can use the optimized bytecode + * as much as possible. + */ + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_END, + &idx) != TCL_OK) { return TCL_ERROR; } - tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size); - result = TclGetIntFromObj(NULL, tmpObj, &idx1); - if (result == TCL_OK) { - if (idx1 < 0) { - result = TCL_ERROR; - } + + /* + * There are four main cases. If there are no values to insert, this is + * just a confirm-listiness check. If the index is '0', this is a prepend. + * If the index is 'end' (== TCL_INDEX_END), this is an append. Otherwise, + * this is a splice (== split, insert values as list, concat-3). + */ + + CompileWord(envPtr, listTokenPtr, interp, 1); + if (parsePtr->numWords == 3) { + TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); + TclEmitInt4( TCL_INDEX_END, envPtr); + return TCL_OK; + } + + for (i=3 ; i<parsePtr->numWords ; i++) { + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, i); + } + TclEmitInstInt4( INST_LIST, i - 3, envPtr); + + if (idx == TCL_INDEX_START) { + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + } else if (idx == TCL_INDEX_END) { + TclEmitOpcode( INST_LIST_CONCAT, envPtr); } else { - result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx1); - if (result == TCL_OK && idx1 > -2) { - result = TCL_ERROR; + /* + * Here we handle two ranges for idx. First when idx > 0, we + * want the first half of the split to end at index idx-1 and + * the second half to start at index idx. + * Second when idx < TCL_INDEX_END, indicating "end-N" indexing, + * we want the first half of the split to end at index end-N and + * the second half to start at index end-N+1. We accomplish this + * with a pre-adjustment of the end-N value. + * The root of this is that the commands [lrange] and [linsert] + * differ in their interpretation of the "end" index. + */ + + if (idx < TCL_INDEX_END) { + idx++; } + TclEmitInstInt4( INST_OVER, 1, envPtr); + TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); + TclEmitInt4( idx - 1, envPtr); + TclEmitInstInt4( INST_REVERSE, 3, envPtr); + TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr); + TclEmitInt4( TCL_INDEX_END, envPtr); + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileLreplaceCmd -- + * + * How to compile the "lreplace" command. We only bother with the case + * where the indices are constant. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLreplaceCmd( + Tcl_Interp *interp, /* Tcl interpreter for context. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the + * command. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds the resulting instructions. */ +{ + Tcl_Token *tokenPtr, *listTokenPtr; + DefineLineInformation; /* TIP #280 */ + int idx1, idx2, i, offset, offset2; + int emptyPrefix=1, suffixStart = 0; + + if (parsePtr->numWords < 4) { + return TCL_ERROR; + } + listTokenPtr = TokenAfter(parsePtr->tokenPtr); + + tokenPtr = TokenAfter(listTokenPtr); + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_AFTER, + &idx1) != TCL_OK) { + return TCL_ERROR; } - TclDecrRefCount(tmpObj); - if (result != TCL_OK) { + + tokenPtr = TokenAfter(tokenPtr); + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END, + &idx2) != TCL_OK) { return TCL_ERROR; } /* - * Parse the second index. Will only compile if it is constant and not an - * _integer_ less than zero (since we reserve negative indices here for - * end-relative indexing). + * idx1, idx2 are the conventional encoded forms of the tokens parsed + * as all forms of index values. Values of idx1 that come before the + * list are treated the same as if they were the start of the list. + * Values of idx2 that come after the list are treated the same as if + * they were the end of the list. */ - tokenPtr = TokenAfter(tokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + if (idx1 == TCL_INDEX_AFTER) { + /* + * [lreplace] treats idx1 value end+1 differently from end+2, etc. + * The operand encoding cannot distinguish them, so we must bail + * out to direct evaluation. + */ return TCL_ERROR; } - tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size); - result = TclGetIntFromObj(NULL, tmpObj, &idx2); - if (result == TCL_OK) { - if (idx2 < 0) { - result = TCL_ERROR; - } + + /* + * General structure of the [lreplace] result is + * prefix replacement suffix + * In a few cases we can predict various parts will be empty and + * take advantage. + * + * The proper suffix begins with the greater of indices idx1 or + * idx2 + 1. If we cannot tell at compile time which is greater, + * we must defer to direct evaluation. + */ + + if (idx2 == TCL_INDEX_BEFORE) { + suffixStart = idx1; + } else if (idx2 == TCL_INDEX_END) { + suffixStart = TCL_INDEX_AFTER; + } else if (((idx2 < TCL_INDEX_END) && (idx1 <= TCL_INDEX_END)) + || ((idx2 >= TCL_INDEX_START) && (idx1 >= TCL_INDEX_START))) { + suffixStart = (idx1 > idx2 + 1) ? idx1 : idx2 + 1; } else { - result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx2); - if (result == TCL_OK && idx2 > -2) { - result = TCL_ERROR; - } - } - TclDecrRefCount(tmpObj); - if (result != TCL_OK) { return TCL_ERROR; } + /* All paths start with computing/pushing the original value. */ + CompileWord(envPtr, listTokenPtr, interp, 1); + /* - * Sanity check: can only issue when we're removing a range at one or - * other end of the list. If we're at one end or the other, convert the - * indices into the equivalent for an [lrange]. + * Push all the replacement values next so any errors raised in + * creating them get raised first. */ - - if (idx1 == 0) { - if (idx2 == -2) { - guaranteedDropAll = 1; + if (parsePtr->numWords > 4) { + /* Push the replacement arguments */ + tokenPtr = TokenAfter(tokenPtr); + for (i=4 ; i<parsePtr->numWords ; i++) { + CompileWord(envPtr, tokenPtr, interp, i); + tokenPtr = TokenAfter(tokenPtr); } - idx1 = idx2 + 1; - idx2 = -2; - } else if (idx2 == -2) { - idx2 = idx1 - 1; - idx1 = 0; - } else { - return TCL_ERROR; + + /* Make a list of them... */ + TclEmitInstInt4( INST_LIST, i - 4, envPtr); + + emptyPrefix = 0; } /* - * Issue instructions. It's not safe to skip doing the LIST_RANGE, as - * we've not proved that the 'list' argument is really a list. Not that it - * is worth trying to do that given current knowledge. + * [lreplace] raises an error when idx1 points after the list, but + * only when the list is not empty. This is maximum stupidity. + * + * TODO: TIP this nonsense away! */ - - CompileWord(envPtr, listTokenPtr, interp, 1); - if (guaranteedDropAll) { + if (idx1 >= TCL_INDEX_START) { + if (emptyPrefix) { + TclEmitOpcode( INST_DUP, envPtr); + } else { + TclEmitInstInt4( INST_OVER, 1, envPtr); + } TclEmitOpcode( INST_LIST_LENGTH, envPtr); + TclEmitOpcode( INST_DUP, envPtr); + offset = CurrentOffset(envPtr); + TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr); + + /* List is not empty */ + TclEmitPush(TclAddLiteralObj(envPtr, Tcl_NewIntObj(idx1), + NULL), envPtr); + TclEmitOpcode( INST_GT, envPtr); + offset2 = CurrentOffset(envPtr); + TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr); + + /* Idx1 >= list length ===> raise an error */ + TclEmitPush(TclAddLiteralObj(envPtr, Tcl_ObjPrintf( + "list doesn't contain element %d", idx1), NULL), envPtr); + CompileReturnInternal(envPtr, INST_RETURN_IMM, TCL_ERROR, 0, + Tcl_ObjPrintf("-errorcode {TCL OPERATION LREPLACE BADIDX}")); + TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset, + envPtr->codeStart + offset + 1); TclEmitOpcode( INST_POP, envPtr); - PushStringLiteral(envPtr, ""); + TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset2, + envPtr->codeStart + offset2 + 1); + } + + if ((idx1 == suffixStart) && (parsePtr->numWords == 4)) { + /* + * This is a "no-op". Example: [lreplace {a b c} 2 0] + * We still do a list operation to get list-verification + * and canonicalization side effects. + */ + TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); + TclEmitInt4( TCL_INDEX_END, envPtr); + return TCL_OK; + } + + if (idx1 != TCL_INDEX_START) { + /* Prefix may not be empty; generate bytecode to push it */ + if (emptyPrefix) { + TclEmitOpcode( INST_DUP, envPtr); + } else { + TclEmitInstInt4( INST_OVER, 1, envPtr); + } + TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); + TclEmitInt4( idx1 - 1, envPtr); + if (!emptyPrefix) { + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + } + emptyPrefix = 0; + } + + if (!emptyPrefix) { + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + } + + if (suffixStart == TCL_INDEX_AFTER) { + TclEmitOpcode( INST_POP, envPtr); + if (emptyPrefix) { + PushStringLiteral(envPtr, ""); + } } else { - TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr); - TclEmitInt4( idx2, envPtr); + /* Suffix may not be empty; generate bytecode to push it */ + TclEmitInstInt4( INST_LIST_RANGE_IMM, suffixStart, envPtr); + TclEmitInt4( TCL_INDEX_END, envPtr); + if (!emptyPrefix) { + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + } } + return TCL_OK; } @@ -1787,6 +1901,28 @@ TclCompileNamespaceCodeCmd( } int +TclCompileNamespaceOriginCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(parsePtr->tokenPtr); + + CompileWord(envPtr, tokenPtr, interp, 1); + TclEmitOpcode( INST_ORIGIN_COMMAND, envPtr); + return TCL_OK; +} + +int TclCompileNamespaceQualifiersCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command @@ -1869,7 +2005,7 @@ TclCompileNamespaceUpvarCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; - int isScalar, localIndex, numWords, i; + int localIndex, numWords, i; DefineLineInformation; /* TIP #280 */ if (envPtr->procPtr == NULL) { @@ -1899,15 +2035,13 @@ TclCompileNamespaceUpvarCmd( */ localTokenPtr = tokenPtr; - for (i=3; i<=numWords; i+=2) { + for (i=2; i<numWords; i+=2) { otherTokenPtr = TokenAfter(localTokenPtr); localTokenPtr = TokenAfter(otherTokenPtr); - CompileWord(envPtr, otherTokenPtr, interp, 1); - PushVarNameWord(interp, localTokenPtr, envPtr, 0, - &localIndex, &isScalar, 1); - - if ((localIndex < 0) || !isScalar) { + CompileWord(envPtr, otherTokenPtr, interp, i); + localIndex = LocalScalarFromToken(localTokenPtr, envPtr); + if (localIndex < 0) { return TCL_ERROR; } TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr); @@ -2093,7 +2227,7 @@ TclCompileRegexpCmd( * converted pattern as a literal. */ - if (TclReToGlob(NULL, varTokenPtr[1].start, len, &ds, &exact) + if (TclReToGlob(NULL, varTokenPtr[1].start, len, &ds, &exact, NULL) == TCL_OK) { simple = 1; PushLiteral(envPtr, Tcl_DStringValue(&ds),Tcl_DStringLength(&ds)); @@ -2102,7 +2236,7 @@ TclCompileRegexpCmd( } if (!simple) { - CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-2); + CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords - 2); } /* @@ -2110,7 +2244,7 @@ TclCompileRegexpCmd( */ varTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-1); + CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords - 1); if (simple) { if (exact && !nocase) { @@ -2185,7 +2319,7 @@ TclCompileRegsubCmd( Tcl_Obj *patternObj = NULL, *replacementObj = NULL; Tcl_DString pattern; const char *bytes; - int len, exact, result = TCL_ERROR; + int len, exact, quantified, result = TCL_ERROR; if (parsePtr->numWords < 5 || parsePtr->numWords > 6) { return TCL_ERROR; @@ -2244,8 +2378,9 @@ TclCompileRegsubCmd( * replacement "simple"? */ - bytes = Tcl_GetStringFromObj(patternObj, &len); - if (TclReToGlob(NULL, bytes, len, &pattern, &exact) != TCL_OK || exact) { + bytes = TclGetStringFromObj(patternObj, &len); + if (TclReToGlob(NULL, bytes, len, &pattern, &exact, &quantified) + != TCL_OK || exact || quantified) { goto done; } bytes = Tcl_DStringValue(&pattern); @@ -2291,9 +2426,9 @@ TclCompileRegsubCmd( result = TCL_OK; bytes = Tcl_DStringValue(&pattern) + 1; PushLiteral(envPtr, bytes, len); - bytes = Tcl_GetStringFromObj(replacementObj, &len); + bytes = TclGetStringFromObj(replacementObj, &len); PushLiteral(envPtr, bytes, len); - CompileWord(envPtr, stringTokenPtr, interp, parsePtr->numWords-2); + CompileWord(envPtr, stringTokenPtr, interp, parsePtr->numWords - 2); TclEmitOpcode( INST_STR_MAP, envPtr); done: @@ -2363,7 +2498,7 @@ TclCompileReturnCmd( CompileWord(envPtr, optsTokenPtr, interp, 2); CompileWord(envPtr, msgTokenPtr, interp, 3); - TclEmitOpcode(INST_RETURN_STK, envPtr); + TclEmitInvoke(envPtr, INST_RETURN_STK); return TCL_OK; } @@ -2377,6 +2512,10 @@ TclCompileReturnCmd( * Scan through the return options. If any are unknown at compile time, * there is no value in bytecompiling. Save the option values known in an * objv array for merging into a return options dictionary. + * + * TODO: There is potential for improvement if all option keys are known + * at compile time and all option values relating to '-code' and '-level' + * are known at compile time. */ for (objc = 0; objc < numOptionWords; objc++) { @@ -2384,7 +2523,7 @@ TclCompileReturnCmd( Tcl_IncrRefCount(objv[objc]); if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) { /* - * Non-literal, so punt to run-time. + * Non-literal, so punt to run-time assembly of the dictionary. */ for (; objc>=0 ; objc--) { @@ -2418,7 +2557,7 @@ TclCompileReturnCmd( */ if (explicitResult) { - CompileWord(envPtr, wordTokenPtr, interp, numWords-1); + CompileWord(envPtr, wordTokenPtr, interp, numWords - 1); } else { /* * No explict result argument, so default result is empty string. @@ -2496,7 +2635,7 @@ TclCompileReturnCmd( */ if (explicitResult) { - CompileWord(envPtr, wordTokenPtr, interp, numWords-1); + CompileWord(envPtr, wordTokenPtr, interp, numWords - 1); } else { PushStringLiteral(envPtr, ""); } @@ -2505,7 +2644,7 @@ TclCompileReturnCmd( * Issue the RETURN itself. */ - TclEmitOpcode(INST_RETURN_STK, envPtr); + TclEmitInvoke(envPtr, INST_RETURN_STK); return TCL_OK; } @@ -2517,6 +2656,23 @@ CompileReturnInternal( int level, Tcl_Obj *returnOpts) { + if (level == 0 && (code == TCL_BREAK || code == TCL_CONTINUE)) { + ExceptionRange *rangePtr; + ExceptionAux *exceptAux; + + rangePtr = TclGetInnermostExceptionRange(envPtr, code, &exceptAux); + if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) { + TclCleanupStackForBreakContinue(envPtr, exceptAux); + if (code == TCL_BREAK) { + TclAddLoopBreakFixup(envPtr, exceptAux); + } else { + TclAddLoopContinueFixup(envPtr, exceptAux); + } + Tcl_DecrRefCount(returnOpts); + return; + } + } + TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr); TclEmitInstInt4(op, code, envPtr); TclEmitInt4(level, envPtr); @@ -2532,7 +2688,7 @@ TclCompileSyntaxError( const char *bytes = TclGetStringFromObj(msg, &numBytes); TclErrorStackResetIf(interp, bytes, numBytes); - TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr); + TclEmitPush(TclRegisterLiteral(envPtr, bytes, numBytes, 0), envPtr); CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0, TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR))); Tcl_ResetResult(interp); @@ -2566,18 +2722,16 @@ TclCompileUpvarCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; - int isScalar, localIndex, numWords, i; + int localIndex, numWords, i; DefineLineInformation; /* TIP #280 */ - Tcl_Obj *objPtr = Tcl_NewObj(); + Tcl_Obj *objPtr; if (envPtr->procPtr == NULL) { - Tcl_DecrRefCount(objPtr); return TCL_ERROR; } numWords = parsePtr->numWords; if (numWords < 3) { - Tcl_DecrRefCount(objPtr); return TCL_ERROR; } @@ -2585,6 +2739,7 @@ TclCompileUpvarCmd( * Push the frame index if it is known at compile time */ + objPtr = Tcl_NewObj(); tokenPtr = TokenAfter(parsePtr->tokenPtr); if (TclWordKnownAtCompileTime(tokenPtr, objPtr)) { CallFrame *framePtr; @@ -2603,16 +2758,17 @@ TclCompileUpvarCmd( if (numWords%2) { return TCL_ERROR; } + /* TODO: Push the known value instead? */ CompileWord(envPtr, tokenPtr, interp, 1); otherTokenPtr = TokenAfter(tokenPtr); - i = 4; + i = 2; } else { if (!(numWords%2)) { return TCL_ERROR; } PushStringLiteral(envPtr, "1"); otherTokenPtr = tokenPtr; - i = 3; + i = 1; } } else { Tcl_DecrRefCount(objPtr); @@ -2625,14 +2781,12 @@ TclCompileUpvarCmd( * be called at runtime. */ - for (; i<=numWords; i+=2, otherTokenPtr = TokenAfter(localTokenPtr)) { + for (; i<numWords; i+=2, otherTokenPtr = TokenAfter(localTokenPtr)) { localTokenPtr = TokenAfter(otherTokenPtr); - CompileWord(envPtr, otherTokenPtr, interp, 1); - PushVarNameWord(interp, localTokenPtr, envPtr, 0, - &localIndex, &isScalar, 1); - - if ((localIndex < 0) || !isScalar) { + CompileWord(envPtr, otherTokenPtr, interp, i); + localIndex = LocalScalarFromToken(localTokenPtr, envPtr); + if (localIndex < 0) { return TCL_ERROR; } TclEmitInstInt4( INST_UPVAR, localIndex, envPtr); @@ -2706,15 +2860,18 @@ TclCompileVariableCmd( return TCL_ERROR; } + /* TODO: Consider what value can pass through the + * IndexTailVarIfKnown() screen. Full CompileWord() + * likely does not apply here. Push known value instead. */ CompileWord(envPtr, varTokenPtr, interp, i); TclEmitInstInt4( INST_VARIABLE, localIndex, envPtr); - if (i+1 < numWords) { + if (i + 1 < numWords) { /* * A value has been given: set the variable, pop the value */ - CompileWord(envPtr, valueTokenPtr, interp, i+1); + CompileWord(envPtr, valueTokenPtr, interp, i + 1); Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); TclEmitOpcode( INST_POP, envPtr); } @@ -2779,16 +2936,18 @@ IndexTailVarIfKnown( } else { full = 0; lastTokenPtr = varTokenPtr + n; - if (!TclWordKnownAtCompileTime(lastTokenPtr, tailPtr)) { + + if (lastTokenPtr->type != TCL_TOKEN_TEXT) { Tcl_DecrRefCount(tailPtr); return -1; } + Tcl_SetStringObj(tailPtr, lastTokenPtr->start, lastTokenPtr->size); } tailName = TclGetStringFromObj(tailPtr, &len); if (len) { - if (*(tailName+len-1) == ')') { + if (*(tailName + len - 1) == ')') { /* * Possible array: bail out */ @@ -2802,7 +2961,7 @@ IndexTailVarIfKnown( */ for (p = tailName + len -1; p > tailName; p--) { - if ((*p == ':') && (*(p-1) == ':')) { + if ((*p == ':') && (*(p - 1) == ':')) { p++; break; } @@ -2824,6 +2983,66 @@ IndexTailVarIfKnown( return localIndex; } +/* + * ---------------------------------------------------------------------- + * + * TclCompileObjectNextCmd, TclCompileObjectSelfCmd -- + * + * Compilations of the TclOO utility commands [next] and [self]. + * + * ---------------------------------------------------------------------- + */ + +int +TclCompileObjectNextCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = parsePtr->tokenPtr; + int i; + + if (parsePtr->numWords > 255) { + return TCL_ERROR; + } + + for (i=0 ; i<parsePtr->numWords ; i++) { + CompileWord(envPtr, tokenPtr, interp, i); + tokenPtr = TokenAfter(tokenPtr); + } + TclEmitInstInt1( INST_TCLOO_NEXT, i, envPtr); + return TCL_OK; +} + +int +TclCompileObjectNextToCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = parsePtr->tokenPtr; + int i; + + if (parsePtr->numWords < 2 || parsePtr->numWords > 255) { + return TCL_ERROR; + } + + for (i=0 ; i<parsePtr->numWords ; i++) { + CompileWord(envPtr, tokenPtr, interp, i); + tokenPtr = TokenAfter(tokenPtr); + } + TclEmitInstInt1( INST_TCLOO_NEXT_CLASS, i, envPtr); + return TCL_OK; +} + int TclCompileObjectSelfCmd( Tcl_Interp *interp, /* Used for error reporting. */ diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index d1eb9db..9434e54 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -17,6 +17,7 @@ #include "tclInt.h" #include "tclCompile.h" +#include "tclStringTrim.h" /* * Prototypes for procedures defined later in this file: @@ -27,6 +28,9 @@ static void FreeJumptableInfo(ClientData clientData); static void PrintJumptableInfo(ClientData clientData, Tcl_Obj *appendObj, ByteCode *codePtr, unsigned int pcOffset); +static void DisassembleJumptableInfo(ClientData clientData, + Tcl_Obj *dictObj, ByteCode *codePtr, + unsigned int pcOffset); static int CompileAssociativeBinaryOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, const char *identity, int instruction, CompileEnv *envPtr); @@ -71,7 +75,8 @@ const AuxDataType tclJumptableInfoType = { "JumptableInfo", /* name */ DupJumptableInfo, /* dupProc */ FreeJumptableInfo, /* freeProc */ - PrintJumptableInfo /* printProc */ + PrintJumptableInfo, /* printProc */ + DisassembleJumptableInfo /* disassembleProc */ }; /* @@ -99,6 +104,9 @@ const AuxDataType tclJumptableInfoType = { if ((idx)<256) {OP1(LOAD_SCALAR1,(idx));} else {OP4(LOAD_SCALAR4,(idx));} #define STORE(idx) \ if ((idx)<256) {OP1(STORE_SCALAR1,(idx));} else {OP4(STORE_SCALAR4,(idx));} +#define INVOKE(name) \ + TclEmitInvoke(envPtr,INST_##name) + /* *---------------------------------------------------------------------- @@ -213,6 +221,78 @@ TclCompileSetCmd( */ int +TclCompileStringCatCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + int i, numWords = parsePtr->numWords, numArgs; + Tcl_Token *wordTokenPtr; + Tcl_Obj *obj, *folded; + DefineLineInformation; /* TIP #280 */ + + /* Trivial case, no arg */ + + if (numWords<2) { + PushStringLiteral(envPtr, ""); + return TCL_OK; + } + + /* General case: issue CONCAT1's (by chunks of 254 if needed), folding + contiguous constants along the way */ + + numArgs = 0; + folded = NULL; + wordTokenPtr = TokenAfter(parsePtr->tokenPtr); + for (i = 1; i < numWords; i++) { + obj = Tcl_NewObj(); + if (TclWordKnownAtCompileTime(wordTokenPtr, obj)) { + if (folded) { + Tcl_AppendObjToObj(folded, obj); + Tcl_DecrRefCount(obj); + } else { + folded = obj; + } + } else { + Tcl_DecrRefCount(obj); + if (folded) { + int len; + const char *bytes = TclGetStringFromObj(folded, &len); + + PushLiteral(envPtr, bytes, len); + Tcl_DecrRefCount(folded); + folded = NULL; + numArgs ++; + } + CompileWord(envPtr, wordTokenPtr, interp, i); + numArgs ++; + if (numArgs >= 254) { /* 254 to take care of the possible +1 of "folded" above */ + TclEmitInstInt1(INST_STR_CONCAT1, numArgs, envPtr); + numArgs = 1; /* concat pushes 1 obj, the result */ + } + } + wordTokenPtr = TokenAfter(wordTokenPtr); + } + if (folded) { + int len; + const char *bytes = TclGetStringFromObj(folded, &len); + + PushLiteral(envPtr, bytes, len); + Tcl_DecrRefCount(folded); + folded = NULL; + numArgs ++; + } + if (numArgs > 1) { + TclEmitInstInt1(INST_STR_CONCAT1, numArgs, envPtr); + } + + return TCL_OK; +} + +int TclCompileStringCmpCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command @@ -369,6 +449,284 @@ TclCompileStringIndexCmd( } int +TclCompileStringIsCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); + static const char *const isClasses[] = { + "alnum", "alpha", "ascii", "control", + "boolean", "digit", "double", "entier", + "false", "graph", "integer", "list", + "lower", "print", "punct", "space", + "true", "upper", "wideinteger", "wordchar", + "xdigit", NULL + }; + enum isClasses { + STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL, + STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_ENTIER, + STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT, STR_IS_LIST, + STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE, + STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD, + STR_IS_XDIGIT + }; + int t, range, allowEmpty = 0, end; + InstStringClassType strClassType; + Tcl_Obj *isClass; + + if (parsePtr->numWords < 3 || parsePtr->numWords > 6) { + return TCL_ERROR; + } + isClass = Tcl_NewObj(); + if (!TclWordKnownAtCompileTime(tokenPtr, isClass)) { + Tcl_DecrRefCount(isClass); + return TCL_ERROR; + } else if (Tcl_GetIndexFromObj(interp, isClass, isClasses, "class", 0, + &t) != TCL_OK) { + Tcl_DecrRefCount(isClass); + TclCompileSyntaxError(interp, envPtr); + return TCL_OK; + } + Tcl_DecrRefCount(isClass); + +#define GotLiteral(tokenPtr, word) \ + ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD && \ + (tokenPtr)[1].size > 1 && \ + (tokenPtr)[1].start[0] == word[0] && \ + strncmp((tokenPtr)[1].start, (word), (tokenPtr)[1].size) == 0) + + /* + * Cannot handle the -failindex option at all, and that's the only legal + * way to have more than 4 arguments. + */ + + if (parsePtr->numWords != 3 && parsePtr->numWords != 4) { + return TCL_ERROR; + } + + tokenPtr = TokenAfter(tokenPtr); + if (parsePtr->numWords == 3) { + allowEmpty = 1; + } else { + if (!GotLiteral(tokenPtr, "-strict")) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(tokenPtr); + } +#undef GotLiteral + + /* + * Compile the code. There are several main classes of check here. + * 1. Character classes + * 2. Booleans + * 3. Integers + * 4. Floats + * 5. Lists + */ + + CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1); + + switch ((enum isClasses) t) { + case STR_IS_ALNUM: + strClassType = STR_CLASS_ALNUM; + goto compileStrClass; + case STR_IS_ALPHA: + strClassType = STR_CLASS_ALPHA; + goto compileStrClass; + case STR_IS_ASCII: + strClassType = STR_CLASS_ASCII; + goto compileStrClass; + case STR_IS_CONTROL: + strClassType = STR_CLASS_CONTROL; + goto compileStrClass; + case STR_IS_DIGIT: + strClassType = STR_CLASS_DIGIT; + goto compileStrClass; + case STR_IS_GRAPH: + strClassType = STR_CLASS_GRAPH; + goto compileStrClass; + case STR_IS_LOWER: + strClassType = STR_CLASS_LOWER; + goto compileStrClass; + case STR_IS_PRINT: + strClassType = STR_CLASS_PRINT; + goto compileStrClass; + case STR_IS_PUNCT: + strClassType = STR_CLASS_PUNCT; + goto compileStrClass; + case STR_IS_SPACE: + strClassType = STR_CLASS_SPACE; + goto compileStrClass; + case STR_IS_UPPER: + strClassType = STR_CLASS_UPPER; + goto compileStrClass; + case STR_IS_WORD: + strClassType = STR_CLASS_WORD; + goto compileStrClass; + case STR_IS_XDIGIT: + strClassType = STR_CLASS_XDIGIT; + compileStrClass: + if (allowEmpty) { + OP1( STR_CLASS, strClassType); + } else { + int over, over2; + + OP( DUP); + OP1( STR_CLASS, strClassType); + JUMP1( JUMP_TRUE, over); + OP( POP); + PUSH( "0"); + JUMP1( JUMP, over2); + FIXJUMP1(over); + PUSH( ""); + OP( STR_NEQ); + FIXJUMP1(over2); + } + return TCL_OK; + + case STR_IS_BOOL: + case STR_IS_FALSE: + case STR_IS_TRUE: + OP( TRY_CVT_TO_BOOLEAN); + switch (t) { + int over, over2; + + case STR_IS_BOOL: + if (allowEmpty) { + JUMP1( JUMP_TRUE, over); + PUSH( ""); + OP( STR_EQ); + JUMP1( JUMP, over2); + FIXJUMP1(over); + OP( POP); + PUSH( "1"); + FIXJUMP1(over2); + } else { + OP4( REVERSE, 2); + OP( POP); + } + return TCL_OK; + case STR_IS_TRUE: + JUMP1( JUMP_TRUE, over); + if (allowEmpty) { + PUSH( ""); + OP( STR_EQ); + } else { + OP( POP); + PUSH( "0"); + } + FIXJUMP1( over); + OP( LNOT); + OP( LNOT); + return TCL_OK; + case STR_IS_FALSE: + JUMP1( JUMP_TRUE, over); + if (allowEmpty) { + PUSH( ""); + OP( STR_NEQ); + } else { + OP( POP); + PUSH( "1"); + } + FIXJUMP1( over); + OP( LNOT); + return TCL_OK; + } + + case STR_IS_DOUBLE: { + int satisfied, isEmpty; + + if (allowEmpty) { + OP( DUP); + PUSH( ""); + OP( STR_EQ); + JUMP1( JUMP_TRUE, isEmpty); + OP( NUM_TYPE); + JUMP1( JUMP_TRUE, satisfied); + PUSH( "0"); + JUMP1( JUMP, end); + FIXJUMP1( isEmpty); + OP( POP); + FIXJUMP1( satisfied); + } else { + OP( NUM_TYPE); + JUMP1( JUMP_TRUE, satisfied); + PUSH( "0"); + JUMP1( JUMP, end); + TclAdjustStackDepth(-1, envPtr); + FIXJUMP1( satisfied); + } + PUSH( "1"); + FIXJUMP1( end); + return TCL_OK; + } + + case STR_IS_INT: + case STR_IS_WIDE: + case STR_IS_ENTIER: + if (allowEmpty) { + int testNumType; + + OP( DUP); + OP( NUM_TYPE); + OP( DUP); + JUMP1( JUMP_TRUE, testNumType); + OP( POP); + PUSH( ""); + OP( STR_EQ); + JUMP1( JUMP, end); + TclAdjustStackDepth(1, envPtr); + FIXJUMP1( testNumType); + OP4( REVERSE, 2); + OP( POP); + } else { + OP( NUM_TYPE); + OP( DUP); + JUMP1( JUMP_FALSE, end); + } + + switch (t) { + case STR_IS_INT: + PUSH( "1"); + OP( EQ); + break; + case STR_IS_WIDE: + PUSH( "2"); + OP( LE); + break; + case STR_IS_ENTIER: + PUSH( "3"); + OP( LE); + break; + } + FIXJUMP1( end); + return TCL_OK; + + case STR_IS_LIST: + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); + OP4( BEGIN_CATCH4, range); + ExceptionRangeStarts(envPtr, range); + OP( DUP); + OP( LIST_LENGTH); + OP( POP); + ExceptionRangeEnds(envPtr, range); + ExceptionRangeTarget(envPtr, range, catchOffset); + OP( POP); + OP( PUSH_RETURN_CODE); + OP( END_CATCH); + OP( LNOT); + return TCL_OK; + } + + return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr); +} + +int TclCompileStringMatchCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command @@ -538,12 +896,12 @@ TclCompileStringMapCmd( * correct semantics for mapping. */ - bytes = Tcl_GetStringFromObj(objv[0], &len); + bytes = TclGetStringFromObj(objv[0], &len); if (len == 0) { CompileWord(envPtr, stringTokenPtr, interp, 2); } else { PushLiteral(envPtr, bytes, len); - bytes = Tcl_GetStringFromObj(objv[1], &len); + bytes = TclGetStringFromObj(objv[1], &len); PushLiteral(envPtr, bytes, len); CompileWord(envPtr, stringTokenPtr, interp, 2); OP(STR_MAP); @@ -563,8 +921,7 @@ TclCompileStringRangeCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *stringTokenPtr, *fromTokenPtr, *toTokenPtr; - Tcl_Obj *tmpObj; - int idx1, idx2, result; + int idx1, idx2; if (parsePtr->numWords != 4) { return TCL_ERROR; @@ -573,73 +930,448 @@ TclCompileStringRangeCmd( fromTokenPtr = TokenAfter(stringTokenPtr); toTokenPtr = TokenAfter(fromTokenPtr); + /* Every path must push the string argument */ + CompileWord(envPtr, stringTokenPtr, interp, 1); + /* - * Parse the first index. Will only compile if it is constant and not an - * _integer_ less than zero (since we reserve negative indices here for - * end-relative indexing). + * Parse the two indices. */ - tmpObj = Tcl_NewObj(); - result = TCL_ERROR; - if (TclWordKnownAtCompileTime(fromTokenPtr, tmpObj)) { - if (TclGetIntFromObj(NULL, tmpObj, &idx1) == TCL_OK) { - if (idx1 >= 0) { - result = TCL_OK; - } - } else if (TclGetIntForIndexM(NULL, tmpObj, -2, &idx1) == TCL_OK) { - if (idx1 <= -2) { - result = TCL_OK; - } - } - } - TclDecrRefCount(tmpObj); - if (result != TCL_OK) { + if (TclGetIndexFromToken(fromTokenPtr, TCL_INDEX_START, TCL_INDEX_AFTER, + &idx1) != TCL_OK) { goto nonConstantIndices; } - /* - * Parse the second index. Will only compile if it is constant and not an - * _integer_ less than zero (since we reserve negative indices here for - * end-relative indexing). + * Token parsed as an index expression. We treat all indices before + * the string the same as the start of the string. */ - tmpObj = Tcl_NewObj(); - result = TCL_ERROR; - if (TclWordKnownAtCompileTime(toTokenPtr, tmpObj)) { - if (TclGetIntFromObj(NULL, tmpObj, &idx2) == TCL_OK) { - if (idx2 >= 0) { - result = TCL_OK; - } - } else if (TclGetIntForIndexM(NULL, tmpObj, -2, &idx2) == TCL_OK) { - if (idx2 <= -2) { - result = TCL_OK; - } - } + if (idx1 == TCL_INDEX_AFTER) { + /* [string range $s end+1 $last] must be empty string */ + OP( POP); + PUSH( ""); + return TCL_OK; } - TclDecrRefCount(tmpObj); - if (result != TCL_OK) { + + if (TclGetIndexFromToken(toTokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END, + &idx2) != TCL_OK) { goto nonConstantIndices; } + /* + * Token parsed as an index expression. We treat all indices after + * the string the same as the end of the string. + */ + if (idx2 == TCL_INDEX_BEFORE) { + /* [string range $s $first -1] must be empty string */ + OP( POP); + PUSH( ""); + return TCL_OK; + } /* * Push the operand onto the stack and then the substring operation. */ - CompileWord(envPtr, stringTokenPtr, interp, 1); OP44( STR_RANGE_IMM, idx1, idx2); return TCL_OK; /* * Push the operands onto the stack and then the substring operation. - */ + */ nonConstantIndices: - CompileWord(envPtr, stringTokenPtr, interp, 1); CompileWord(envPtr, fromTokenPtr, interp, 2); CompileWord(envPtr, toTokenPtr, interp, 3); OP( STR_RANGE); return TCL_OK; } + +int +TclCompileStringReplaceCmd( + Tcl_Interp *interp, /* Tcl interpreter for context. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the + * command. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds the resulting instructions. */ +{ + Tcl_Token *tokenPtr, *valueTokenPtr; + DefineLineInformation; /* TIP #280 */ + int first, last; + + if (parsePtr->numWords < 4 || parsePtr->numWords > 5) { + return TCL_ERROR; + } + + /* Bytecode to compute/push string argument being replaced */ + valueTokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, valueTokenPtr, interp, 1); + + /* + * Check for first index known and useful at compile time. + */ + tokenPtr = TokenAfter(valueTokenPtr); + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_AFTER, + &first) != TCL_OK) { + goto genericReplace; + } + + /* + * Check for last index known and useful at compile time. + */ + tokenPtr = TokenAfter(tokenPtr); + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_AFTER, + &last) != TCL_OK) { + goto genericReplace; + } + + /* + * [string replace] is an odd bird. For many arguments it is + * a conventional substring replacer. However it also goes out + * of its way to become a no-op for many cases where it would be + * replacing an empty substring. Precisely, it is a no-op when + * + * (last < first) OR + * (last < 0) OR + * (end < first) + * + * For some compile-time values we can detect these cases, and + * compile direct to bytecode implementing the no-op. + */ + + if ((last == TCL_INDEX_BEFORE) /* Know (last < 0) */ + || (first == TCL_INDEX_AFTER) /* Know (first > end) */ + + /* + * Tricky to determine when runtime (last < first) can be + * certainly known based on the encoded values. Consider the + * cases... + * + * (first <= TCL_INDEX_END) && + * (last == TCL_INDEX_AFTER) => cannot tell REJECT + * (last <= TCL_INDEX END) && (last < first) => ACCEPT + * else => cannot tell REJECT + */ + || ((first <= TCL_INDEX_END) && (last <= TCL_INDEX_END) + && (last < first)) /* Know (last < first) */ + /* + * (first == TCL_INDEX_BEFORE) && + * (last == TCL_INDEX_AFTER) => (first < last) REJECT + * (last <= TCL_INDEX_END) => cannot tell REJECT + * else => (first < last) REJECT + * + * else [[first >= TCL_INDEX_START]] && + * (last == TCL_INDEX_AFTER) => cannot tell REJECT + * (last <= TCL_INDEX_END) => cannot tell REJECT + * else [[last >= TCL_INDEX START]] && (last < first) => ACCEPT + */ + || ((first >= TCL_INDEX_START) && (last >= TCL_INDEX_START) + && (last < first))) { /* Know (last < first) */ + if (parsePtr->numWords == 5) { + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 4); + OP( POP); /* Pop newString */ + } + /* Original string argument now on TOS as result */ + return TCL_OK; + } + + if (parsePtr->numWords == 5) { + /* + * When we have a string replacement, we have to take care about + * not replacing empty substrings that [string replace] promises + * not to replace + * + * The remaining index values might be suitable for conventional + * string replacement, but only if they cannot possibly meet the + * conditions described above at runtime. If there's a chance they + * might, we would have to emit bytecode to check and at that point + * we're paying more in bytecode execution time than would make + * things worthwhile. Trouble is we are very limited in + * how much we can detect that at compile time. After decoding, + * we need, first: + * + * (first <= end) + * + * The encoded indices (first <= TCL_INDEX END) and + * (first == TCL_INDEX_BEFORE) always meets this condition, but + * any other encoded first index has some list for which it fails. + * + * We also need, second: + * + * (last >= 0) + * + * The encoded indices (last >= TCL_INDEX_START) and + * (last == TCL_INDEX_AFTER) always meet this condition but any + * other encoded last index has some list for which it fails. + * + * Finally we need, third: + * + * (first <= last) + * + * Considered in combination with the constraints we already have, + * we see that we can proceed when (first == TCL_INDEX_BEFORE) + * or (last == TCL_INDEX_AFTER). These also permit simplification + * of the prefix|replace|suffix construction. The other constraints, + * though, interfere with getting a guarantee that first <= last. + */ + + if ((first == TCL_INDEX_BEFORE) && (last >= TCL_INDEX_START)) { + /* empty prefix */ + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 4); + OP4( REVERSE, 2); + if (last == TCL_INDEX_AFTER) { + OP( POP); /* Pop original */ + } else { + OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END); + OP1( STR_CONCAT1, 2); + } + return TCL_OK; + } + + if ((last == TCL_INDEX_AFTER) && (first <= TCL_INDEX_END)) { + OP44( STR_RANGE_IMM, 0, first-1); + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 4); + OP1( STR_CONCAT1, 2); + return TCL_OK; + } + + /* FLOW THROUGH TO genericReplace */ + + } else { + /* + * When we have no replacement string to worry about, we may + * have more luck, because the forbidden empty string replacements + * are harmless when they are replaced by another empty string. + */ + + if ((first == TCL_INDEX_BEFORE) || (first == TCL_INDEX_START)) { + /* empty prefix - build suffix only */ + + if ((last == TCL_INDEX_END) || (last == TCL_INDEX_AFTER)) { + /* empty suffix too => empty result */ + OP( POP); /* Pop original */ + PUSH ( ""); + return TCL_OK; + } + OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END); + return TCL_OK; + } else { + if ((last == TCL_INDEX_END) || (last == TCL_INDEX_AFTER)) { + /* empty suffix - build prefix only */ + OP44( STR_RANGE_IMM, 0, first-1); + return TCL_OK; + } + OP( DUP); + OP44( STR_RANGE_IMM, 0, first-1); + OP4( REVERSE, 2); + OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END); + OP1( STR_CONCAT1, 2); + return TCL_OK; + } + } + + genericReplace: + tokenPtr = TokenAfter(valueTokenPtr); + CompileWord(envPtr, tokenPtr, interp, 2); + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 3); + if (parsePtr->numWords == 5) { + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 4); + } else { + PUSH( ""); + } + OP( STR_REPLACE); + return TCL_OK; +} + +int +TclCompileStringTrimLCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; + + if (parsePtr->numWords != 2 && parsePtr->numWords != 3) { + return TCL_ERROR; + } + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + if (parsePtr->numWords == 3) { + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 2); + } else { + PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet)); + } + OP( STR_TRIM_LEFT); + return TCL_OK; +} + +int +TclCompileStringTrimRCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; + + if (parsePtr->numWords != 2 && parsePtr->numWords != 3) { + return TCL_ERROR; + } + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + if (parsePtr->numWords == 3) { + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 2); + } else { + PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet)); + } + OP( STR_TRIM_RIGHT); + return TCL_OK; +} + +int +TclCompileStringTrimCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; + + if (parsePtr->numWords != 2 && parsePtr->numWords != 3) { + return TCL_ERROR; + } + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + if (parsePtr->numWords == 3) { + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 2); + } else { + PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet)); + } + OP( STR_TRIM); + return TCL_OK; +} + +int +TclCompileStringToUpperCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; + + if (parsePtr->numWords != 2) { + return TclCompileBasic1To3ArgCmd(interp, parsePtr, cmdPtr, envPtr); + } + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + OP( STR_UPPER); + return TCL_OK; +} + +int +TclCompileStringToLowerCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; + + if (parsePtr->numWords != 2) { + return TclCompileBasic1To3ArgCmd(interp, parsePtr, cmdPtr, envPtr); + } + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + OP( STR_LOWER); + return TCL_OK; +} + +int +TclCompileStringToTitleCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; + + if (parsePtr->numWords != 2) { + return TclCompileBasic1To3ArgCmd(interp, parsePtr, cmdPtr, envPtr); + } + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + OP( STR_TITLE); + return TCL_OK; +} + +/* + * Support definitions for the [string is] compilation. + */ + +static int +UniCharIsAscii( + int character) +{ + return (character >= 0) && (character < 0x80); +} + +static int +UniCharIsHexDigit( + int character) +{ + return (character >= 0) && (character < 0x80) && isxdigit(character); +} + +StringClassDesc const tclStringClassTable[] = { + {"alnum", Tcl_UniCharIsAlnum}, + {"alpha", Tcl_UniCharIsAlpha}, + {"ascii", UniCharIsAscii}, + {"control", Tcl_UniCharIsControl}, + {"digit", Tcl_UniCharIsDigit}, + {"graph", Tcl_UniCharIsGraph}, + {"lower", Tcl_UniCharIsLower}, + {"print", Tcl_UniCharIsPrint}, + {"punct", Tcl_UniCharIsPunct}, + {"space", Tcl_UniCharIsSpace}, + {"upper", Tcl_UniCharIsUpper}, + {"word", Tcl_UniCharIsWordChar}, + {"xdigit", UniCharIsHexDigit}, + {NULL, NULL} +}; /* *---------------------------------------------------------------------- @@ -750,7 +1482,7 @@ TclSubstCompile( /* * Tricky point! If the first token does not result in a *guaranteed* push * of a Tcl_Obj on the stack, we must push an empty object. Otherwise it - * is possible to get to an INST_CONCAT1 or INST_DONE without enough + * is possible to get to an INST_STR_CONCAT1 or INST_DONE without enough * values on the stack, resulting in a crash. Thanks to Joe Mistachkin for * identifying a script that could trigger this case. */ @@ -770,8 +1502,8 @@ TclSubstCompile( switch (tokenPtr->type) { case TCL_TOKEN_TEXT: - literal = TclRegisterNewLiteral(envPtr, - tokenPtr->start, tokenPtr->size); + literal = TclRegisterLiteral(envPtr, + tokenPtr->start, tokenPtr->size, 0); TclEmitPush(literal, envPtr); TclAdvanceLines(&bline, tokenPtr->start, tokenPtr->start + tokenPtr->size); @@ -780,7 +1512,7 @@ TclSubstCompile( case TCL_TOKEN_BS: length = TclParseBackslash(tokenPtr->start, tokenPtr->size, NULL, buf); - literal = TclRegisterNewLiteral(envPtr, buf, length); + literal = TclRegisterLiteral(envPtr, buf, length, 0); TclEmitPush(literal, envPtr); count++; continue; @@ -815,11 +1547,11 @@ TclSubstCompile( } while (count > 255) { - OP1( CONCAT1, 255); + OP1( STR_CONCAT1, 255); count -= 254; } if (count > 1) { - OP1( CONCAT1, count); + OP1( STR_CONCAT1, count); count = 1; } @@ -873,7 +1605,7 @@ TclSubstCompile( OP( END_CATCH); OP( RETURN_CODE_BRANCH); - /* ERROR -> reraise it */ + /* ERROR -> reraise it; NB: can't require BREAK/CONTINUE handling */ OP( RETURN_STK); OP( NOP); @@ -939,7 +1671,7 @@ TclSubstCompile( (int) (CurrentOffset(envPtr) - okFixup.codeOffset)); } if (count > 1) { - OP1(CONCAT1, count); + OP1(STR_CONCAT1, count); count = 1; } @@ -952,11 +1684,11 @@ TclSubstCompile( } while (count > 255) { - OP1( CONCAT1, 255); + OP1( STR_CONCAT1, 255); count -= 254; } if (count > 1) { - OP1( CONCAT1, count); + OP1( STR_CONCAT1, count); } Tcl_FreeParse(&parse); @@ -1216,10 +1948,10 @@ TclCompileSwitchCmd( } if (numWords % 2) { abort: - ckfree((char *) bodyToken); - ckfree((char *) bodyTokenArray); - ckfree((char *) bodyLines); - ckfree((char *) bodyContLines); + ckfree(bodyToken); + ckfree(bodyTokenArray); + ckfree(bodyLines); + ckfree(bodyContLines); return TCL_ERROR; } } else if (numWords % 2 || numWords == 0) { @@ -1342,7 +2074,7 @@ IssueSwitchChainedTests( int foundDefault; /* Flag to indicate whether a "default" clause * is present. */ JumpFixup *fixupArray; /* Array of forward-jump fixup records. */ - int *fixupTargetArray; /* Array of places for fixups to point at. */ + unsigned int *fixupTargetArray; /* Array of places for fixups to point at. */ int fixupCount; /* Number of places to fix up. */ int contFixIndex; /* Where the first of the jumps due to a group * of continuation bodies starts, or -1 if @@ -1409,7 +2141,7 @@ IssueSwitchChainedTests( */ if (TclReToGlob(NULL, bodyToken[i]->start, - bodyToken[i]->size, &ds, &exact) == TCL_OK) { + bodyToken[i]->size, &ds, &exact, NULL) == TCL_OK){ simple = 1; PushLiteral(envPtr, Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)); @@ -1496,7 +2228,7 @@ IssueSwitchChainedTests( } /* - * Now do the actual compilation. Note that we do not use BODY() + * Now do the actual compilation. Note that we do not use BODY() * because we may have synthesized the tokens in a non-standard * pattern. */ @@ -1759,11 +2491,13 @@ IssueSwitchJumpTable( * DupJumptableInfo: a copy of the jump-table * FreeJumptableInfo: none * PrintJumptableInfo: none + * DisassembleJumptableInfo: none * * Side effects: * DupJumptableInfo: allocates memory * FreeJumptableInfo: releases memory * PrintJumptableInfo: none + * DisassembleJumptableInfo: none * *---------------------------------------------------------------------- */ @@ -1826,6 +2560,30 @@ PrintJumptableInfo( keyPtr, pcOffset + offset); } } + +static void +DisassembleJumptableInfo( + ClientData clientData, + Tcl_Obj *dictObj, + ByteCode *codePtr, + unsigned int pcOffset) +{ + register JumptableInfo *jtPtr = clientData; + Tcl_Obj *mapping = Tcl_NewObj(); + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + const char *keyPtr; + int offset; + + hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search); + for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) { + keyPtr = Tcl_GetHashKey(&jtPtr->hashTable, hPtr); + offset = PTR2INT(Tcl_GetHashValue(hPtr)); + Tcl_DictObjPut(NULL, mapping, Tcl_NewStringObj(keyPtr, -1), + Tcl_NewIntObj(offset)); + } + Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("mapping", -1), mapping); +} /* *---------------------------------------------------------------------- @@ -1864,6 +2622,7 @@ TclCompileTailcallCmd( } /* make room for the nsObjPtr */ + /* TODO: Doesn't this have to be a known value? */ CompileWord(envPtr, tokenPtr, interp, 0); for (i=1 ; i<parsePtr->numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); @@ -1927,7 +2686,7 @@ TclCompileThrowCmd( } CompileWord(envPtr, msgToken, interp, 2); - codeIsList = codeKnown && (TCL_OK == + codeIsList = codeKnown && (TCL_OK == Tcl_ListObjLength(interp, objPtr, &len)); codeIsValid = codeIsList && (len != 0); @@ -1964,7 +2723,7 @@ TclCompileThrowCmd( OP( LIST_LENGTH); OP1( JUMP_FALSE1, 16); OP4( LIST, 2); - OP44( RETURN_IMM, 1, 0); + OP44( RETURN_IMM, TCL_ERROR, 0); TclAdjustStackDepth(2, envPtr); OP( POP); OP( POP); @@ -1973,7 +2732,7 @@ TclCompileThrowCmd( PUSH( "type must be non-empty list"); PUSH( "-errorcode {TCL OPERATION THROW BADEXCEPTION}"); } - OP44( RETURN_IMM, 1, 0); + OP44( RETURN_IMM, TCL_ERROR, 0); return TCL_OK; } @@ -2112,7 +2871,7 @@ TclCompileTryCmd( } if (objc > 0) { int len; - const char *varname = Tcl_GetStringFromObj(objv[0], &len); + const char *varname = TclGetStringFromObj(objv[0], &len); resultVarIndices[i] = LocalScalar(varname, len, envPtr); if (resultVarIndices[i] < 0) { @@ -2124,7 +2883,7 @@ TclCompileTryCmd( } if (objc == 2) { int len; - const char *varname = Tcl_GetStringFromObj(objv[1], &len); + const char *varname = TclGetStringFromObj(objv[1], &len); optionVarIndices[i] = LocalScalar(varname, len, envPtr); if (optionVarIndices[i] < 0) { @@ -2327,7 +3086,7 @@ IssueTryClausesInstructions( OP4( DICT_GET, 1); TclAdjustStackDepth(-1, envPtr); OP44( LIST_RANGE_IMM, 0, len-1); - p = Tcl_GetStringFromObj(matchClauses[i], &len); + p = TclGetStringFromObj(matchClauses[i], &len); PushLiteral(envPtr, p, len); OP( STR_EQ); JUMP4( JUMP_FALSE, notECJumpSource); @@ -2355,6 +3114,7 @@ IssueTryClausesInstructions( if (!handlerTokens[i]) { forwardsNeedFixing = 1; JUMP4( JUMP, forwardsToFix[i]); + TclAdjustStackDepth(1, envPtr); } else { int dontChangeOptions; @@ -2395,7 +3155,7 @@ IssueTryClausesInstructions( TclAdjustStackDepth(-1, envPtr); FIXJUMP1( dontChangeOptions); OP4( REVERSE, 2); - OP( RETURN_STK); + INVOKE( RETURN_STK); } JUMP4( JUMP, addrsToFix[i]); @@ -2414,7 +3174,7 @@ IssueTryClausesInstructions( OP( POP); LOAD( optionsVar); LOAD( resultVar); - OP( RETURN_STK); + INVOKE( RETURN_STK); /* * Fix all the jumps from taken clauses to here (which is the end of the @@ -2537,7 +3297,7 @@ IssueTryClausesFinallyInstructions( OP4( DICT_GET, 1); TclAdjustStackDepth(-1, envPtr); OP44( LIST_RANGE_IMM, 0, len-1); - p = Tcl_GetStringFromObj(matchClauses[i], &len); + p = TclGetStringFromObj(matchClauses[i], &len); PushLiteral(envPtr, p, len); OP( STR_EQ); JUMP4( JUMP_FALSE, notECJumpSource); @@ -2723,7 +3483,7 @@ IssueTryClausesFinallyInstructions( FIXJUMP1( finalOK); LOAD( optionsVar); LOAD( resultVar); - OP( RETURN_STK); + INVOKE( RETURN_STK); return TCL_OK; } @@ -2782,7 +3542,7 @@ IssueTryFinallyInstructions( OP1( JUMP1, 7); FIXJUMP1( jumpOK); OP4( REVERSE, 2); - OP( RETURN_STK); + INVOKE( RETURN_STK); return TCL_OK; } @@ -2814,39 +3574,81 @@ TclCompileUnsetCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr; - int isScalar, localIndex, numWords, flags, i; - Tcl_Obj *leadingWord; + int isScalar, localIndex, flags = 1, i, varCount = 0, haveFlags = 0; DefineLineInformation; /* TIP #280 */ /* TODO: Consider support for compiling expanded args. */ - numWords = parsePtr->numWords-1; - flags = 1; - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - leadingWord = Tcl_NewObj(); - if (numWords > 0 && TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) { - int len; - const char *bytes = Tcl_GetStringFromObj(leadingWord, &len); - if (len == 11 && !strncmp("-nocomplain", bytes, 11)) { - flags = 0; - varTokenPtr = TokenAfter(varTokenPtr); - numWords--; - } else if (len == 2 && !strncmp("--", bytes, 2)) { - varTokenPtr = TokenAfter(varTokenPtr); - numWords--; - } - } else { - /* - * Cannot guarantee that the first word is not '-nocomplain' at - * evaluation with reasonable effort, so spill to interpreted version. - */ + /* + * Verify that all words - except the first non-option one - are known at + * compile time so that we can handle them without needing to do a nasty + * push/rotate. [Bug 3970f54c4e] + */ + for (i=1,varTokenPtr=parsePtr->tokenPtr ; i<parsePtr->numWords ; i++) { + Tcl_Obj *leadingWord = Tcl_NewObj(); + + varTokenPtr = TokenAfter(varTokenPtr); + if (!TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) { + TclDecrRefCount(leadingWord); + + /* + * We can tolerate non-trivial substitutions in the first variable + * to be unset. If a '--' or '-nocomplain' was present, anything + * goes in that one place! (All subsequent variable names must be + * constants since we don't want to have to push them all first.) + */ + + if (varCount == 0) { + if (haveFlags) { + continue; + } + + /* + * In fact, we're OK as long as we're the first argument *and* + * we provably don't start with a '-'. If that is true, then + * even if everything else is varying, we still can't be a + * flag. Otherwise we'll spill to runtime to place a limit on + * the trickiness. + */ + + if (varTokenPtr->type == TCL_TOKEN_WORD + && varTokenPtr[1].type == TCL_TOKEN_TEXT + && varTokenPtr[1].size > 0 + && varTokenPtr[1].start[0] != '-') { + continue; + } + } + return TCL_ERROR; + } + if (varCount == 0) { + const char *bytes; + int len; + + bytes = TclGetStringFromObj(leadingWord, &len); + if (i == 1 && len == 11 && !strncmp("-nocomplain", bytes, 11)) { + flags = 0; + haveFlags++; + } else if (i == (2 - flags) && len == 2 && !strncmp("--", bytes, 2)) { + haveFlags++; + } else { + varCount++; + } + } else { + varCount++; + } TclDecrRefCount(leadingWord); - return TCL_ERROR; } - TclDecrRefCount(leadingWord); - for (i=0 ; i<numWords ; i++) { + /* + * Issue instructions to unset each of the named variables. + */ + + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + for (i=0; i<haveFlags;i++) { + varTokenPtr = TokenAfter(varTokenPtr); + } + for (i=1+haveFlags ; i<parsePtr->numWords ; i++) { /* * Decide if we can use a frame slot for the var/array name or if we * need to emit code to compute and push the name at runtime. We use a @@ -2856,7 +3658,7 @@ TclCompileUnsetCmd( */ PushVarNameWord(interp, varTokenPtr, envPtr, 0, - &localIndex, &isScalar, 1); + &localIndex, &isScalar, i); /* * Emit instructions to unset the variable. @@ -3106,6 +3908,51 @@ TclCompileYieldCmd( /* *---------------------------------------------------------------------- * + * TclCompileYieldToCmd -- + * + * Procedure called to compile the "yieldto" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "yieldto" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileYieldToCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); + int i; + + if (parsePtr->numWords < 2) { + return TCL_ERROR; + } + + OP( NS_CURRENT); + for (i = 1 ; i < parsePtr->numWords ; i++) { + CompileWord(envPtr, tokenPtr, interp, i); + tokenPtr = TokenAfter(tokenPtr); + } + OP4( LIST, i); + OP( YIELD_TO_INVOKE); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * CompileUnaryOpCmd -- * * Utility routine to compile the unary operator commands. diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 2a48117..b854b0f 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -365,7 +365,7 @@ static const unsigned char prec[] = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, + 0, /* Unary operator lexemes */ PREC_UNARY, /* UNARY_PLUS */ PREC_UNARY, /* UNARY_MINUS */ @@ -420,7 +420,7 @@ static const unsigned char instruction[] = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, + 0, /* Unary operator lexemes */ INST_UPLUS, /* UNARY_PLUS */ INST_UMINUS, /* UNARY_MINUS */ @@ -488,15 +488,8 @@ static const unsigned char Lexeme[] = { typedef struct JumpList { JumpFixup jump; /* Pass this argument to matching calls of - * TclEmitForwardJump() and + * TclEmitForwardJump() and * TclFixupForwardJump(). */ - int depth; /* Remember the currStackDepth of the - * CompileEnv here. */ - int offset; /* Data used to compute jump lengths to pass - * to TclFixupForwardJump() */ - int convert; /* Temporary storage used to compute whether - * numeric conversion will be needed following - * the operator we're compiling. */ struct JumpList *next; /* Point to next item on the stack */ } JumpList; @@ -571,13 +564,13 @@ ParseExpr( { OpNode *nodes = NULL; /* Pointer to the OpNode storage array where * we build the parse tree. */ - int nodesAvailable = 64; /* Initial size of the storage array. This + unsigned int nodesAvailable = 64; /* Initial size of the storage array. This * value establishes a minimum tree memory * cost of only about 1 kibyte, and is large * enough for most expressions to parse with * no need for array growth and * reallocation. */ - int nodesUsed = 0; /* Number of OpNodes filled. */ + unsigned int nodesUsed = 0; /* Number of OpNodes filled. */ int scanned = 0; /* Capture number of byte scanned by parsing * routines. */ int lastParsed; /* Stores info about what the lexeme parsed @@ -669,11 +662,13 @@ ParseExpr( */ if (nodesUsed >= nodesAvailable) { - int size = nodesUsed * 2; - OpNode *newPtr; + unsigned int size = nodesUsed * 2; + OpNode *newPtr = NULL; do { + if (size <= UINT_MAX/sizeof(OpNode)) { newPtr = attemptckrealloc(nodes, size * sizeof(OpNode)); + } } while ((newPtr == NULL) && ((size -= (size - nodesUsed) / 2) > nodesUsed)); if (newPtr == NULL) { @@ -845,7 +840,7 @@ ParseExpr( switch (lexeme) { case NUMBER: - case BOOLEAN: + case BOOLEAN: /* * TODO: Consider using a dict or hash to collapse all * duplicate literals into a single representative value. @@ -868,7 +863,7 @@ ParseExpr( start += scanned; numBytes -= scanned; continue; - + default: break; } @@ -1331,7 +1326,7 @@ ParseExpr( nodePtr->mark = MARK_LEFT; nodePtr->left = complete; - /* + /* * The COMMA operator cannot be optimized, since the function * needs all of its arguments, and optimization would reduce the * number. Other binary operators root constant expressions when @@ -1553,7 +1548,7 @@ ConvertTreeToTokens( * Tcl_ParseExpr() we do not change them now. Internally, we can * do better. */ - + int toCopy = tokenPtr->numComponents + 1; if (tokenPtr->numComponents == tokenPtr[1].numComponents + 1) { @@ -1569,7 +1564,7 @@ ConvertTreeToTokens( subExprTokenPtr->type = TCL_TOKEN_SUB_EXPR; parsePtr->numTokens += toCopy; } else { - /* + /* * Multiple element word. Create a TCL_TOKEN_SUB_EXPR token to * lead, with fields initialized from the leading token, then * copy entire set of word tokens. @@ -1618,7 +1613,7 @@ ConvertTreeToTokens( case COMMA: case COLON: - /* + /* * Historical practice has been to have no Tcl_Tokens for * these operators. */ @@ -1754,7 +1749,7 @@ ConvertTreeToTokens( /* * Before we leave this node/operator/subexpression for the * last time, finish up its tokens.... - * + * * Our current position scanning the string is where the * substring for the subexpression ends. */ @@ -1890,7 +1885,7 @@ ParseLexeme( { const char *end; int scanned; - Tcl_UniChar ch; + Tcl_UniChar ch = 0; Tcl_Obj *literal = NULL; unsigned char byte; @@ -1974,7 +1969,7 @@ ParseLexeme( case 'i': if ((numBytes > 1) && (start[1] == 'n') - && ((numBytes == 2) || !isalpha(UCHAR(start[2])))) { + && ((numBytes == 2) || start[2] & 0x80 || !isalpha(UCHAR(start[2])))) { /* * Must make this check so we can tell the difference between the * "in" operator and the "int" function name and the "infinity" @@ -1988,14 +1983,15 @@ ParseLexeme( case 'e': if ((numBytes > 1) && (start[1] == 'q') - && ((numBytes == 2) || !isalpha(UCHAR(start[2])))) { + && ((numBytes == 2) || start[2] & 0x80 || !isalpha(UCHAR(start[2])))) { *lexemePtr = STREQ; return 2; } break; case 'n': - if ((numBytes > 1) && ((numBytes == 2) || !isalpha(UCHAR(start[2])))) { + if ((numBytes > 1) + && ((numBytes == 2) || start[2] & 0x80 || !isalpha(UCHAR(start[2])))) { switch (start[1]) { case 'e': *lexemePtr = STRNEQ; @@ -2010,9 +2006,8 @@ ParseLexeme( literal = Tcl_NewObj(); if (TclParseNumber(NULL, literal, NULL, start, numBytes, &end, TCL_PARSE_NO_WHITESPACE) == TCL_OK) { - if (end < start + numBytes && !isalnum(UCHAR(*end)) - && UCHAR(*end) != '_') { - + if (end < start + numBytes && !TclIsBareword(*end)) { + number: TclInitStringRep(literal, start, end-start); *lexemePtr = NUMBER; @@ -2036,9 +2031,9 @@ ParseLexeme( const char *p = start; while (p < end) { - if (!isalnum(UCHAR(*p++))) { + if (!TclIsBareword(*p++)) { /* - * The number has non-bareword characters, so we + * The number has non-bareword characters, so we * must treat it as a number. */ goto number; @@ -2061,33 +2056,30 @@ ParseLexeme( } } - if (Tcl_UtfCharComplete(start, numBytes)) { - scanned = Tcl_UtfToUniChar(start, &ch); - } else { - char utfBytes[TCL_UTF_MAX]; + /* + * We reject leading underscores in bareword. No sensible reason why. + * Might be inspired by reserved identifier rules in C, which of course + * have no direct relevance here. + */ - memcpy(utfBytes, start, (size_t) numBytes); - utfBytes[numBytes] = '\0'; - scanned = Tcl_UtfToUniChar(utfBytes, &ch); - } - if (!isalnum(UCHAR(ch))) { - *lexemePtr = INVALID; - Tcl_DecrRefCount(literal); - return scanned; - } - end = start; - while (isalnum(UCHAR(ch)) || (UCHAR(ch) == '_')) { - end += scanned; - numBytes -= scanned; - if (Tcl_UtfCharComplete(end, numBytes)) { - scanned = Tcl_UtfToUniChar(end, &ch); + if (!TclIsBareword(*start) || *start == '_') { + if (Tcl_UtfCharComplete(start, numBytes)) { + scanned = TclUtfToUniChar(start, &ch); } else { char utfBytes[TCL_UTF_MAX]; - memcpy(utfBytes, end, (size_t) numBytes); + memcpy(utfBytes, start, (size_t) numBytes); utfBytes[numBytes] = '\0'; - scanned = Tcl_UtfToUniChar(utfBytes, &ch); + scanned = TclUtfToUniChar(utfBytes, &ch); } + *lexemePtr = INVALID; + Tcl_DecrRefCount(literal); + return scanned; + } + end = start; + while (numBytes && TclIsBareword(*end)) { + end += 1; + numBytes -= 1; } *lexemePtr = BAREWORD; if (literalPtr) { @@ -2105,7 +2097,7 @@ ParseLexeme( * TclCompileExpr -- * * This procedure compiles a string containing a Tcl expression into Tcl - * bytecodes. + * bytecodes. * * Results: * None. @@ -2189,7 +2181,6 @@ ExecConstantExprTree( CompileEnv *envPtr; ByteCode *byteCodePtr; int code; - Tcl_Obj *byteCodeObj = Tcl_NewObj(); NRE_callback *rootPtr = TOP_CB(interp); /* @@ -2203,14 +2194,12 @@ ExecConstantExprTree( CompileExprTree(interp, nodes, index, litObjvPtr, NULL, NULL, envPtr, 0 /* optimize */); TclEmitOpcode(INST_DONE, envPtr); - Tcl_IncrRefCount(byteCodeObj); - TclInitByteCodeObj(byteCodeObj, envPtr); + byteCodePtr = TclInitByteCode(envPtr); TclFreeCompileEnv(envPtr); TclStackFree(interp, envPtr); - byteCodePtr = byteCodeObj->internalRep.twoPtrValue.ptr1; TclNRExecuteByteCode(interp, byteCodePtr); code = TclNRRunCallbacks(interp, TCL_OK, rootPtr); - Tcl_DecrRefCount(byteCodeObj); + TclReleaseByteCode(byteCodePtr); return code; } @@ -2261,30 +2250,8 @@ CompileExprTree( if (nodePtr->mark == MARK_LEFT) { next = nodePtr->left; - switch (nodePtr->lexeme) { - case QUESTION: - newJump = TclStackAlloc(interp, sizeof(JumpList)); - newJump->next = jumpPtr; - jumpPtr = newJump; - newJump = TclStackAlloc(interp, sizeof(JumpList)); - newJump->next = jumpPtr; - jumpPtr = newJump; - jumpPtr->depth = envPtr->currStackDepth; + if (nodePtr->lexeme == QUESTION) { convert = 1; - break; - case AND: - case OR: - newJump = TclStackAlloc(interp, sizeof(JumpList)); - newJump->next = jumpPtr; - jumpPtr = newJump; - newJump = TclStackAlloc(interp, sizeof(JumpList)); - newJump->next = jumpPtr; - jumpPtr = newJump; - newJump = TclStackAlloc(interp, sizeof(JumpList)); - newJump->next = jumpPtr; - jumpPtr = newJump; - jumpPtr->depth = envPtr->currStackDepth; - break; } } else if (nodePtr->mark == MARK_RIGHT) { next = nodePtr->right; @@ -2300,9 +2267,9 @@ CompileExprTree( p = TclGetStringFromObj(*funcObjv, &length); funcObjv++; Tcl_DStringAppend(&cmdName, p, length); - TclEmitPush(TclRegisterNewCmdLiteral(envPtr, + TclEmitPush(TclRegisterLiteral(envPtr, Tcl_DStringValue(&cmdName), - Tcl_DStringLength(&cmdName)), envPtr); + Tcl_DStringLength(&cmdName), LITERAL_CMD_NAME), envPtr); Tcl_DStringFree(&cmdName); /* @@ -2317,25 +2284,35 @@ CompileExprTree( break; } case QUESTION: + newJump = TclStackAlloc(interp, sizeof(JumpList)); + newJump->next = jumpPtr; + jumpPtr = newJump; TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpPtr->jump); break; case COLON: - CLANG_ASSERT(jumpPtr); + newJump = TclStackAlloc(interp, sizeof(JumpList)); + newJump->next = jumpPtr; + jumpPtr = newJump; TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &jumpPtr->next->jump); - envPtr->currStackDepth = jumpPtr->depth; - jumpPtr->offset = (envPtr->codeNext - envPtr->codeStart); - jumpPtr->convert = convert; + &jumpPtr->jump); + TclAdjustStackDepth(-1, envPtr); + if (convert) { + jumpPtr->jump.jumpType = TCL_TRUE_JUMP; + } convert = 1; break; case AND: - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpPtr->jump); - break; case OR: - TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &jumpPtr->jump); + newJump = TclStackAlloc(interp, sizeof(JumpList)); + newJump->next = jumpPtr; + jumpPtr = newJump; + TclEmitForwardJump(envPtr, (nodePtr->lexeme == AND) + ? TCL_FALSE_JUMP : TCL_TRUE_JUMP, &jumpPtr->jump); break; } } else { + int pc1, pc2, target; + switch (nodePtr->lexeme) { case START: case QUESTION: @@ -2352,11 +2329,11 @@ CompileExprTree( * Use the numWords count we've kept to invoke the function * command with the correct number of arguments. */ - + if (numWords < 255) { - TclEmitInstInt1(INST_INVOKE_STK1, numWords, envPtr); + TclEmitInvoke(envPtr, INST_INVOKE_STK1, numWords); } else { - TclEmitInstInt4(INST_INVOKE_STK4, numWords, envPtr); + TclEmitInvoke(envPtr, INST_INVOKE_STK4, numWords); } /* @@ -2375,18 +2352,20 @@ CompileExprTree( break; case COLON: CLANG_ASSERT(jumpPtr); - if (TclFixupForwardJump(envPtr, &jumpPtr->next->jump, - (envPtr->codeNext - envPtr->codeStart) - - jumpPtr->next->jump.codeOffset, 127)) { - jumpPtr->offset += 3; + if (jumpPtr->jump.jumpType == TCL_TRUE_JUMP) { + jumpPtr->jump.jumpType = TCL_UNCONDITIONAL_JUMP; + convert = 1; + } + target = jumpPtr->jump.codeOffset + 2; + if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) { + target += 3; } - TclFixupForwardJump(envPtr, &jumpPtr->jump, - jumpPtr->offset - jumpPtr->jump.codeOffset, 127); - convert |= jumpPtr->convert; - envPtr->currStackDepth = jumpPtr->depth + 1; freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); + TclFixupForwardJump(envPtr, &jumpPtr->jump, + target - jumpPtr->jump.codeOffset, 127); + freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); @@ -2394,30 +2373,24 @@ CompileExprTree( case AND: case OR: CLANG_ASSERT(jumpPtr); - TclEmitForwardJump(envPtr, (nodePtr->lexeme == AND) - ? TCL_FALSE_JUMP : TCL_TRUE_JUMP, - &jumpPtr->next->jump); - TclEmitPush(TclRegisterNewLiteral(envPtr, - (nodePtr->lexeme == AND) ? "1" : "0", 1), envPtr); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &jumpPtr->next->next->jump); + pc1 = CurrentOffset(envPtr); + TclEmitInstInt1((nodePtr->lexeme == AND) ? INST_JUMP_FALSE1 + : INST_JUMP_TRUE1, 0, envPtr); + TclEmitPush(TclRegisterLiteral(envPtr, + (nodePtr->lexeme == AND) ? "1" : "0", 1, 0), envPtr); + pc2 = CurrentOffset(envPtr); + TclEmitInstInt1(INST_JUMP1, 0, envPtr); TclAdjustStackDepth(-1, envPtr); - TclFixupForwardJumpToHere(envPtr, &jumpPtr->next->jump, 127); + TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc1, + envPtr->codeStart + pc1 + 1); if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) { - jumpPtr->next->next->jump.codeOffset += 3; + pc2 += 3; } - TclEmitPush(TclRegisterNewLiteral(envPtr, - (nodePtr->lexeme == AND) ? "0" : "1", 1), envPtr); - TclFixupForwardJumpToHere(envPtr, &jumpPtr->next->next->jump, - 127); + TclEmitPush(TclRegisterLiteral(envPtr, + (nodePtr->lexeme == AND) ? "0" : "1", 1, 0), envPtr); + TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc2, + envPtr->codeStart + pc2 + 1); convert = 0; - envPtr->currStackDepth = jumpPtr->depth + 1; - freePtr = jumpPtr; - jumpPtr = jumpPtr->next; - TclStackFree(interp, freePtr); - freePtr = jumpPtr; - jumpPtr = jumpPtr->next; - TclStackFree(interp, freePtr); freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); @@ -2448,9 +2421,9 @@ CompileExprTree( if (optimize) { int length; const char *bytes = TclGetStringFromObj(literal, &length); - int index = TclRegisterNewLiteral(envPtr, bytes, length); + int index = TclRegisterLiteral(envPtr, bytes, length, 0); Tcl_Obj *objPtr = TclFetchLiteral(envPtr, index); - + if ((objPtr->typePtr == NULL) && (literal->typePtr != NULL)) { /* * Would like to do this: @@ -2506,8 +2479,8 @@ CompileExprTree( if (objPtr->bytes) { Tcl_Obj *tableValue; - index = TclRegisterNewLiteral(envPtr, objPtr->bytes, - objPtr->length); + index = TclRegisterLiteral(envPtr, objPtr->bytes, + objPtr->length, 0); tableValue = TclFetchLiteral(envPtr, index); if ((tableValue->typePtr == NULL) && (objPtr->typePtr != NULL)) { @@ -2593,7 +2566,7 @@ TclSingleOpCmd( * * TclSortingOpCmd -- * Implements the commands: - * <, <=, >, >=, ==, eq + * <, <=, >, >=, ==, eq * in the ::tcl::mathop namespace. These commands are defined for * arbitrary number of arguments by computing the AND of the base * operator applied to all neighbor argument pairs. diff --git a/generic/tclCompile.c b/generic/tclCompile.c index f5c8d41..b5de230 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -17,15 +17,6 @@ #include <assert.h> /* - * Table of all AuxData types. - */ - -static Tcl_HashTable auxDataTypeTable; -static int auxDataTypeTableInitialized; /* 0 means not yet initialized. */ - -TCL_DECLARE_MUTEX(tableMutex) - -/* * Variable that controls whether compilation tracing is enabled and, if so, * what level of tracing is desired: * 0: no compilation tracing @@ -55,15 +46,15 @@ InstructionDesc const tclInstructionTable[] = { /* Name Bytes stackEffect #Opnds Operand types */ {"done", 1, -1, 0, {OPERAND_NONE}}, /* Finish ByteCode execution and return stktop (top stack item) */ - {"push1", 2, +1, 1, {OPERAND_UINT1}}, + {"push1", 2, +1, 1, {OPERAND_LIT1}}, /* Push object at ByteCode objArray[op1] */ - {"push4", 5, +1, 1, {OPERAND_UINT4}}, + {"push4", 5, +1, 1, {OPERAND_LIT4}}, /* 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}}, + {"strcat", 2, INT_MIN, 1, {OPERAND_UINT1}}, /* Concatenate the top op1 items and push result */ {"invokeStk1", 2, INT_MIN, 1, {OPERAND_UINT1}}, /* Invoke command named objv[0]; <objc,objv> = <op1,top op1> */ @@ -125,17 +116,17 @@ InstructionDesc const tclInstructionTable[] = { {"incrStkImm", 2, 0, 1, {OPERAND_INT1}}, /* Incr general variable; unparsed name is top, amount is op1 */ - {"jump1", 2, 0, 1, {OPERAND_INT1}}, + {"jump1", 2, 0, 1, {OPERAND_OFFSET1}}, /* Jump relative to (pc + op1) */ - {"jump4", 5, 0, 1, {OPERAND_INT4}}, + {"jump4", 5, 0, 1, {OPERAND_OFFSET4}}, /* Jump relative to (pc + op4) */ - {"jumpTrue1", 2, -1, 1, {OPERAND_INT1}}, + {"jumpTrue1", 2, -1, 1, {OPERAND_OFFSET1}}, /* Jump relative to (pc + op1) if stktop expr object is true */ - {"jumpTrue4", 5, -1, 1, {OPERAND_INT4}}, + {"jumpTrue4", 5, -1, 1, {OPERAND_OFFSET4}}, /* Jump relative to (pc + op4) if stktop expr object is true */ - {"jumpFalse1", 2, -1, 1, {OPERAND_INT1}}, + {"jumpFalse1", 2, -1, 1, {OPERAND_OFFSET1}}, /* Jump relative to (pc + op1) if stktop expr object is false */ - {"jumpFalse4", 5, -1, 1, {OPERAND_INT4}}, + {"jumpFalse4", 5, -1, 1, {OPERAND_OFFSET4}}, /* Jump relative to (pc + op4) if stktop expr object is false */ {"lor", 1, -1, 0, {OPERAND_NONE}}, @@ -298,7 +289,7 @@ InstructionDesc const tclInstructionTable[] = { /* List Index: push (lindex stktop op4) */ {"listRangeImm", 9, 0, 2, {OPERAND_IDX4, OPERAND_IDX4}}, /* List Range: push (lrange stktop op4 op4) */ - {"startCommand", 9, 0, 2, {OPERAND_INT4,OPERAND_UINT4}}, + {"startCommand", 9, 0, 2, {OPERAND_OFFSET4, OPERAND_UINT4}}, /* Start of bytecoded command: op is the length of the cmd's code, op2 * is number of commands here */ @@ -356,7 +347,7 @@ InstructionDesc const tclInstructionTable[] = { /* Create the variables (described in the aux data referred to by the * second immediate argument) to mirror the state of the dictionary in * the variable referred to by the first immediate argument. The list - * of keys (top of the stack, not poppsed) must be the same length as + * of keys (top of the stack, not popped) must be the same length as * the list of variables. * Stack: ... keyList => ... keyList */ {"dictUpdateEnd", 9, -1, 2, {OPERAND_LVT4, OPERAND_AUX4}}, @@ -493,6 +484,7 @@ InstructionDesc const tclInstructionTable[] = { * qualified version, or produces the empty string if no such command * exists. Never generates errors. * Stack: ... cmdName => ... fullCmdName */ + {"tclooSelf", 1, +1, 0, {OPERAND_NONE}}, /* Push the identity of the current TclOO object (i.e., the name of * its current public access command) on the stack. */ @@ -517,7 +509,7 @@ InstructionDesc const tclInstructionTable[] = { * case. Also runs the whole-array trace on the named variable, so can * throw anything. * Stack: ... varName => ... boolean */ - {"arrayExistsImm", 5, +1, 1, {OPERAND_UINT4}}, + {"arrayExistsImm", 5, +1, 1, {OPERAND_LVT4}}, /* Looks up the variable indexed by opnd and tests whether it is an * array. Pushes a boolean describing whether this is the case. Also * runs the whole-array trace on the named variable, so can throw @@ -527,7 +519,7 @@ InstructionDesc const tclInstructionTable[] = { /* Forces the element on the top of the stack to be the name of an * array. * Stack: ... varName => ... */ - {"arrayMakeImm", 5, 0, 1, {OPERAND_UINT4}}, + {"arrayMakeImm", 5, 0, 1, {OPERAND_LVT4}}, /* Forces the variable indexed by opnd to be an array. Does not touch * the stack. */ @@ -545,6 +537,128 @@ InstructionDesc const tclInstructionTable[] = { /* Drops an element from the auxiliary stack, popping stack elements * until the matching stack depth is reached. */ + /* New foreach implementation */ + {"foreach_start", 5, +2, 1, {OPERAND_AUX4}}, + /* Initialize execution of a foreach loop. Operand is aux data index + * of the ForeachInfo structure for the foreach command. It pushes 2 + * elements which hold runtime params for foreach_step, they are later + * dropped by foreach_end together with the value lists. NOTE that the + * iterator-tracker and info reference must not be passed to bytecodes + * that handle normal Tcl values. NOTE that this instruction jumps to + * the foreach_step instruction paired with it; the stack info below + * is only nominal. + * Stack: ... listObjs... => ... listObjs... iterTracker info */ + {"foreach_step", 1, 0, 0, {OPERAND_NONE}}, + /* "Step" or begin next iteration of foreach loop. Assigns to foreach + * iteration variables. May jump to straight after the foreach_start + * that pushed the iterTracker and info values. MUST be followed + * immediately by a foreach_end. + * Stack: ... listObjs... iterTracker info => + * ... listObjs... iterTracker info */ + {"foreach_end", 1, 0, 0, {OPERAND_NONE}}, + /* Clean up a foreach loop by dropping the info value, the tracker + * value and the lists that were being iterated over. + * Stack: ... listObjs... iterTracker info => ... */ + {"lmap_collect", 1, -1, 0, {OPERAND_NONE}}, + /* Appends the value at the top of the stack to the list located on + * the stack the "other side" of the foreach-related values. + * Stack: ... collector listObjs... iterTracker info value => + * ... collector listObjs... iterTracker info */ + + {"strtrim", 1, -1, 0, {OPERAND_NONE}}, + /* [string trim] core: removes the characters (designated by the value + * at the top of the stack) from both ends of the string and pushes + * the resulting string. + * Stack: ... string charset => ... trimmedString */ + {"strtrimLeft", 1, -1, 0, {OPERAND_NONE}}, + /* [string trimleft] core: removes the characters (designated by the + * value at the top of the stack) from the left of the string and + * pushes the resulting string. + * Stack: ... string charset => ... trimmedString */ + {"strtrimRight", 1, -1, 0, {OPERAND_NONE}}, + /* [string trimright] core: removes the characters (designated by the + * value at the top of the stack) from the right of the string and + * pushes the resulting string. + * Stack: ... string charset => ... trimmedString */ + + {"concatStk", 5, INT_MIN, 1, {OPERAND_UINT4}}, + /* Wrapper round Tcl_ConcatObj(), used for [concat] and [eval]. opnd + * is number of values to concatenate. + * Operation: push concat(stk1 stk2 ... stktop) */ + + {"strcaseUpper", 1, 0, 0, {OPERAND_NONE}}, + /* [string toupper] core: converts whole string to upper case using + * the default (extended "C" locale) rules. + * Stack: ... string => ... newString */ + {"strcaseLower", 1, 0, 0, {OPERAND_NONE}}, + /* [string tolower] core: converts whole string to upper case using + * the default (extended "C" locale) rules. + * Stack: ... string => ... newString */ + {"strcaseTitle", 1, 0, 0, {OPERAND_NONE}}, + /* [string totitle] core: converts whole string to upper case using + * the default (extended "C" locale) rules. + * Stack: ... string => ... newString */ + {"strreplace", 1, -3, 0, {OPERAND_NONE}}, + /* [string replace] core: replaces a non-empty range of one string + * with the contents of another. + * Stack: ... string fromIdx toIdx replacement => ... newString */ + + {"originCmd", 1, 0, 0, {OPERAND_NONE}}, + /* Reports which command was the origin (via namespace import chain) + * of the command named on the top of the stack. + * Stack: ... cmdName => ... fullOriginalCmdName */ + + {"tclooNext", 2, INT_MIN, 1, {OPERAND_UINT1}}, + /* Call the next item on the TclOO call chain, passing opnd arguments + * (min 1, max 255, *includes* "next"). The result of the invoked + * method implementation will be pushed on the stack in place of the + * arguments (similar to invokeStk). + * Stack: ... "next" arg2 arg3 -- argN => ... result */ + {"tclooNextClass", 2, INT_MIN, 1, {OPERAND_UINT1}}, + /* Call the following item on the TclOO call chain defined by class + * className, passing opnd arguments (min 2, max 255, *includes* + * "nextto" and the class name). The result of the invoked method + * implementation will be pushed on the stack in place of the + * arguments (similar to invokeStk). + * Stack: ... "nextto" className arg3 arg4 -- argN => ... result */ + + {"yieldToInvoke", 1, 0, 0, {OPERAND_NONE}}, + /* Makes the current coroutine yield the value at the top of the + * stack, invoking the given command/args with resolution in the given + * namespace (all packed into a list), and places the list of values + * that are the response back on top of the stack when it resumes. + * Stack: ... [list ns cmd arg1 ... argN] => ... resumeList */ + + {"numericType", 1, 0, 0, {OPERAND_NONE}}, + /* Pushes the numeric type code of the word at the top of the stack. + * Stack: ... value => ... typeCode */ + {"tryCvtToBoolean", 1, +1, 0, {OPERAND_NONE}}, + /* Try converting stktop to boolean if possible. No errors. + * Stack: ... value => ... value isStrictBool */ + {"strclass", 2, 0, 1, {OPERAND_SCLS1}}, + /* See if all the characters of the given string are a member of the + * specified (by opnd) character class. Note that an empty string will + * satisfy the class check (standard definition of "all"). + * Stack: ... stringValue => ... boolean */ + + {"lappendList", 5, 0, 1, {OPERAND_LVT4}}, + /* Lappend list to scalar variable at op4 in frame. + * Stack: ... list => ... listVarContents */ + {"lappendListArray", 5, -1, 1, {OPERAND_LVT4}}, + /* Lappend list to array element; array at op4. + * Stack: ... elem list => ... listVarContents */ + {"lappendListArrayStk", 1, -2, 0, {OPERAND_NONE}}, + /* Lappend list to array element. + * Stack: ... arrayName elem list => ... listVarContents */ + {"lappendListStk", 1, -1, 0, {OPERAND_NONE}}, + /* Lappend list to general variable. + * Stack: ... varName list => ... listVarContents */ + + {"clockRead", 2, +1, 1, {OPERAND_UINT1}}, + /* Read clock out to the stack. Operand is which clock to read + * 0=clicks, 1=microseconds, 2=milliseconds, 3=seconds. + * Stack: ... => ... time */ + {NULL, 0, 0, 0, {OPERAND_NONE}} }; @@ -552,6 +666,7 @@ InstructionDesc const tclInstructionTable[] = { * Prototypes for procedures defined later in this file: */ +static void CleanupByteCode(ByteCode *codePtr); static ByteCode * CompileSubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); static void DupByteCodeInternalRep(Tcl_Obj *srcPtr, @@ -567,18 +682,13 @@ static void FreeSubstCodeInternalRep(Tcl_Obj *objPtr); static int GetCmdLocEncodingSize(CompileEnv *envPtr); static int IsCompactibleCompileEnv(Tcl_Interp *interp, CompileEnv *envPtr); +static void PreventCycle(Tcl_Obj *objPtr, CompileEnv *envPtr); #ifdef TCL_COMPILE_STATS static void RecordByteCodeStats(ByteCode *codePtr); #endif /* TCL_COMPILE_STATS */ -static void RegisterAuxDataType(const AuxDataType *typePtr); static int SetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void StartExpanding(CompileEnv *envPtr); -static int FormatInstruction(ByteCode *codePtr, - const unsigned char *pc, Tcl_Obj *bufferObj); -static void PrintSourceToObj(Tcl_Obj *appendObj, - const char *stringPtr, int maxChars); -static void UpdateStringOfInstName(Tcl_Obj *objPtr); /* * TIP #280: Helper for building the per-word line information of all compiled @@ -617,19 +727,6 @@ static const Tcl_ObjType substCodeType = { }; /* - * The structure below defines an instruction name Tcl object to allow - * reporting of inner contexts in errorstack without string allocation. - */ - -static const Tcl_ObjType tclInstNameType = { - "instname", /* name */ - NULL, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - UpdateStringOfInstName, /* updateStringProc */ - NULL, /* setFromAnyProc */ -}; - -/* * Helper macros. */ @@ -673,7 +770,8 @@ TclSetByteCodeFromAny( Interp *iPtr = (Interp *) interp; CompileEnv compEnv; /* Compilation environment structure allocated * in frame. */ - int length, result = TCL_OK; + size_t length; + int result = TCL_OK; const char *stringPtr; Proc *procPtr = iPtr->compiledProcPtr; ContLineLoc *clLocPtr; @@ -688,7 +786,8 @@ TclSetByteCodeFromAny( } #endif - stringPtr = TclGetStringFromObj(objPtr, &length); + stringPtr = TclGetString(objPtr); + length = objPtr->length; /* * TIP #280: Pick up the CmdFrame in which the BC compiler was invoked and @@ -754,7 +853,9 @@ TclSetByteCodeFromAny( * instruction generator boundaries. */ - TclOptimizeBytecode(&compEnv); + if (iPtr->extra.optimizer) { + (iPtr->extra.optimizer)(&compEnv); + } /* * Invoke the compilation hook procedure if one exists. @@ -774,7 +875,7 @@ TclSetByteCodeFromAny( #endif /*TCL_COMPILE_DEBUG*/ if (result == TCL_OK) { - TclInitByteCodeObj(objPtr, &compEnv); + (void) TclInitByteCodeObj(objPtr, &tclByteCodeType, &compEnv); #ifdef TCL_COMPILE_DEBUG if (tclTraceCompile >= 2) { TclPrintByteCodeObj(interp, objPtr); @@ -875,17 +976,13 @@ FreeByteCodeInternalRep( { register ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; - objPtr->typePtr = NULL; - codePtr->refCount--; - if (codePtr->refCount <= 0) { - TclCleanupByteCode(codePtr); - } + TclReleaseByteCode(codePtr); } /* *---------------------------------------------------------------------- * - * TclCleanupByteCode -- + * TclReleaseByteCode -- * * This procedure does all the real work of freeing up a bytecode * object's ByteCode structure. It's called only when the structure's @@ -902,7 +999,26 @@ FreeByteCodeInternalRep( */ void -TclCleanupByteCode( +TclPreserveByteCode( + register ByteCode *codePtr) +{ + codePtr->refCount++; +} + +void +TclReleaseByteCode( + register ByteCode *codePtr) +{ + if (codePtr->refCount-- > 1) { + return; + } + + /* Just dropped to refcount==0. Clean up. */ + CleanupByteCode(codePtr); +} + +static void +CleanupByteCode( register ByteCode *codePtr) /* Points to the ByteCode to free. */ { Tcl_Interp *interp = (Tcl_Interp *) *codePtr->interpHandle; @@ -1169,8 +1285,6 @@ Tcl_NRSubstObj( * * Results: * A (ByteCode *) is returned pointing to the resulting ByteCode. - * The caller must manage its refCount and arrange for a call to - * TclCleanupByteCode() when the last reference disappears. * * Side effects: * The Tcl_ObjType of objPtr is changed to the "substcode" type, and the @@ -1193,21 +1307,21 @@ CompileSubstObj( if (objPtr->typePtr == &substCodeType) { Namespace *nsPtr = iPtr->varFramePtr->nsPtr; - codePtr = objPtr->internalRep.ptrAndLongRep.ptr; - if ((unsigned long)flags != objPtr->internalRep.ptrAndLongRep.value + codePtr = objPtr->internalRep.twoPtrValue.ptr1; + if (flags != PTR2INT(objPtr->internalRep.twoPtrValue.ptr2) || ((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != nsPtr) || (codePtr->nsEpoch != nsPtr->resolverEpoch) || (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) { - FreeSubstCodeInternalRep(objPtr); + TclFreeIntRep(objPtr); } } if (objPtr->typePtr != &substCodeType) { CompileEnv compEnv; int numBytes; - const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes); + const char *bytes = TclGetStringFromObj(objPtr, &numBytes); /* TODO: Check for more TIP 280 */ TclInitCompileEnv(interp, &compEnv, bytes, numBytes, NULL, 0); @@ -1215,13 +1329,11 @@ CompileSubstObj( TclSubstCompile(interp, bytes, numBytes, flags, 1, &compEnv); TclEmitOpcode(INST_DONE, &compEnv); - TclInitByteCodeObj(objPtr, &compEnv); - objPtr->typePtr = &substCodeType; + codePtr = TclInitByteCodeObj(objPtr, &substCodeType, &compEnv); TclFreeCompileEnv(&compEnv); - codePtr = objPtr->internalRep.twoPtrValue.ptr1; - objPtr->internalRep.ptrAndLongRep.ptr = codePtr; - objPtr->internalRep.ptrAndLongRep.value = flags; + objPtr->internalRep.twoPtrValue.ptr1 = codePtr; + objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(flags); if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; @@ -1260,13 +1372,9 @@ static void FreeSubstCodeInternalRep( register Tcl_Obj *objPtr) /* Object whose internal rep to free. */ { - register ByteCode *codePtr = objPtr->internalRep.ptrAndLongRep.ptr; + register ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; - objPtr->typePtr = NULL; - codePtr->refCount--; - if (codePtr->refCount <= 0) { - TclCleanupByteCode(codePtr); - } + TclReleaseByteCode(codePtr); } static void @@ -1279,14 +1387,14 @@ ReleaseCmdWordData( Tcl_DecrRefCount(eclPtr->path); } for (i=0 ; i<eclPtr->nuloc ; i++) { - ckfree((char *) eclPtr->loc[i].line); + ckfree(eclPtr->loc[i].line); } if (eclPtr->loc != NULL) { - ckfree((char *) eclPtr->loc); + ckfree(eclPtr->loc); } - ckfree((char *) eclPtr); + ckfree(eclPtr); } /* @@ -1524,7 +1632,7 @@ TclFreeCompileEnv( envPtr->localLitTable.buckets = envPtr->localLitTable.staticBuckets; } if (envPtr->iPtr) { - /* + /* * We never converted to Bytecode, so free the things we would * have transferred to it. */ @@ -1691,9 +1799,17 @@ CompileCmdLiteral( CompileEnv *envPtr) { int numBytes; - const char *bytes = Tcl_GetStringFromObj(cmdObj, &numBytes); - int cmdLitIdx = TclRegisterNewCmdLiteral(envPtr, bytes, numBytes); - Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); + const char *bytes; + Command *cmdPtr; + int cmdLitIdx, extraLiteralFlags = LITERAL_CMD_NAME; + + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); + if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) { + extraLiteralFlags |= LITERAL_UNSHARED; + } + + bytes = TclGetStringFromObj(cmdObj, &numBytes); + cmdLitIdx = TclRegisterLiteral(envPtr, bytes, numBytes, extraLiteralFlags); if (cmdPtr) { TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr); @@ -1709,7 +1825,7 @@ TclCompileInvocation( int numWords, CompileEnv *envPtr) { - int wordIdx = 0; + int wordIdx = 0, depth = TclGetStackDepth(envPtr); DefineLineInformation; if (cmdObj) { @@ -1728,8 +1844,8 @@ TclCompileInvocation( continue; } - objIdx = TclRegisterNewLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size); + objIdx = TclRegisterLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size, 0); if (envPtr->clNext) { TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), tokenPtr[1].start - envPtr->source, envPtr->clNext); @@ -1738,10 +1854,11 @@ TclCompileInvocation( } if (wordIdx <= 255) { - TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); + TclEmitInvoke(envPtr, INST_INVOKE_STK1, wordIdx); } else { - TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr); + TclEmitInvoke(envPtr, INST_INVOKE_STK4, wordIdx); } + TclCheckStackDepth(depth+1, envPtr); } static void @@ -1754,7 +1871,7 @@ CompileExpanded( { int wordIdx = 0; DefineLineInformation; - + int depth = TclGetStackDepth(envPtr); StartExpanding(envPtr); if (cmdObj) { @@ -1777,8 +1894,8 @@ CompileExpanded( continue; } - objIdx = TclRegisterNewLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size); + objIdx = TclRegisterLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size, 0); if (envPtr->clNext) { TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), tokenPtr[1].start - envPtr->source, envPtr->clNext); @@ -1787,27 +1904,24 @@ CompileExpanded( } /* - * The stack depth during argument expansion can only be - * managed at runtime, as the number of elements in the - * expanded lists is not known at compile time. We adjust here - * the stack depth estimate so that it is correct after the - * command with expanded arguments returns. + * The stack depth during argument expansion can only be managed at + * runtime, as the number of elements in the expanded lists is not known + * at compile time. We adjust here the stack depth estimate so that it is + * correct after the command with expanded arguments returns. * - * The end effect of this command's invocation is that all the - * words of the command are popped from the stack, and the - * result is pushed: the stack top changes by (1-wordIdx). + * The end effect of this command's invocation is that all the words of + * the command are popped from the stack, and the result is pushed: the + * stack top changes by (1-wordIdx). * - * Note that the estimates are not correct while the command - * is being prepared and run, INST_EXPAND_STKTOP is not - * stack-neutral in general. + * Note that the estimates are not correct while the command is being + * prepared and run, INST_EXPAND_STKTOP is not stack-neutral in general. */ - TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); - envPtr->expandCount--; - TclAdjustStackDepth(1 - wordIdx, envPtr); + TclEmitInvoke(envPtr, INST_INVOKE_EXPANDED, wordIdx); + TclCheckStackDepth(depth+1, envPtr); } -static int +static int CompileCmdCompileProc( Tcl_Interp *interp, Tcl_Parse *parsePtr, @@ -1816,10 +1930,11 @@ CompileCmdCompileProc( { int unwind = 0, incrOffset = -1; DefineLineInformation; + int depth = TclGetStackDepth(envPtr); /* - * Emit of the INST_START_CMD instruction is controlled by - * the value of envPtr->atCmdStart: + * Emit of the INST_START_CMD instruction is controlled by the value of + * envPtr->atCmdStart: * * atCmdStart == 2 : We are not using the INST_START_CMD instruction. * atCmdStart == 1 : INST_START_CMD was the last instruction emitted. @@ -1850,9 +1965,10 @@ CompileCmdCompileProc( if (TCL_OK == TclAttemptCompileProc(interp, parsePtr, 1, cmdPtr, envPtr)) { if (incrOffset >= 0) { /* - * We successfully compiled a command. Increment the number - * of commands that start at the currently active INST_START_CMD. + * We successfully compiled a command. Increment the number of + * commands that start at the currently active INST_START_CMD. */ + unsigned char *incrPtr = envPtr->codeStart + incrOffset; unsigned char *startPtr = incrPtr - 5; @@ -1862,15 +1978,16 @@ CompileCmdCompileProc( TclStoreInt4AtPtr(envPtr->codeNext - startPtr, startPtr + 1); } } + TclCheckStackDepth(depth+1, envPtr); return TCL_OK; } envPtr->codeNext -= unwind; /* Unwind INST_START_CMD */ /* - * Throw out any line information generated by the failed - * compile attempt. + * Throw out any line information generated by the failed compile attempt. */ + while (mapPtr->nuloc - 1 > eclIndex) { mapPtr->nuloc--; ckfree(mapPtr->loc[mapPtr->nuloc].line); @@ -1878,11 +1995,11 @@ CompileCmdCompileProc( } /* - * Reset the index of next command. - * Toss out any from failed nested partial compiles. + * Reset the index of next command. Toss out any from failed nested + * partial compiles. */ - envPtr->numCommands = mapPtr->nuloc; + envPtr->numCommands = mapPtr->nuloc; return TCL_ERROR; } @@ -1904,6 +2021,7 @@ CompileCommandTokens( int *clNext = envPtr->clNext; int cmdIdx = envPtr->numCommands; int startCodeOffset = envPtr->codeNext - envPtr->codeStart; + int depth = TclGetStackDepth(envPtr); assert (parsePtr->numWords > 0); @@ -1914,11 +2032,10 @@ CompileCommandTokens( parsePtr->commandStart - envPtr->source, startCodeOffset); /* - * TIP #280. Scan the words and compute the extended location - * information. The map first contain full per-word line - * information for use by the compiler. This is later replaced by - * a reduced form which signals non-literal words, stored in - * 'wlines'. + * TIP #280. Scan the words and compute the extended location information. + * The map first contain full per-word line information for use by the + * compiler. This is later replaced by a reduced form which signals + * non-literal words, stored in 'wlines'. */ EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source, @@ -1940,8 +2057,8 @@ CompileCommandTokens( cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); if (cmdPtr) { /* - * Found a command. Test the ways we can be told - * not to attempt to compile it. + * Found a command. Test the ways we can be told not to attempt + * to compile it. */ if ((cmdPtr->compileProc == NULL) || (cmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION) @@ -1985,8 +2102,8 @@ CompileCommandTokens( (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); /* - * TIP #280: Free full form of per-word line data and insert the - * reduced form now + * TIP #280: Free full form of per-word line data and insert the reduced + * form now */ envPtr->line = cmdLine; @@ -1996,6 +2113,7 @@ CompileCommandTokens( eclPtr->loc[wlineat].line = wlines; eclPtr->loc[wlineat].next = NULL; + TclCheckStackDepth(depth, envPtr); return cmdIdx; } @@ -2015,6 +2133,7 @@ TclCompileScript( * Initial value of -1 indicates this routine * has not yet generated any bytecode. */ const char *p = script; /* Where we are in our compile. */ + int depth = TclGetStackDepth(envPtr); if (envPtr->iPtr == NULL) { Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv"); @@ -2071,20 +2190,20 @@ TclCompileScript( if (parse.numWords == 0) { /* - * The "command" parsed has no words. In this case - * we can skip the rest of the loop body. With no words, - * clearly CompileCommandTokens() has nothing to do. Since - * the parser aggressively sucks up leading comment and white - * space, including newlines, parse.commandStart must be - * pointing at either the end of script, or a command-terminating - * semi-colon. In either case, the TclAdvance*() calls have - * nothing to do. Finally, when no words are parsed, no - * tokens have been allocated at parse.tokenPtr so there's - * also nothing for Tcl_FreeParse() to do. + * The "command" parsed has no words. In this case we can skip + * the rest of the loop body. With no words, clearly + * CompileCommandTokens() has nothing to do. Since the parser + * aggressively sucks up leading comment and white space, + * including newlines, parse.commandStart must be pointing at + * either the end of script, or a command-terminating semi-colon. + * In either case, the TclAdvance*() calls have nothing to do. + * Finally, when no words are parsed, no tokens have been + * allocated at parse.tokenPtr so there's also nothing for + * Tcl_FreeParse() to do. * * The advantage of this shortcut is that CompileCommandTokens() - * can be written with an assumption that parse.numWords > 0, - * with the implication the CCT() always generates bytecode. + * can be written with an assumption that parse.numWords > 0, with + * the implication the CCT() always generates bytecode. */ continue; } @@ -2103,27 +2222,30 @@ TclCompileScript( if (lastCmdIdx == -1) { /* - * Compiling the script yielded no bytecode. The script must be - * all whitespace, comments, and empty commands. Such scripts - * are defined to successfully produce the empty string result, - * so we emit the simple bytecode that makes that happen. + * Compiling the script yielded no bytecode. The script must be all + * whitespace, comments, and empty commands. Such scripts are defined + * to successfully produce the empty string result, so we emit the + * simple bytecode that makes that happen. */ + PushStringLiteral(envPtr, ""); } else { /* * We compiled at least one command to bytecode. The routine * CompileCommandTokens() follows the bytecode of each compiled - * command with an INST_POP, so that stack balance is maintained - * when several commands are in sequence. (The result of each - * command is thrown away before moving on to the next command). - * For the last command compiled, we need to undo that INST_POP - * so that the result of the last command becomes the result of - * the script. The code here removes that trailing INST_POP. + * command with an INST_POP, so that stack balance is maintained when + * several commands are in sequence. (The result of each command is + * thrown away before moving on to the next command). For the last + * command compiled, we need to undo that INST_POP so that the result + * of the last command becomes the result of the script. The code + * here removes that trailing INST_POP. */ + envPtr->cmdMapPtr[lastCmdIdx].numCodeBytes--; envPtr->codeNext--; envPtr->currStackDepth++; } + TclCheckStackDepth(depth+1, envPtr); } /* @@ -2229,11 +2351,12 @@ TclCompileTokens( Tcl_DString textBuffer; /* Holds concatenated chars from adjacent * TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */ char buffer[TCL_UTF_MAX]; - int i, numObjsToConcat, length; + int i, numObjsToConcat, length, adjust; unsigned char *entryCodeNext = envPtr->codeNext; #define NUM_STATIC_POS 20 int isLiteral, maxNumCL, numCL; int *clPosition = NULL; + int depth = TclGetStackDepth(envPtr); /* * For the handling of continuation lines in literals we first check if @@ -2266,6 +2389,7 @@ TclCompileTokens( clPosition = ckalloc(maxNumCL * sizeof(int)); } + adjust = 0; Tcl_DStringInit(&textBuffer); numObjsToConcat = 0; for ( ; count > 0; count--, tokenPtr++) { @@ -2309,6 +2433,7 @@ TclCompileTokens( clPosition[numCL] = clPos; numCL ++; } + adjust++; } break; @@ -2331,8 +2456,10 @@ TclCompileTokens( numCL = 0; } + envPtr->line += adjust; TclCompileScript(interp, tokenPtr->start+1, tokenPtr->size-2, envPtr); + envPtr->line -= adjust; numObjsToConcat++; break; @@ -2383,11 +2510,11 @@ TclCompileTokens( */ while (numObjsToConcat > 255) { - TclEmitInstInt1(INST_CONCAT1, 255, envPtr); + TclEmitInstInt1(INST_STR_CONCAT1, 255, envPtr); numObjsToConcat -= 254; /* concat pushes 1 obj, the result */ } if (numObjsToConcat > 1) { - TclEmitInstInt1(INST_CONCAT1, numObjsToConcat, envPtr); + TclEmitInstInt1(INST_STR_CONCAT1, numObjsToConcat, envPtr); } /* @@ -2407,6 +2534,7 @@ TclCompileTokens( if (maxNumCL) { ckfree(clPosition); } + TclCheckStackDepth(depth+1, envPtr); } /* @@ -2454,7 +2582,7 @@ TclCompileCmdWord( */ TclCompileTokens(interp, tokenPtr, count, envPtr); - TclEmitOpcode(INST_EVAL_STK, envPtr); + TclEmitInvoke(envPtr, INST_EVAL_STK); } } @@ -2518,11 +2646,11 @@ TclCompileExprWords( } concatItems = 2*numWords - 1; while (concatItems > 255) { - TclEmitInstInt1(INST_CONCAT1, 255, envPtr); + TclEmitInstInt1(INST_STR_CONCAT1, 255, envPtr); concatItems -= 254; } if (concatItems > 1) { - TclEmitInstInt1(INST_CONCAT1, concatItems, envPtr); + TclEmitInstInt1(INST_STR_CONCAT1, concatItems, envPtr); } TclEmitOpcode(INST_EXPR_STK, envPtr); } @@ -2595,11 +2723,40 @@ TclCompileNoOp( *---------------------------------------------------------------------- */ -void -TclInitByteCodeObj( - Tcl_Obj *objPtr, /* Points object that should be initialized, - * and whose string rep contains the source - * code. */ +static void +PreventCycle( + Tcl_Obj *objPtr, + CompileEnv *envPtr) +{ + int i; + + for (i = 0; i < envPtr->literalArrayNext; i++) { + if (objPtr == TclFetchLiteral(envPtr, i)) { + /* + * Prevent circular reference where the bytecode intrep of + * a value contains a literal which is that same value. + * If this is allowed to happen, refcount decrements may not + * reach zero, and memory may leak. Bugs 467523, 3357771 + * + * NOTE: [Bugs 3392070, 3389764] We make a copy based completely + * on the string value, and do not call Tcl_DuplicateObj() so we + * can be sure we do not have any lingering cycles hiding in + * the intrep. + */ + int numBytes; + const char *bytes = TclGetStringFromObj(objPtr, &numBytes); + Tcl_Obj *copyPtr = Tcl_NewStringObj(bytes, numBytes); + + Tcl_IncrRefCount(copyPtr); + TclReleaseLiteral((Tcl_Interp *)envPtr->iPtr, objPtr); + + envPtr->literalArrayPtr[i].objPtr = copyPtr; + } + } +} + +ByteCode * +TclInitByteCode( register CompileEnv *envPtr)/* Points to the CompileEnv structure from * which to create a ByteCode structure. */ { @@ -2650,7 +2807,8 @@ TclInitByteCodeObj( codePtr->compileEpoch = iPtr->compileEpoch; codePtr->nsPtr = namespacePtr; codePtr->nsEpoch = namespacePtr->resolverEpoch; - codePtr->refCount = 1; + codePtr->refCount = 0; + TclPreserveByteCode(codePtr); if (namespacePtr->compiledVarResProc || iPtr->resolverPtr) { codePtr->flags = TCL_BYTECODE_RESOLVE_VARS; } else { @@ -2676,29 +2834,7 @@ TclInitByteCodeObj( p += TCL_ALIGN(codeBytes); /* align object array */ codePtr->objArrayPtr = (Tcl_Obj **) p; for (i = 0; i < numLitObjects; i++) { - Tcl_Obj *fetched = TclFetchLiteral(envPtr, i); - - if (objPtr == fetched) { - /* - * Prevent circular reference where the bytecode intrep of - * a value contains a literal which is that same value. - * If this is allowed to happen, refcount decrements may not - * reach zero, and memory may leak. Bugs 467523, 3357771 - * - * NOTE: [Bugs 3392070, 3389764] We make a copy based completely - * on the string value, and do not call Tcl_DuplicateObj() so we - * can be sure we do not have any lingering cycles hiding in - * the intrep. - */ - int numBytes; - const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes); - - codePtr->objArrayPtr[i] = Tcl_NewStringObj(bytes, numBytes); - Tcl_IncrRefCount(codePtr->objArrayPtr[i]); - TclReleaseLiteral((Tcl_Interp *)iPtr, objPtr); - } else { - codePtr->objArrayPtr[i] = fetched; - } + codePtr->objArrayPtr[i] = TclFetchLiteral(envPtr, i); } p += TCL_ALIGN(objArrayBytes); /* align exception range array */ @@ -2741,15 +2877,6 @@ TclInitByteCodeObj( #endif /* TCL_COMPILE_STATS */ /* - * Free the old internal rep then convert the object to a bytecode object - * by making its internal rep point to the just compiled ByteCode. - */ - - TclFreeIntRep(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = codePtr; - objPtr->typePtr = &tclByteCodeType; - - /* * TIP #280. Associate the extended per-word line information with the * byte code object (internal rep), for use with the bc compiler. */ @@ -2762,6 +2889,33 @@ TclInitByteCodeObj( envPtr->iPtr = NULL; codePtr->localCachePtr = NULL; + return codePtr; +} + +ByteCode * +TclInitByteCodeObj( + Tcl_Obj *objPtr, /* Points object that should be initialized, + * and whose string rep contains the source + * code. */ + const Tcl_ObjType *typePtr, + register CompileEnv *envPtr)/* Points to the CompileEnv structure from + * which to create a ByteCode structure. */ +{ + ByteCode *codePtr; + + PreventCycle(objPtr, envPtr); + + codePtr = TclInitByteCode(envPtr); + + /* + * Free the old internal rep then convert the object to a bytecode object + * by making its internal rep point to the just compiled ByteCode. + */ + + TclFreeIntRep(objPtr); + objPtr->internalRep.twoPtrValue.ptr1 = codePtr; + objPtr->typePtr = typePtr; + return codePtr; } /* @@ -2829,7 +2983,8 @@ TclFindCompiledLocal( varNamePtr = &cachePtr->varName0; for (i=0; i < cachePtr->numVars; varNamePtr++, i++) { if (*varNamePtr) { - localName = Tcl_GetStringFromObj(*varNamePtr, &len); + localName = TclGetString(*varNamePtr); + len = (*varNamePtr)->length; if ((len == nameBytes) && !strncmp(name, localName, len)) { return i; } @@ -3137,8 +3292,10 @@ EnterCmdWordData( TclAdvanceLines(&wordLine, last, tokenPtr->start); TclAdvanceContinuations(&wordLine, &wordNext, tokenPtr->start - envPtr->source); + /* See Ticket 4b61afd660 */ wwlines[wordIdx] = - (TclWordKnownAtCompileTime(tokenPtr, NULL) ? wordLine : -1); + ((wordIdx == 0) || TclWordKnownAtCompileTime(tokenPtr, NULL)) + ? wordLine : -1; ePtr->line[wordIdx] = wordLine; ePtr->next[wordIdx] = wordNext; last = tokenPtr->start; @@ -3258,26 +3415,25 @@ TclGetInnermostExceptionRange( int returnCode, ExceptionAux **auxPtrPtr) { - int exnIdx = -1, i; + int i = envPtr->exceptArrayNext; + ExceptionRange *rangePtr = envPtr->exceptArrayPtr + i; - for (i=0 ; i<envPtr->exceptArrayNext ; i++) { - ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[i]; + while (i > 0) { + rangePtr--; i--; if (CurrentOffset(envPtr) >= rangePtr->codeOffset && (rangePtr->numCodeBytes == -1 || CurrentOffset(envPtr) < rangePtr->codeOffset+rangePtr->numCodeBytes) && (returnCode != TCL_CONTINUE || envPtr->exceptAuxArrayPtr[i].supportsContinue)) { - exnIdx = i; + + if (auxPtrPtr) { + *auxPtrPtr = envPtr->exceptAuxArrayPtr + i; + } + return rangePtr; } } - if (exnIdx == -1) { - return NULL; - } - if (auxPtrPtr) { - *auxPtrPtr = &envPtr->exceptAuxArrayPtr[exnIdx]; - } - return &envPtr->exceptArrayPtr[exnIdx]; + return NULL; } /* @@ -3351,9 +3507,9 @@ TclAddLoopContinueFixup( * * TclCleanupStackForBreakContinue -- * - * Ditch the extra elements from the auxiliary stack and the main - * stack. How to do this exactly depends on whether there are any - * elements on the auxiliary stack to pop. + * Ditch the extra elements from the auxiliary stack and the main stack. + * How to do this exactly depends on whether there are any elements on + * the auxiliary stack to pop. * * --------------------------------------------------------------------- */ @@ -3367,23 +3523,16 @@ TclCleanupStackForBreakContinue( int toPop = envPtr->expandCount - auxPtr->expandTarget; if (toPop > 0) { - while (toPop > 0) { + while (toPop --> 0) { TclEmitOpcode(INST_EXPAND_DROP, envPtr); - toPop--; } TclAdjustStackDepth(auxPtr->expandTargetDepth - envPtr->currStackDepth, envPtr); - toPop = auxPtr->expandTargetDepth - auxPtr->stackDepth; - while (toPop > 0) { - TclEmitOpcode(INST_POP, envPtr); - toPop--; - } - } else { - toPop = envPtr->currStackDepth - auxPtr->stackDepth; - while (toPop > 0) { - TclEmitOpcode(INST_POP, envPtr); - toPop--; - } + envPtr->currStackDepth = auxPtr->expandTargetDepth; + } + toPop = envPtr->currStackDepth - auxPtr->stackDepth; + while (toPop --> 0) { + TclEmitOpcode(INST_POP, envPtr); } envPtr->currStackDepth = savedStackDepth; } @@ -3900,185 +4049,219 @@ TclFixupForwardJump( /* *---------------------------------------------------------------------- * - * TclGetInstructionTable -- + * TclEmitInvoke -- * - * Returns a pointer to the table describing Tcl bytecode instructions. - * This procedure is defined so that clients can access the pointer from - * outside the TCL DLLs. + * Emit one of the invoke-related instructions, wrapping it if necessary + * in code that ensures that any break or continue operation passing + * through it gets the stack unwinding correct, converting it into an + * internal jump if in an appropriate context. * * Results: - * Returns a pointer to the global instruction table, same as the - * expression (&tclInstructionTable[0]). + * None * * Side effects: - * None. + * Issues the jump with all correct stack management. May create another + * loop exception range; pointers to ExceptionRange and ExceptionAux + * structures should not be held across this call. * *---------------------------------------------------------------------- */ -const void * /* == InstructionDesc* == */ -TclGetInstructionTable(void) -{ - return &tclInstructionTable[0]; -} - -/* - *-------------------------------------------------------------- - * - * RegisterAuxDataType -- - * - * This procedure is called to register a new AuxData type in the table - * of all AuxData types supported by Tcl. - * - * Results: - * None. - * - * Side effects: - * The type is registered in the AuxData type table. If there was already - * a type with the same name as in typePtr, it is replaced with the new - * type. - * - *-------------------------------------------------------------- - */ - -static void -RegisterAuxDataType( - const AuxDataType *typePtr) /* Information about object type; storage must - * be statically allocated (must live forever; - * will not be deallocated). */ +void +TclEmitInvoke( + CompileEnv *envPtr, + int opcode, + ...) { - register Tcl_HashEntry *hPtr; - int isNew; - - Tcl_MutexLock(&tableMutex); - if (!auxDataTypeTableInitialized) { - TclInitAuxDataTypeTable(); - } + va_list argList; + ExceptionRange *rangePtr; + ExceptionAux *auxBreakPtr, *auxContinuePtr; + int arg1, arg2, wordCount = 0, expandCount = 0; + int loopRange = 0, breakRange = 0, continueRange = 0; + int cleanup, depth = TclGetStackDepth(envPtr); /* - * If there's already a type with the given name, remove it. + * Parse the arguments. */ - hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typePtr->name); - if (hPtr != NULL) { - Tcl_DeleteHashEntry(hPtr); + va_start(argList, opcode); + switch (opcode) { + case INST_INVOKE_STK1: + wordCount = arg1 = cleanup = va_arg(argList, int); + arg2 = 0; + break; + case INST_INVOKE_STK4: + wordCount = arg1 = cleanup = va_arg(argList, int); + arg2 = 0; + break; + case INST_INVOKE_REPLACE: + arg1 = va_arg(argList, int); + arg2 = va_arg(argList, int); + wordCount = arg1 + arg2 - 1; + cleanup = arg1 + 1; + break; + default: + Tcl_Panic("unexpected opcode"); + case INST_EVAL_STK: + wordCount = cleanup = 1; + arg1 = arg2 = 0; + break; + case INST_RETURN_STK: + wordCount = cleanup = 2; + arg1 = arg2 = 0; + break; + case INST_INVOKE_EXPANDED: + wordCount = arg1 = cleanup = va_arg(argList, int); + arg2 = 0; + expandCount = 1; + break; } + va_end(argList); /* - * Now insert the new object type. + * Determine if we need to handle break and continue exceptions with a + * special handling exception range (so that we can correctly unwind the + * stack). + * + * These must be done separately; they can be different (especially for + * calls from inside a [for] increment clause). */ - hPtr = Tcl_CreateHashEntry(&auxDataTypeTable, typePtr->name, &isNew); - if (isNew) { - Tcl_SetHashValue(hPtr, typePtr); + rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_CONTINUE, + &auxContinuePtr); + if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) { + auxContinuePtr = NULL; + } else if (auxContinuePtr->stackDepth == envPtr->currStackDepth-wordCount + && auxContinuePtr->expandTarget == envPtr->expandCount-expandCount) { + auxContinuePtr = NULL; + } else { + continueRange = auxContinuePtr - envPtr->exceptAuxArrayPtr; } - Tcl_MutexUnlock(&tableMutex); -} - -/* - *---------------------------------------------------------------------- - * - * TclGetAuxDataType -- - * - * This procedure looks up an Auxdata type by name. - * - * Results: - * If an AuxData type with name matching "typeName" is found, a pointer - * to its AuxDataType structure is returned; otherwise, NULL is returned. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -const AuxDataType * -TclGetAuxDataType( - const char *typeName) /* Name of AuxData type to look up. */ -{ - register Tcl_HashEntry *hPtr; - const AuxDataType *typePtr = NULL; - Tcl_MutexLock(&tableMutex); - if (!auxDataTypeTableInitialized) { - TclInitAuxDataTypeTable(); + rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_BREAK, &auxBreakPtr); + if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) { + auxBreakPtr = NULL; + } else if (auxContinuePtr == NULL + && auxBreakPtr->stackDepth == envPtr->currStackDepth-wordCount + && auxBreakPtr->expandTarget == envPtr->expandCount-expandCount) { + auxBreakPtr = NULL; + } else { + breakRange = auxBreakPtr - envPtr->exceptAuxArrayPtr; } - hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typeName); - if (hPtr != NULL) { - typePtr = Tcl_GetHashValue(hPtr); + if (auxBreakPtr != NULL || auxContinuePtr != NULL) { + loopRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + ExceptionRangeStarts(envPtr, loopRange); } - Tcl_MutexUnlock(&tableMutex); - return typePtr; -} - -/* - *-------------------------------------------------------------- - * - * TclInitAuxDataTypeTable -- - * - * This procedure is invoked to perform once-only initialization of the - * AuxData type table. It also registers the AuxData types defined in - * this file. - * - * Results: - * None. - * - * Side effects: - * Initializes the table of defined AuxData types "auxDataTypeTable" with - * builtin AuxData types defined in this file. - * - *-------------------------------------------------------------- - */ - -void -TclInitAuxDataTypeTable(void) -{ /* - * The table mutex must already be held before this routine is invoked. + * Issue the invoke itself. */ - auxDataTypeTableInitialized = 1; - Tcl_InitHashTable(&auxDataTypeTable, TCL_STRING_KEYS); + switch (opcode) { + case INST_INVOKE_STK1: + TclEmitInstInt1(INST_INVOKE_STK1, arg1, envPtr); + break; + case INST_INVOKE_STK4: + TclEmitInstInt4(INST_INVOKE_STK4, arg1, envPtr); + break; + case INST_INVOKE_EXPANDED: + TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); + envPtr->expandCount--; + TclAdjustStackDepth(1 - arg1, envPtr); + break; + case INST_EVAL_STK: + TclEmitOpcode(INST_EVAL_STK, envPtr); + break; + case INST_RETURN_STK: + TclEmitOpcode(INST_RETURN_STK, envPtr); + break; + case INST_INVOKE_REPLACE: + TclEmitInstInt4(INST_INVOKE_REPLACE, arg1, envPtr); + TclEmitInt1(arg2, envPtr); + TclAdjustStackDepth(-1, envPtr); /* Correction to stack depth calcs */ + break; + } /* - * There are only three AuxData types at this time, so register them here. + * If we're generating a special wrapper exception range, we need to + * finish that up now. */ - RegisterAuxDataType(&tclForeachInfoType); - RegisterAuxDataType(&tclJumptableInfoType); - RegisterAuxDataType(&tclDictUpdateInfoType); + if (auxBreakPtr != NULL || auxContinuePtr != NULL) { + int savedStackDepth = envPtr->currStackDepth; + int savedExpandCount = envPtr->expandCount; + JumpFixup nonTrapFixup; + + if (auxBreakPtr != NULL) { + auxBreakPtr = envPtr->exceptAuxArrayPtr + breakRange; + } + if (auxContinuePtr != NULL) { + auxContinuePtr = envPtr->exceptAuxArrayPtr + continueRange; + } + + ExceptionRangeEnds(envPtr, loopRange); + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &nonTrapFixup); + + /* + * Careful! When generating these stack unwinding sequences, the depth + * of stack in the cases where they are taken is not the same as if + * the exception is not taken. + */ + + if (auxBreakPtr != NULL) { + TclAdjustStackDepth(-1, envPtr); + + ExceptionRangeTarget(envPtr, loopRange, breakOffset); + TclCleanupStackForBreakContinue(envPtr, auxBreakPtr); + TclAddLoopBreakFixup(envPtr, auxBreakPtr); + TclAdjustStackDepth(1, envPtr); + + envPtr->currStackDepth = savedStackDepth; + envPtr->expandCount = savedExpandCount; + } + + if (auxContinuePtr != NULL) { + TclAdjustStackDepth(-1, envPtr); + + ExceptionRangeTarget(envPtr, loopRange, continueOffset); + TclCleanupStackForBreakContinue(envPtr, auxContinuePtr); + TclAddLoopContinueFixup(envPtr, auxContinuePtr); + TclAdjustStackDepth(1, envPtr); + + envPtr->currStackDepth = savedStackDepth; + envPtr->expandCount = savedExpandCount; + } + + TclFinalizeLoopExceptionRange(envPtr, loopRange); + TclFixupForwardJumpToHere(envPtr, &nonTrapFixup, 127); + } + TclCheckStackDepth(depth+1-cleanup, envPtr); } /* *---------------------------------------------------------------------- * - * TclFinalizeAuxDataTypeTable -- + * TclGetInstructionTable -- * - * This procedure is called by Tcl_Finalize after all exit handlers have - * been run to free up storage associated with the table of AuxData - * types. This procedure is called by TclFinalizeExecution() which is - * called by Tcl_Finalize(). + * Returns a pointer to the table describing Tcl bytecode instructions. + * This procedure is defined so that clients can access the pointer from + * outside the TCL DLLs. * * Results: - * None. + * Returns a pointer to the global instruction table, same as the + * expression (&tclInstructionTable[0]). * * Side effects: - * Deletes all entries in the hash table of AuxData types. + * None. * *---------------------------------------------------------------------- */ -void -TclFinalizeAuxDataTypeTable(void) +const void * /* == InstructionDesc* == */ +TclGetInstructionTable(void) { - Tcl_MutexLock(&tableMutex); - if (auxDataTypeTableInitialized) { - Tcl_DeleteHashTable(&auxDataTypeTable); - auxDataTypeTableInitialized = 0; - } - Tcl_MutexUnlock(&tableMutex); + return &tclInstructionTable[0]; } /* @@ -4279,773 +4462,6 @@ EncodeCmdLocMap( return p; } -#ifdef TCL_COMPILE_DEBUG -/* - *---------------------------------------------------------------------- - * - * TclPrintByteCodeObj -- - * - * This procedure prints ("disassembles") the instructions of a bytecode - * object to stdout. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void -TclPrintByteCodeObj( - Tcl_Interp *interp, /* Used only for Tcl_GetStringFromObj. */ - Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ -{ - Tcl_Obj *bufPtr = TclDisassembleByteCodeObj(objPtr); - - fprintf(stdout, "\n%s", TclGetString(bufPtr)); - Tcl_DecrRefCount(bufPtr); -} - -/* - *---------------------------------------------------------------------- - * - * TclPrintInstruction -- - * - * This procedure prints ("disassembles") one instruction from a bytecode - * object to stdout. - * - * Results: - * Returns the length in bytes of the current instruiction. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclPrintInstruction( - ByteCode *codePtr, /* Bytecode containing the instruction. */ - const unsigned char *pc) /* Points to first byte of instruction. */ -{ - Tcl_Obj *bufferObj; - int numBytes; - - TclNewObj(bufferObj); - numBytes = FormatInstruction(codePtr, pc, bufferObj); - fprintf(stdout, "%s", TclGetString(bufferObj)); - Tcl_DecrRefCount(bufferObj); - return numBytes; -} - -/* - *---------------------------------------------------------------------- - * - * TclPrintObject -- - * - * This procedure prints up to a specified number of characters from the - * argument Tcl object's string representation to a specified file. - * - * Results: - * None. - * - * Side effects: - * Outputs characters to the specified file. - * - *---------------------------------------------------------------------- - */ - -void -TclPrintObject( - FILE *outFile, /* The file to print the source to. */ - Tcl_Obj *objPtr, /* Points to the Tcl object whose string - * representation should be printed. */ - int maxChars) /* Maximum number of chars to print. */ -{ - char *bytes; - int length; - - bytes = Tcl_GetStringFromObj(objPtr, &length); - TclPrintSource(outFile, bytes, TclMin(length, maxChars)); -} - -/* - *---------------------------------------------------------------------- - * - * TclPrintSource -- - * - * This procedure prints up to a specified number of characters from the - * argument string to a specified file. It tries to produce legible - * output by adding backslashes as necessary. - * - * Results: - * None. - * - * Side effects: - * Outputs characters to the specified file. - * - *---------------------------------------------------------------------- - */ - -void -TclPrintSource( - FILE *outFile, /* The file to print the source to. */ - const char *stringPtr, /* The string to print. */ - int maxChars) /* Maximum number of chars to print. */ -{ - Tcl_Obj *bufferObj; - - TclNewObj(bufferObj); - PrintSourceToObj(bufferObj, stringPtr, maxChars); - fprintf(outFile, "%s", TclGetString(bufferObj)); - Tcl_DecrRefCount(bufferObj); -} -#endif /* TCL_COMPILE_DEBUG */ - -/* - *---------------------------------------------------------------------- - * - * TclDisassembleByteCodeObj -- - * - * Given an object which is of bytecode type, return a disassembled - * version of the bytecode (in a new refcount 0 object). No guarantees - * are made about the details of the contents of the result. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclDisassembleByteCodeObj( - Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ -{ - ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; - unsigned char *codeStart, *codeLimit, *pc; - unsigned char *codeDeltaNext, *codeLengthNext; - unsigned char *srcDeltaNext, *srcLengthNext; - int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i; - Interp *iPtr = (Interp *) *codePtr->interpHandle; - Tcl_Obj *bufferObj; - char ptrBuf1[20], ptrBuf2[20]; - - TclNewObj(bufferObj); - if (codePtr->refCount <= 0) { - return bufferObj; /* Already freed. */ - } - - codeStart = codePtr->codeStart; - codeLimit = codeStart + codePtr->numCodeBytes; - numCmds = codePtr->numCommands; - - /* - * Print header lines describing the ByteCode. - */ - - sprintf(ptrBuf1, "%p", codePtr); - sprintf(ptrBuf2, "%p", iPtr); - Tcl_AppendPrintfToObj(bufferObj, - "ByteCode 0x%s, refCt %u, epoch %u, interp 0x%s (epoch %u)\n", - ptrBuf1, codePtr->refCount, codePtr->compileEpoch, ptrBuf2, - iPtr->compileEpoch); - Tcl_AppendToObj(bufferObj, " Source ", -1); - PrintSourceToObj(bufferObj, codePtr->source, - TclMin(codePtr->numSrcBytes, 55)); - Tcl_AppendPrintfToObj(bufferObj, - "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", - numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes, - codePtr->numLitObjects, codePtr->numAuxDataItems, - codePtr->maxStackDepth, -#ifdef TCL_COMPILE_STATS - codePtr->numSrcBytes? - codePtr->structureSize/(float)codePtr->numSrcBytes : -#endif - 0.0); - -#ifdef TCL_COMPILE_STATS - Tcl_AppendPrintfToObj(bufferObj, - " Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n", - (unsigned long) codePtr->structureSize, - (unsigned long) (sizeof(ByteCode) - sizeof(size_t) - sizeof(Tcl_Time)), - codePtr->numCodeBytes, - (unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)), - (unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)), - (unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)), - codePtr->numCmdLocBytes); -#endif /* TCL_COMPILE_STATS */ - - /* - * If the ByteCode is the compiled body of a Tcl procedure, print - * information about that procedure. Note that we don't know the - * procedure's name since ByteCode's can be shared among procedures. - */ - - if (codePtr->procPtr != NULL) { - Proc *procPtr = codePtr->procPtr; - int numCompiledLocals = procPtr->numCompiledLocals; - - sprintf(ptrBuf1, "%p", procPtr); - Tcl_AppendPrintfToObj(bufferObj, - " Proc 0x%s, refCt %d, args %d, compiled locals %d\n", - ptrBuf1, procPtr->refCount, procPtr->numArgs, - numCompiledLocals); - if (numCompiledLocals > 0) { - CompiledLocal *localPtr = procPtr->firstLocalPtr; - - for (i = 0; i < numCompiledLocals; i++) { - Tcl_AppendPrintfToObj(bufferObj, - " slot %d%s%s%s%s%s%s", i, - (localPtr->flags & (VAR_ARRAY|VAR_LINK)) ? "" : ", scalar", - (localPtr->flags & VAR_ARRAY) ? ", array" : "", - (localPtr->flags & VAR_LINK) ? ", link" : "", - (localPtr->flags & VAR_ARGUMENT) ? ", arg" : "", - (localPtr->flags & VAR_TEMPORARY) ? ", temp" : "", - (localPtr->flags & VAR_RESOLVED) ? ", resolved" : ""); - if (TclIsVarTemporary(localPtr)) { - Tcl_AppendToObj(bufferObj, "\n", -1); - } else { - Tcl_AppendPrintfToObj(bufferObj, ", \"%s\"\n", - localPtr->name); - } - localPtr = localPtr->nextPtr; - } - } - } - - /* - * Print the ExceptionRange array. - */ - - if (codePtr->numExceptRanges > 0) { - Tcl_AppendPrintfToObj(bufferObj, " Exception ranges %d, depth %d:\n", - codePtr->numExceptRanges, codePtr->maxExceptDepth); - for (i = 0; i < codePtr->numExceptRanges; i++) { - ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; - - Tcl_AppendPrintfToObj(bufferObj, - " %d: level %d, %s, pc %d-%d, ", - i, rangePtr->nestingLevel, - (rangePtr->type==LOOP_EXCEPTION_RANGE ? "loop" : "catch"), - rangePtr->codeOffset, - (rangePtr->codeOffset + rangePtr->numCodeBytes - 1)); - switch (rangePtr->type) { - case LOOP_EXCEPTION_RANGE: - Tcl_AppendPrintfToObj(bufferObj, "continue %d, break %d\n", - rangePtr->continueOffset, rangePtr->breakOffset); - break; - case CATCH_EXCEPTION_RANGE: - Tcl_AppendPrintfToObj(bufferObj, "catch %d\n", - rangePtr->catchOffset); - break; - default: - Tcl_Panic("TclDisassembleByteCodeObj: bad ExceptionRange type %d", - rangePtr->type); - } - } - } - - /* - * If there were no commands (e.g., an expression or an empty string was - * compiled), just print all instructions and return. - */ - - if (numCmds == 0) { - pc = codeStart; - while (pc < codeLimit) { - Tcl_AppendToObj(bufferObj, " ", -1); - pc += FormatInstruction(codePtr, pc, bufferObj); - } - return bufferObj; - } - - /* - * Print table showing the code offset, source offset, and source length - * for each command. These are encoded as a sequence of bytes. - */ - - Tcl_AppendPrintfToObj(bufferObj, " Commands %d:", numCmds); - codeDeltaNext = codePtr->codeDeltaStart; - codeLengthNext = codePtr->codeLengthStart; - srcDeltaNext = codePtr->srcDeltaStart; - srcLengthNext = codePtr->srcLengthStart; - codeOffset = srcOffset = 0; - for (i = 0; i < numCmds; i++) { - if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) { - codeDeltaNext++; - delta = TclGetInt4AtPtr(codeDeltaNext); - codeDeltaNext += 4; - } else { - delta = TclGetInt1AtPtr(codeDeltaNext); - codeDeltaNext++; - } - codeOffset += delta; - - if ((unsigned) *codeLengthNext == (unsigned) 0xFF) { - codeLengthNext++; - codeLen = TclGetInt4AtPtr(codeLengthNext); - codeLengthNext += 4; - } else { - codeLen = TclGetInt1AtPtr(codeLengthNext); - codeLengthNext++; - } - - if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) { - srcDeltaNext++; - delta = TclGetInt4AtPtr(srcDeltaNext); - srcDeltaNext += 4; - } else { - delta = TclGetInt1AtPtr(srcDeltaNext); - srcDeltaNext++; - } - srcOffset += delta; - - if ((unsigned) *srcLengthNext == (unsigned) 0xFF) { - srcLengthNext++; - srcLen = TclGetInt4AtPtr(srcLengthNext); - srcLengthNext += 4; - } else { - srcLen = TclGetInt1AtPtr(srcLengthNext); - srcLengthNext++; - } - - Tcl_AppendPrintfToObj(bufferObj, "%s%4d: pc %d-%d, src %d-%d", - ((i % 2)? " " : "\n "), - (i+1), codeOffset, (codeOffset + codeLen - 1), - srcOffset, (srcOffset + srcLen - 1)); - } - if (numCmds > 0) { - Tcl_AppendToObj(bufferObj, "\n", -1); - } - - /* - * Print each instruction. If the instruction corresponds to the start of - * a command, print the command's source. Note that we don't need the code - * length here. - */ - - codeDeltaNext = codePtr->codeDeltaStart; - srcDeltaNext = codePtr->srcDeltaStart; - srcLengthNext = codePtr->srcLengthStart; - codeOffset = srcOffset = 0; - pc = codeStart; - for (i = 0; i < numCmds; i++) { - if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) { - codeDeltaNext++; - delta = TclGetInt4AtPtr(codeDeltaNext); - codeDeltaNext += 4; - } else { - delta = TclGetInt1AtPtr(codeDeltaNext); - codeDeltaNext++; - } - codeOffset += delta; - - if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) { - srcDeltaNext++; - delta = TclGetInt4AtPtr(srcDeltaNext); - srcDeltaNext += 4; - } else { - delta = TclGetInt1AtPtr(srcDeltaNext); - srcDeltaNext++; - } - srcOffset += delta; - - if ((unsigned) *srcLengthNext == (unsigned) 0xFF) { - srcLengthNext++; - srcLen = TclGetInt4AtPtr(srcLengthNext); - srcLengthNext += 4; - } else { - srcLen = TclGetInt1AtPtr(srcLengthNext); - srcLengthNext++; - } - - /* - * Print instructions before command i. - */ - - while ((pc-codeStart) < codeOffset) { - Tcl_AppendToObj(bufferObj, " ", -1); - pc += FormatInstruction(codePtr, pc, bufferObj); - } - - Tcl_AppendPrintfToObj(bufferObj, " Command %d: ", i+1); - PrintSourceToObj(bufferObj, (codePtr->source + srcOffset), - TclMin(srcLen, 55)); - Tcl_AppendToObj(bufferObj, "\n", -1); - } - if (pc < codeLimit) { - /* - * Print instructions after the last command. - */ - - while (pc < codeLimit) { - Tcl_AppendToObj(bufferObj, " ", -1); - pc += FormatInstruction(codePtr, pc, bufferObj); - } - } - return bufferObj; -} - -/* - *---------------------------------------------------------------------- - * - * FormatInstruction -- - * - * Appends a representation of a bytecode instruction to a Tcl_Obj. - * - *---------------------------------------------------------------------- - */ - -static int -FormatInstruction( - ByteCode *codePtr, /* Bytecode containing the instruction. */ - const unsigned char *pc, /* Points to first byte of instruction. */ - Tcl_Obj *bufferObj) /* Object to append instruction info to. */ -{ - Proc *procPtr = codePtr->procPtr; - unsigned char opCode = *pc; - register const InstructionDesc *instDesc = &tclInstructionTable[opCode]; - unsigned char *codeStart = codePtr->codeStart; - unsigned pcOffset = pc - codeStart; - int opnd = 0, i, j, numBytes = 1; - int localCt = procPtr ? procPtr->numCompiledLocals : 0; - CompiledLocal *localPtr = procPtr ? procPtr->firstLocalPtr : NULL; - char suffixBuffer[128]; /* Additional info to print after main opcode - * and immediates. */ - char *suffixSrc = NULL; - Tcl_Obj *suffixObj = NULL; - AuxData *auxPtr = NULL; - - suffixBuffer[0] = '\0'; - Tcl_AppendPrintfToObj(bufferObj, "(%u) %s ", pcOffset, instDesc->name); - for (i = 0; i < instDesc->numOperands; i++) { - switch (instDesc->opTypes[i]) { - case OPERAND_INT1: - opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++; - if (opCode == INST_JUMP1 || opCode == INST_JUMP_TRUE1 - || opCode == INST_JUMP_FALSE1) { - sprintf(suffixBuffer, "pc %u", pcOffset+opnd); - } - Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); - break; - case OPERAND_INT4: - opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; - if (opCode == INST_JUMP4 || opCode == INST_JUMP_TRUE4 - || opCode == INST_JUMP_FALSE4) { - sprintf(suffixBuffer, "pc %u", pcOffset+opnd); - } else if (opCode == INST_START_CMD) { - sprintf(suffixBuffer, "next cmd at pc %u", pcOffset+opnd); - } - Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); - break; - case OPERAND_UINT1: - opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; - if (opCode == INST_PUSH1) { - suffixObj = codePtr->objArrayPtr[opnd]; - } - Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); - break; - case OPERAND_AUX4: - case OPERAND_UINT4: - opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; - if (opCode == INST_PUSH4) { - suffixObj = codePtr->objArrayPtr[opnd]; - } else if (opCode == INST_START_CMD && opnd != 1) { - sprintf(suffixBuffer+strlen(suffixBuffer), - ", %u cmds start here", opnd); - } - Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); - if (instDesc->opTypes[i] == OPERAND_AUX4) { - auxPtr = &codePtr->auxDataArrayPtr[opnd]; - } - break; - case OPERAND_IDX4: - opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; - if (opnd >= -1) { - Tcl_AppendPrintfToObj(bufferObj, "%d ", opnd); - } else if (opnd == -2) { - Tcl_AppendPrintfToObj(bufferObj, "end "); - } else { - Tcl_AppendPrintfToObj(bufferObj, "end-%d ", -2-opnd); - } - break; - case OPERAND_LVT1: - opnd = TclGetUInt1AtPtr(pc+numBytes); - numBytes++; - goto printLVTindex; - case OPERAND_LVT4: - opnd = TclGetUInt4AtPtr(pc+numBytes); - numBytes += 4; - printLVTindex: - if (localPtr != NULL) { - if (opnd >= localCt) { - Tcl_Panic("FormatInstruction: bad local var index %u (%u locals)", - (unsigned) opnd, localCt); - } - for (j = 0; j < opnd; j++) { - localPtr = localPtr->nextPtr; - } - if (TclIsVarTemporary(localPtr)) { - sprintf(suffixBuffer, "temp var %u", (unsigned) opnd); - } else { - sprintf(suffixBuffer, "var "); - suffixSrc = localPtr->name; - } - } - Tcl_AppendPrintfToObj(bufferObj, "%%v%u ", (unsigned) opnd); - break; - case OPERAND_NONE: - default: - break; - } - } - if (suffixObj) { - const char *bytes; - int length; - - Tcl_AppendToObj(bufferObj, "\t# ", -1); - bytes = Tcl_GetStringFromObj(codePtr->objArrayPtr[opnd], &length); - PrintSourceToObj(bufferObj, bytes, TclMin(length, 40)); - } else if (suffixBuffer[0]) { - Tcl_AppendPrintfToObj(bufferObj, "\t# %s", suffixBuffer); - if (suffixSrc) { - PrintSourceToObj(bufferObj, suffixSrc, 40); - } - } - Tcl_AppendToObj(bufferObj, "\n", -1); - if (auxPtr && auxPtr->type->printProc) { - Tcl_AppendToObj(bufferObj, "\t\t[", -1); - auxPtr->type->printProc(auxPtr->clientData, bufferObj, codePtr, - pcOffset); - Tcl_AppendToObj(bufferObj, "]\n", -1); - } - return numBytes; -} - -/* - *---------------------------------------------------------------------- - * - * TclGetInnerContext -- - * - * If possible, returns a list capturing the inner context. Otherwise - * return NULL. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclGetInnerContext( - Tcl_Interp *interp, - const unsigned char *pc, - Tcl_Obj **tosPtr) -{ - int objc = 0, off = 0; - Tcl_Obj *result; - Interp *iPtr = (Interp *) interp; - - switch (*pc) { - case INST_STR_LEN: - case INST_LNOT: - case INST_BITNOT: - case INST_UMINUS: - case INST_UPLUS: - case INST_TRY_CVT_TO_NUMERIC: - case INST_EXPAND_STKTOP: - case INST_EXPR_STK: - objc = 1; - break; - - case INST_LIST_IN: - case INST_LIST_NOT_IN: /* Basic list containment operators. */ - case INST_STR_EQ: - case INST_STR_NEQ: /* String (in)equality check */ - case INST_STR_CMP: /* String compare. */ - case INST_STR_INDEX: - case INST_STR_MATCH: - case INST_REGEXP: - case INST_EQ: - case INST_NEQ: - case INST_LT: - case INST_GT: - case INST_LE: - case INST_GE: - case INST_MOD: - case INST_LSHIFT: - case INST_RSHIFT: - case INST_BITOR: - case INST_BITXOR: - case INST_BITAND: - case INST_EXPON: - case INST_ADD: - case INST_SUB: - case INST_DIV: - case INST_MULT: - objc = 2; - break; - - case INST_RETURN_STK: - /* early pop. TODO: dig out opt dict too :/ */ - objc = 1; - break; - - case INST_SYNTAX: - case INST_RETURN_IMM: - objc = 2; - break; - - case INST_INVOKE_STK4: - objc = TclGetUInt4AtPtr(pc+1); - break; - - case INST_INVOKE_STK1: - objc = TclGetUInt1AtPtr(pc+1); - break; - } - - result = iPtr->innerContext; - if (Tcl_IsShared(result)) { - Tcl_DecrRefCount(result); - iPtr->innerContext = result = Tcl_NewListObj(objc + 1, NULL); - Tcl_IncrRefCount(result); - } else { - int len; - - /* - * Reset while keeping the list intrep as much as possible. - */ - - Tcl_ListObjLength(interp, result, &len); - Tcl_ListObjReplace(interp, result, 0, len, 0, NULL); - } - Tcl_ListObjAppendElement(NULL, result, TclNewInstNameObj(*pc)); - - for (; objc>0 ; objc--) { - Tcl_Obj *objPtr; - - objPtr = tosPtr[1 - objc + off]; - if (!objPtr) { - Tcl_Panic("InnerContext: bad tos -- appending null object"); - } - if ((objPtr->refCount<=0) -#ifdef TCL_MEM_DEBUG - || (objPtr->refCount==0x61616161) -#endif - ) { - Tcl_Panic("InnerContext: bad tos -- appending freed object %p", - objPtr); - } - Tcl_ListObjAppendElement(NULL, result, objPtr); - } - - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TclNewInstNameObj -- - * - * Creates a new InstName Tcl_Obj based on the given instruction - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclNewInstNameObj( - unsigned char inst) -{ - Tcl_Obj *objPtr = Tcl_NewObj(); - - objPtr->typePtr = &tclInstNameType; - objPtr->internalRep.longValue = (long) inst; - objPtr->bytes = NULL; - - return objPtr; -} - -/* - *---------------------------------------------------------------------- - * - * UpdateStringOfInstName -- - * - * Update the string representation for an instruction name object. - * - *---------------------------------------------------------------------- - */ - -static void -UpdateStringOfInstName( - Tcl_Obj *objPtr) -{ - int inst = objPtr->internalRep.longValue; - char *s, buf[20]; - int len; - - if ((inst < 0) || (inst > LAST_INST_OPCODE)) { - sprintf(buf, "inst_%d", inst); - s = buf; - } else { - s = (char *) tclInstructionTable[objPtr->internalRep.longValue].name; - } - len = strlen(s); - objPtr->bytes = ckalloc(len + 1); - memcpy(objPtr->bytes, s, len + 1); - objPtr->length = len; -} - -/* - *---------------------------------------------------------------------- - * - * PrintSourceToObj -- - * - * Appends a quoted representation of a string to a Tcl_Obj. - * - *---------------------------------------------------------------------- - */ - -static void -PrintSourceToObj( - Tcl_Obj *appendObj, /* The object to print the source to. */ - const char *stringPtr, /* The string to print. */ - int maxChars) /* Maximum number of chars to print. */ -{ - register const char *p; - register int i = 0; - - if (stringPtr == NULL) { - Tcl_AppendToObj(appendObj, "\"\"", -1); - return; - } - - Tcl_AppendToObj(appendObj, "\"", -1); - p = stringPtr; - for (; (*p != '\0') && (i < maxChars); p++, i++) { - switch (*p) { - case '"': - Tcl_AppendToObj(appendObj, "\\\"", -1); - continue; - case '\f': - Tcl_AppendToObj(appendObj, "\\f", -1); - continue; - case '\n': - Tcl_AppendToObj(appendObj, "\\n", -1); - continue; - case '\r': - Tcl_AppendToObj(appendObj, "\\r", -1); - continue; - case '\t': - Tcl_AppendToObj(appendObj, "\\t", -1); - continue; - case '\v': - Tcl_AppendToObj(appendObj, "\\v", -1); - continue; - default: - Tcl_AppendPrintfToObj(appendObj, "%c", *p); - continue; - } - } - Tcl_AppendToObj(appendObj, "\"", -1); -} - #ifdef TCL_COMPILE_STATS /* *---------------------------------------------------------------------- diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 5660055..8746afc 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -48,6 +48,13 @@ MODULE_SCOPE int tclTraceCompile; MODULE_SCOPE int tclTraceExec; #endif + +/* + * The type of lambda expressions. Note that every lambda will *always* have a + * string representation. + */ + +MODULE_SCOPE const Tcl_ObjType tclLambdaType; /* *------------------------------------------------------------------------ @@ -128,7 +135,7 @@ typedef struct ExceptionAux { int numBreakTargets; /* The number of [break]s that want to be * targeted to the place where this loop * exception will be bound to. */ - int *breakTargets; /* The offsets of the INST_JUMP4 instructions + unsigned int *breakTargets; /* The offsets of the INST_JUMP4 instructions * issued by the [break]s that we must * update. Note that resizing a jump (via * TclFixupForwardJump) can cause the contents @@ -138,7 +145,7 @@ typedef struct ExceptionAux { int numContinueTargets; /* The number of [continue]s that want to be * targeted to the place where this loop * exception will be bound to. */ - int *continueTargets; /* The offsets of the INST_JUMP4 instructions + unsigned int *continueTargets; /* The offsets of the INST_JUMP4 instructions * issued by the [continue]s that we must * update. Note that resizing a jump (via * TclFixupForwardJump) can cause the contents @@ -238,6 +245,16 @@ typedef struct AuxDataType { AuxDataPrintProc *printProc;/* Callback function to invoke when printing * the aux data as part of debugging. NULL * means that the data can't be printed. */ + AuxDataPrintProc *disassembleProc; + /* Callback function to invoke when doing a + * disassembly of the aux data (like the + * printProc, except that the output is + * intended to be script-readable). The + * appendObj argument should be filled in with + * a descriptive dictionary; it will start out + * with "name" mapped to the content of the + * name field. NULL means that the printProc + * should be used instead. */ } AuxDataType; /* @@ -400,7 +417,7 @@ typedef struct ByteCode { * procs are specific to an interpreter so the * code emitted will depend on the * interpreter. */ - int compileEpoch; /* Value of iPtr->compileEpoch when this + unsigned int compileEpoch; /* Value of iPtr->compileEpoch when this * ByteCode was compiled. Used to invalidate * code when, e.g., commands with compile * procs are redefined. */ @@ -408,11 +425,11 @@ typedef struct ByteCode { * compiled. If the code is executed if a * different namespace, it must be * recompiled. */ - int nsEpoch; /* Value of nsPtr->resolverEpoch when this + unsigned int nsEpoch; /* Value of nsPtr->resolverEpoch when this * ByteCode was compiled. Used to invalidate * code when new namespace resolution rules * are put into effect. */ - int refCount; /* Reference count: set 1 when created plus 1 + unsigned int refCount; /* Reference count: set 1 when created plus 1 * for each execution of the code currently * active. This structure can be freed when * refCount becomes zero. */ @@ -512,7 +529,7 @@ typedef struct ByteCode { #define INST_PUSH4 2 #define INST_POP 3 #define INST_DUP 4 -#define INST_CONCAT1 5 +#define INST_STR_CONCAT1 5 #define INST_INVOKE_STK1 6 #define INST_INVOKE_STK4 7 #define INST_EVAL_STK 8 @@ -586,8 +603,8 @@ typedef struct ByteCode { #define INST_CONTINUE 66 /* Opcodes 67 to 68 */ -#define INST_FOREACH_START4 67 -#define INST_FOREACH_STEP4 68 +#define INST_FOREACH_START4 67 /* DEPRECATED */ +#define INST_FOREACH_STEP4 68 /* DEPRECATED */ /* Opcodes 69 to 72 */ #define INST_BEGIN_CATCH4 69 @@ -751,6 +768,8 @@ typedef struct ByteCode { #define INST_INFO_LEVEL_NUM 152 #define INST_INFO_LEVEL_ARGS 153 #define INST_RESOLVE_COMMAND 154 + +/* For compilation relating to TclOO */ #define INST_TCLOO_SELF 155 #define INST_TCLOO_CLASS 156 #define INST_TCLOO_NS 157 @@ -768,8 +787,44 @@ typedef struct ByteCode { #define INST_EXPAND_DROP 165 +/* New foreach implementation */ +#define INST_FOREACH_START 166 +#define INST_FOREACH_STEP 167 +#define INST_FOREACH_END 168 +#define INST_LMAP_COLLECT 169 + +/* For compilation of [string trim] and related */ +#define INST_STR_TRIM 170 +#define INST_STR_TRIM_LEFT 171 +#define INST_STR_TRIM_RIGHT 172 + +#define INST_CONCAT_STK 173 + +#define INST_STR_UPPER 174 +#define INST_STR_LOWER 175 +#define INST_STR_TITLE 176 +#define INST_STR_REPLACE 177 + +#define INST_ORIGIN_COMMAND 178 + +#define INST_TCLOO_NEXT 179 +#define INST_TCLOO_NEXT_CLASS 180 + +#define INST_YIELD_TO_INVOKE 181 + +#define INST_NUM_TYPE 182 +#define INST_TRY_CVT_TO_BOOLEAN 183 +#define INST_STR_CLASS 184 + +#define INST_LAPPEND_LIST 185 +#define INST_LAPPEND_LIST_ARRAY 186 +#define INST_LAPPEND_LIST_ARRAY_STK 187 +#define INST_LAPPEND_LIST_STK 188 + +#define INST_CLOCK_READ 189 + /* The last opcode */ -#define LAST_INST_OPCODE 165 +#define LAST_INST_OPCODE 189 /* * Table describing the Tcl bytecode instructions: their name (for displaying @@ -794,8 +849,15 @@ typedef enum InstOperandType { * variable table. */ OPERAND_LVT4, /* Four byte unsigned index into the local * variable table. */ - OPERAND_AUX4 /* Four byte unsigned index into the aux data + OPERAND_AUX4, /* Four byte unsigned index into the aux data * table. */ + OPERAND_OFFSET1, /* One byte signed jump offset. */ + OPERAND_OFFSET4, /* Four byte signed jump offset. */ + OPERAND_LIT1, /* One byte unsigned index into table of + * literals. */ + OPERAND_LIT4, /* Four byte unsigned index into table of + * literals. */ + OPERAND_SCLS1 /* Index into tclStringClassTable. */ } InstOperandType; typedef struct InstructionDesc { @@ -814,6 +876,40 @@ typedef struct InstructionDesc { MODULE_SCOPE InstructionDesc const tclInstructionTable[]; /* + * Constants used by INST_STRING_CLASS to indicate character classes. These + * correspond closely by name with what [string is] can support, but there is + * no requirement to keep the values the same. + */ + +typedef enum InstStringClassType { + STR_CLASS_ALNUM, /* Unicode alphabet or digit characters. */ + STR_CLASS_ALPHA, /* Unicode alphabet characters. */ + STR_CLASS_ASCII, /* Characters in range U+000000..U+00007F. */ + STR_CLASS_CONTROL, /* Unicode control characters. */ + STR_CLASS_DIGIT, /* Unicode digit characters. */ + STR_CLASS_GRAPH, /* Unicode printing characters, excluding + * space. */ + STR_CLASS_LOWER, /* Unicode lower-case alphabet characters. */ + STR_CLASS_PRINT, /* Unicode printing characters, including + * spaces. */ + STR_CLASS_PUNCT, /* Unicode punctuation characters. */ + STR_CLASS_SPACE, /* Unicode space characters. */ + STR_CLASS_UPPER, /* Unicode upper-case alphabet characters. */ + STR_CLASS_WORD, /* Unicode word (alphabetic, digit, connector + * punctuation) characters. */ + STR_CLASS_XDIGIT /* Characters that can be used as digits in + * hexadecimal numbers ([0-9A-Fa-f]). */ +} InstStringClassType; + +typedef struct StringClassDesc { + const char *name; /* Name of the class. */ + int (*comparator)(int); /* Function to test if a single unicode + * character is a member of the class. */ +} StringClassDesc; + +MODULE_SCOPE StringClassDesc const tclStringClassTable[]; + +/* * Compilation of some Tcl constructs such as if commands and the logical or * (||) and logical and (&&) operators in expressions requires the generation * of forward jumps. Since the PC target of these jumps isn't known when the @@ -834,7 +930,7 @@ typedef enum { typedef struct JumpFixup { TclJumpType jumpType; /* Indicates the kind of jump. */ - int codeOffset; /* Offset of the first byte of the one-byte + unsigned int codeOffset; /* Offset of the first byte of the one-byte * forward jump's code. */ int cmdIndex; /* Index of the first command after the one * for which the jump was emitted. Used to @@ -901,11 +997,6 @@ typedef struct ForeachInfo { * LAST FIELD IN THE STRUCTURE! */ } ForeachInfo; -MODULE_SCOPE const AuxDataType tclForeachInfoType; - -#define FOREACHINFO(envPtr, index) \ - ((ForeachInfo*)((envPtr)->auxDataArrayPtr[TclGetUInt4AtPtr(index)].clientData)) - /* * Structure used to hold information about a switch command that is needed * during program execution. These structures are stored in CompileEnv and @@ -938,11 +1029,6 @@ typedef struct { * STRUCTURE. */ } DictUpdateInfo; -MODULE_SCOPE const AuxDataType tclDictUpdateInfoType; - -#define DICTUPDATEINFO(envPtr, index) \ - ((DictUpdateInfo*)((envPtr)->auxDataArrayPtr[TclGetUInt4AtPtr(index)].clientData)) - /* * ClientData type used by the math operator commands. */ @@ -983,7 +1069,6 @@ MODULE_SCOPE ByteCode * TclCompileObj(Tcl_Interp *interp, Tcl_Obj *objPtr, MODULE_SCOPE int TclAttemptCompileProc(Tcl_Interp *interp, Tcl_Parse *parsePtr, int depth, Command *cmdPtr, CompileEnv *envPtr); -MODULE_SCOPE void TclCleanupByteCode(ByteCode *codePtr); MODULE_SCOPE void TclCleanupStackForBreakContinue(CompileEnv *envPtr, ExceptionAux *auxPtr); MODULE_SCOPE void TclCompileCmdWord(Tcl_Interp *interp, @@ -1012,7 +1097,7 @@ MODULE_SCOPE int TclCreateAuxData(ClientData clientData, MODULE_SCOPE int TclCreateExceptRange(ExceptionRangeType type, CompileEnv *envPtr); MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp, int size); -MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, char *bytes, +MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, const char *bytes, int length, unsigned int hash, int *newPtr, Namespace *nsPtr, int flags, LiteralEntry **globalPtrPtr); @@ -1021,13 +1106,13 @@ MODULE_SCOPE void TclDeleteLiteralTable(Tcl_Interp *interp, LiteralTable *tablePtr); MODULE_SCOPE void TclEmitForwardJump(CompileEnv *envPtr, TclJumpType jumpType, JumpFixup *jumpFixupPtr); +MODULE_SCOPE void TclEmitInvoke(CompileEnv *envPtr, int opcode, ...); MODULE_SCOPE ExceptionRange * TclGetExceptionRangeForPc(unsigned char *pc, int catchOnly, ByteCode *codePtr); MODULE_SCOPE void TclExpandJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE int TclNRExecuteByteCode(Tcl_Interp *interp, ByteCode *codePtr); MODULE_SCOPE Tcl_Obj * TclFetchLiteral(CompileEnv *envPtr, unsigned int index); -MODULE_SCOPE void TclFinalizeAuxDataTypeTable(void); MODULE_SCOPE int TclFindCompiledLocal(const char *name, int nameChars, int create, CompileEnv *envPtr); MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr, @@ -1035,9 +1120,11 @@ MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr, int distThreshold); MODULE_SCOPE void TclFreeCompileEnv(CompileEnv *envPtr); MODULE_SCOPE void TclFreeJumpFixupArray(JumpFixupArray *fixupArrayPtr); -MODULE_SCOPE void TclInitAuxDataTypeTable(void); -MODULE_SCOPE void TclInitByteCodeObj(Tcl_Obj *objPtr, - CompileEnv *envPtr); +MODULE_SCOPE int TclGetIndexFromToken(Tcl_Token *tokenPtr, + int before, int after, int *indexPtr); +MODULE_SCOPE ByteCode * TclInitByteCode(CompileEnv *envPtr); +MODULE_SCOPE ByteCode * TclInitByteCodeObj(Tcl_Obj *objPtr, + const Tcl_ObjType *typePtr, CompileEnv *envPtr); MODULE_SCOPE void TclInitCompileEnv(Tcl_Interp *interp, CompileEnv *envPtr, const char *string, int numBytes, const CmdFrame *invoker, int word); @@ -1055,7 +1142,11 @@ MODULE_SCOPE void TclFinalizeLoopExceptionRange(CompileEnv *envPtr, MODULE_SCOPE char * TclLiteralStats(LiteralTable *tablePtr); MODULE_SCOPE int TclLog2(int value); #endif -MODULE_SCOPE void TclOptimizeBytecode(CompileEnv *envPtr); +MODULE_SCOPE int TclLocalScalar(const char *bytes, int numBytes, + CompileEnv *envPtr); +MODULE_SCOPE int TclLocalScalarFromToken(Tcl_Token *tokenPtr, + CompileEnv *envPtr); +MODULE_SCOPE void TclOptimizeBytecode(void *envPtr); #ifdef TCL_COMPILE_DEBUG MODULE_SCOPE void TclPrintByteCodeObj(Tcl_Interp *interp, Tcl_Obj *objPtr); @@ -1070,10 +1161,10 @@ MODULE_SCOPE void TclPushVarName(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags, int *localIndexPtr, int *isScalarPtr); -MODULE_SCOPE int TclRegisterLiteral(CompileEnv *envPtr, - char *bytes, int length, int flags); +MODULE_SCOPE void TclPreserveByteCode(ByteCode *codePtr); +MODULE_SCOPE void TclReleaseByteCode(ByteCode *codePtr); MODULE_SCOPE void TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr); -MODULE_SCOPE void TclInvalidateCmdLiteral(Tcl_Interp *interp, +MODULE_SCOPE void TclInvalidateCmdLiteral(Tcl_Interp *interp, const char *name, Namespace *nsPtr); MODULE_SCOPE int TclSingleOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, @@ -1094,12 +1185,15 @@ MODULE_SCOPE void TclVerifyLocalLiteralTable(CompileEnv *envPtr); MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr, Tcl_Obj *valuePtr); MODULE_SCOPE void TclLogCommandInfo(Tcl_Interp *interp, - const char *script, - const char *command, int length, - const unsigned char *pc, Tcl_Obj **tosPtr); + const char *script, const char *command, + int length, const unsigned char *pc, + Tcl_Obj **tosPtr); MODULE_SCOPE Tcl_Obj *TclGetInnerContext(Tcl_Interp *interp, - const unsigned char *pc, Tcl_Obj **tosPtr); + const unsigned char *pc, Tcl_Obj **tosPtr); MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); +MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData, + register Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[], int isLambda); /* @@ -1120,29 +1214,7 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); #define LITERAL_ON_HEAP 0x01 #define LITERAL_CMD_NAME 0x02 - -/* - * Form of TclRegisterLiteral with flags == 0. In that case, it is safe to - * cast away constness, and it is cleanest to do that here, all in one place. - * - * int TclRegisterNewLiteral(CompileEnv *envPtr, const char *bytes, - * int length); - */ - -#define TclRegisterNewLiteral(envPtr, bytes, length) \ - TclRegisterLiteral(envPtr, (char *)(bytes), length, /*flags*/ 0) - -/* - * Form of TclRegisterLiteral with flags == LITERAL_CMD_NAME. In that case, it - * is safe to cast away constness, and it is cleanest to do that here, all in - * one place. - * - * int TclRegisterNewNSLiteral(CompileEnv *envPtr, const char *bytes, - * int length); - */ - -#define TclRegisterNewCmdLiteral(envPtr, bytes, length) \ - TclRegisterLiteral(envPtr, (char *)(bytes), length, LITERAL_CMD_NAME) +#define LITERAL_UNSHARED 0x04 /* * Macro used to manually adjust the stack requirements; used in cases where @@ -1162,6 +1234,21 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); (envPtr)->currStackDepth += (delta); \ } while (0) +#define TclGetStackDepth(envPtr) \ + ((envPtr)->currStackDepth) + +#define TclSetStackDepth(depth, envPtr) \ + (envPtr)->currStackDepth = (depth) + +#define TclCheckStackDepth(depth, envPtr) \ + do { \ + int _dd = (depth); \ + if (_dd != (envPtr)->currStackDepth) { \ + Tcl_Panic("bad stack depth computations: is %i, should be %i", \ + (envPtr)->currStackDepth, _dd); \ + } \ + } while (0) + /* * Macro used to update the stack requirements. It is called by the macros * TclEmitOpCode, TclEmitInst1 and TclEmitInst4. @@ -1174,12 +1261,12 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); #define TclUpdateStackReqs(op, i, envPtr) \ do { \ - int delta = tclInstructionTable[(op)].stackEffect; \ - if (delta) { \ - if (delta == INT_MIN) { \ - delta = 1 - (i); \ + int _delta = tclInstructionTable[(op)].stackEffect; \ + if (_delta) { \ + if (_delta == INT_MIN) { \ + _delta = 1 - (i); \ } \ - TclAdjustStackDepth(delta, envPtr); \ + TclAdjustStackDepth(_delta, envPtr); \ } \ } while (0) @@ -1293,11 +1380,11 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); #define TclEmitPush(objIndex, envPtr) \ do { \ - register int objIndexCopy = (objIndex); \ - if (objIndexCopy <= 255) { \ - TclEmitInstInt1(INST_PUSH1, objIndexCopy, (envPtr)); \ + register int _objIndexCopy = (objIndex); \ + if (_objIndexCopy <= 255) { \ + TclEmitInstInt1(INST_PUSH1, _objIndexCopy, (envPtr)); \ } else { \ - TclEmitInstInt4(INST_PUSH4, objIndexCopy, (envPtr)); \ + TclEmitInstInt4(INST_PUSH4, _objIndexCopy, (envPtr)); \ } \ } while (0) @@ -1444,9 +1531,9 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); */ #define PushLiteral(envPtr, string, length) \ - TclEmitPush(TclRegisterNewLiteral((envPtr), (string), (length)), (envPtr)) + TclEmitPush(TclRegisterLiteral(envPtr, string, length, 0), (envPtr)) #define PushStringLiteral(envPtr, string) \ - PushLiteral((envPtr), (string), (int) (sizeof(string "") - 1)) + PushLiteral(envPtr, string, (int) (sizeof(string "") - 1)) /* * Macro to advance to the next token; it is more mnemonic than the address @@ -1544,7 +1631,7 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); #define PushVarNameWord(i,v,e,f,l,sc,word) \ SetLineInformation(word); \ - TclPushVarName(i,v,e,f,l,sc) + TclPushVarName(i,v,e,f,l,sc) /* * Often want to issue one of two versions of an instruction based on whether @@ -1566,11 +1653,9 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); #define AnonymousLocal(envPtr) \ (TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1, (envPtr))) #define LocalScalar(chars,len,envPtr) \ - (!TclIsLocalScalar((chars), (len)) ? -1 : \ - TclFindCompiledLocal((chars), (len), /*create*/ 1, (envPtr))) + TclLocalScalar(chars, len, envPtr) #define LocalScalarFromToken(tokenPtr,envPtr) \ - ((tokenPtr)->type != TCL_TOKEN_SIMPLE_WORD ? -1 : \ - LocalScalar((tokenPtr)[1].start, (tokenPtr)[1].size, (envPtr))) + TclLocalScalarFromToken(tokenPtr, envPtr) /* * Flags bits used by TclPushVarName. diff --git a/generic/tclConfig.c b/generic/tclConfig.c index 2fb3e92..eb6807c 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -232,7 +232,7 @@ QueryConfigObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj("package not known", -1)); Tcl_SetErrorCode(interp, "TCL", "FATAL", "PKGCFG_BASE", - Tcl_GetString(pkgName), NULL); + TclGetString(pkgName), NULL); return TCL_ERROR; } @@ -247,7 +247,7 @@ QueryConfigObjCmd( || val == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("key not known", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONFIG", - Tcl_GetString(objv[2]), NULL); + TclGetString(objv[2]), NULL); return TCL_ERROR; } @@ -333,9 +333,9 @@ QueryConfigDelete( Tcl_DictObjRemove(NULL, pDB, pkgName); Tcl_DecrRefCount(pkgName); if (cdPtr->encoding) { - ckfree((char *)cdPtr->encoding); + ckfree(cdPtr->encoding); } - ckfree((char *)cdPtr); + ckfree(cdPtr); } /* diff --git a/generic/tclDate.c b/generic/tclDate.c index 6222a8a..717a1b3 100644 --- a/generic/tclDate.c +++ b/generic/tclDate.c @@ -359,14 +359,8 @@ typedef short int yytype_int16; #ifndef YYSIZE_T # ifdef __SIZE_TYPE__ # define YYSIZE_T __SIZE_TYPE__ -# elif defined size_t -# define YYSIZE_T size_t -# elif ! defined YYSIZE_T && (defined __STDC__ || defined __C99__FUNC__ \ - || defined __cplusplus || defined _MSC_VER) -# include <stddef.h> /* INFRINGES ON USER NAME SPACE */ -# define YYSIZE_T size_t # else -# define YYSIZE_T unsigned int +# define YYSIZE_T size_t # endif #endif @@ -1354,7 +1348,7 @@ yyparse (info) int yychar; /* The semantic value of the look-ahead symbol. */ -YYSTYPE yylval; +YYSTYPE yylval = {0}; /* Number of syntax errors so far. */ int yynerrs; diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 4d40be1..7732ae6 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -23,6 +23,15 @@ # endif #endif +#if !defined(BUILD_tcl) +# define TCL_DEPRECATED(msg) EXTERN TCL_DEPRECATED_API(msg) +#elif defined(TCL_NO_DEPRECATED) +# define TCL_DEPRECATED(msg) MODULE_SCOPE +#else +# define TCL_DEPRECATED(msg) EXTERN +#endif + + /* * WARNING: This file is automatically generated by the tools/genStubs.tcl * script. Any modifications to the function declarations below should be made @@ -31,6 +40,10 @@ /* !BEGIN!: Do not edit below this line. */ +#ifdef __cplusplus +extern "C" { +#endif + /* * Exported function declarations: */ @@ -40,11 +53,11 @@ EXTERN int Tcl_PkgProvideEx(Tcl_Interp *interp, const char *name, const char *version, const void *clientData); /* 1 */ -EXTERN CONST84_RETURN char * Tcl_PkgRequireEx(Tcl_Interp *interp, +EXTERN const char * Tcl_PkgRequireEx(Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 2 */ -EXTERN void Tcl_Panic(const char *format, ...) TCL_FORMAT_PRINTF(1, 2); +EXTERN TCL_NORETURN void Tcl_Panic(const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 3 */ EXTERN char * Tcl_Alloc(unsigned int size); /* 4 */ @@ -59,7 +72,7 @@ EXTERN void Tcl_DbCkfree(char *ptr, const char *file, int line); /* 8 */ EXTERN char * Tcl_DbCkrealloc(char *ptr, unsigned int size, const char *file, int line); -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ /* 9 */ EXTERN void Tcl_CreateFileHandler(int fd, int mask, Tcl_FileProc *proc, ClientData clientData); @@ -69,7 +82,7 @@ EXTERN void Tcl_CreateFileHandler(int fd, int mask, EXTERN void Tcl_CreateFileHandler(int fd, int mask, Tcl_FileProc *proc, ClientData clientData); #endif /* MACOSX */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ /* 10 */ EXTERN void Tcl_DeleteFileHandler(int fd); #endif /* UNIX */ @@ -106,7 +119,8 @@ EXTERN void Tcl_DbIncrRefCount(Tcl_Obj *objPtr, const char *file, EXTERN int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file, int line); /* 22 */ -EXTERN Tcl_Obj * Tcl_DbNewBooleanObj(int boolValue, const char *file, +TCL_DEPRECATED("No longer in use, changed to macro") +Tcl_Obj * Tcl_DbNewBooleanObj(int boolValue, const char *file, int line); /* 23 */ EXTERN Tcl_Obj * Tcl_DbNewByteArrayObj(const unsigned char *bytes, @@ -118,7 +132,8 @@ EXTERN Tcl_Obj * Tcl_DbNewDoubleObj(double doubleValue, EXTERN Tcl_Obj * Tcl_DbNewListObj(int objc, Tcl_Obj *const *objv, const char *file, int line); /* 26 */ -EXTERN Tcl_Obj * Tcl_DbNewLongObj(long longValue, const char *file, +TCL_DEPRECATED("No longer in use, changed to macro") +Tcl_Obj * Tcl_DbNewLongObj(long longValue, const char *file, int line); /* 27 */ EXTERN Tcl_Obj * Tcl_DbNewObj(const char *file, int line); @@ -145,9 +160,9 @@ EXTERN int Tcl_GetDouble(Tcl_Interp *interp, const char *src, EXTERN int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); /* 36 */ -EXTERN int Tcl_GetIndexFromObj(Tcl_Interp *interp, - Tcl_Obj *objPtr, - CONST84 char *const *tablePtr, +TCL_DEPRECATED("No longer in use, changed to macro") +int Tcl_GetIndexFromObj(Tcl_Interp *interp, + Tcl_Obj *objPtr, const char *const *tablePtr, const char *msg, int flags, int *indexPtr); /* 37 */ EXTERN int Tcl_GetInt(Tcl_Interp *interp, const char *src, @@ -186,24 +201,28 @@ EXTERN int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *const objv[]); /* 49 */ -EXTERN Tcl_Obj * Tcl_NewBooleanObj(int boolValue); +TCL_DEPRECATED("No longer in use, changed to macro") +Tcl_Obj * Tcl_NewBooleanObj(int boolValue); /* 50 */ EXTERN Tcl_Obj * Tcl_NewByteArrayObj(const unsigned char *bytes, int length); /* 51 */ EXTERN Tcl_Obj * Tcl_NewDoubleObj(double doubleValue); /* 52 */ -EXTERN Tcl_Obj * Tcl_NewIntObj(int intValue); +TCL_DEPRECATED("No longer in use, changed to macro") +Tcl_Obj * Tcl_NewIntObj(int intValue); /* 53 */ EXTERN Tcl_Obj * Tcl_NewListObj(int objc, Tcl_Obj *const objv[]); /* 54 */ -EXTERN Tcl_Obj * Tcl_NewLongObj(long longValue); +TCL_DEPRECATED("No longer in use, changed to macro") +Tcl_Obj * Tcl_NewLongObj(long longValue); /* 55 */ EXTERN Tcl_Obj * Tcl_NewObj(void); /* 56 */ EXTERN Tcl_Obj * Tcl_NewStringObj(const char *bytes, int length); /* 57 */ -EXTERN void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue); +TCL_DEPRECATED("No longer in use, changed to macro") +void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue); /* 58 */ EXTERN unsigned char * Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int length); /* 59 */ @@ -212,22 +231,26 @@ EXTERN void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, /* 60 */ EXTERN void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue); /* 61 */ -EXTERN void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue); +TCL_DEPRECATED("No longer in use, changed to macro") +void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue); /* 62 */ EXTERN void Tcl_SetListObj(Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[]); /* 63 */ -EXTERN void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue); +TCL_DEPRECATED("No longer in use, changed to macro") +void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue); /* 64 */ EXTERN void Tcl_SetObjLength(Tcl_Obj *objPtr, int length); /* 65 */ EXTERN void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, int length); /* 66 */ -EXTERN void Tcl_AddErrorInfo(Tcl_Interp *interp, +TCL_DEPRECATED("No longer in use, changed to macro") +void Tcl_AddErrorInfo(Tcl_Interp *interp, const char *message); /* 67 */ -EXTERN void Tcl_AddObjErrorInfo(Tcl_Interp *interp, +TCL_DEPRECATED("No longer in use, changed to macro") +void Tcl_AddObjErrorInfo(Tcl_Interp *interp, const char *message, int length); /* 68 */ EXTERN void Tcl_AllowExceptions(Tcl_Interp *interp); @@ -250,7 +273,8 @@ EXTERN int Tcl_AsyncReady(void); /* 76 */ EXTERN void Tcl_BackgroundError(Tcl_Interp *interp); /* 77 */ -EXTERN char Tcl_Backslash(const char *src, int *readPtr); +TCL_DEPRECATED("Use Tcl_UtfBackslash") +char Tcl_Backslash(const char *src, int *readPtr); /* 78 */ EXTERN int Tcl_BadChannelOption(Tcl_Interp *interp, const char *optionName, @@ -267,7 +291,7 @@ EXTERN int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan); /* 82 */ EXTERN int Tcl_CommandComplete(const char *cmd); /* 83 */ -EXTERN char * Tcl_Concat(int argc, CONST84 char *const *argv); +EXTERN char * Tcl_Concat(int argc, const char *const *argv); /* 84 */ EXTERN int Tcl_ConvertElement(const char *src, char *dst, int flags); @@ -278,7 +302,7 @@ EXTERN int Tcl_ConvertCountedElement(const char *src, EXTERN int Tcl_CreateAlias(Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int argc, - CONST84 char *const *argv); + const char *const *argv); /* 87 */ EXTERN int Tcl_CreateAliasObj(Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, @@ -309,7 +333,8 @@ EXTERN void Tcl_CreateExitHandler(Tcl_ExitProc *proc, /* 94 */ EXTERN Tcl_Interp * Tcl_CreateInterp(void); /* 95 */ -EXTERN void Tcl_CreateMathFunc(Tcl_Interp *interp, +TCL_DEPRECATED("") +void Tcl_CreateMathFunc(Tcl_Interp *interp, const char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, ClientData clientData); @@ -399,21 +424,22 @@ EXTERN void Tcl_DStringStartSublist(Tcl_DString *dsPtr); /* 126 */ EXTERN int Tcl_Eof(Tcl_Channel chan); /* 127 */ -EXTERN CONST84_RETURN char * Tcl_ErrnoId(void); +EXTERN const char * Tcl_ErrnoId(void); /* 128 */ -EXTERN CONST84_RETURN char * Tcl_ErrnoMsg(int err); +EXTERN const char * Tcl_ErrnoMsg(int err); /* 129 */ EXTERN int Tcl_Eval(Tcl_Interp *interp, const char *script); /* 130 */ EXTERN int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName); /* 131 */ -EXTERN int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr); +TCL_DEPRECATED("No longer in use, changed to macro") +int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 132 */ EXTERN void Tcl_EventuallyFree(ClientData clientData, Tcl_FreeProc *freeProc); /* 133 */ -EXTERN void Tcl_Exit(int status); +EXTERN TCL_NORETURN void Tcl_Exit(int status); /* 134 */ EXTERN int Tcl_ExposeCommand(Tcl_Interp *interp, const char *hiddenCmdToken, @@ -456,13 +482,13 @@ EXTERN void Tcl_FreeResult(Tcl_Interp *interp); EXTERN int Tcl_GetAlias(Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, - CONST84 char **targetCmdPtr, int *argcPtr, - CONST84 char ***argvPtr); + const char **targetCmdPtr, int *argcPtr, + const char ***argvPtr); /* 149 */ EXTERN int Tcl_GetAliasObj(Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, - CONST84 char **targetCmdPtr, int *objcPtr, + const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 150 */ EXTERN ClientData Tcl_GetAssocData(Tcl_Interp *interp, @@ -481,7 +507,7 @@ EXTERN ClientData Tcl_GetChannelInstanceData(Tcl_Channel chan); /* 155 */ EXTERN int Tcl_GetChannelMode(Tcl_Channel chan); /* 156 */ -EXTERN CONST84_RETURN char * Tcl_GetChannelName(Tcl_Channel chan); +EXTERN const char * Tcl_GetChannelName(Tcl_Channel chan); /* 157 */ EXTERN int Tcl_GetChannelOption(Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, @@ -492,12 +518,12 @@ EXTERN CONST86 Tcl_ChannelType * Tcl_GetChannelType(Tcl_Channel chan); EXTERN int Tcl_GetCommandInfo(Tcl_Interp *interp, const char *cmdName, Tcl_CmdInfo *infoPtr); /* 160 */ -EXTERN CONST84_RETURN char * Tcl_GetCommandName(Tcl_Interp *interp, +EXTERN const char * Tcl_GetCommandName(Tcl_Interp *interp, Tcl_Command command); /* 161 */ EXTERN int Tcl_GetErrno(void); /* 162 */ -EXTERN CONST84_RETURN char * Tcl_GetHostName(void); +EXTERN const char * Tcl_GetHostName(void); /* 163 */ EXTERN int Tcl_GetInterpPath(Tcl_Interp *askInterp, Tcl_Interp *slaveInterp); @@ -507,7 +533,7 @@ EXTERN Tcl_Interp * Tcl_GetMaster(Tcl_Interp *interp); EXTERN const char * Tcl_GetNameOfExecutable(void); /* 166 */ EXTERN Tcl_Obj * Tcl_GetObjResult(Tcl_Interp *interp); -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ /* 167 */ EXTERN int Tcl_GetOpenFile(Tcl_Interp *interp, const char *chanID, int forWriting, @@ -533,19 +559,20 @@ EXTERN Tcl_Interp * Tcl_GetSlave(Tcl_Interp *interp, /* 173 */ EXTERN Tcl_Channel Tcl_GetStdChannel(int type); /* 174 */ -EXTERN CONST84_RETURN char * Tcl_GetStringResult(Tcl_Interp *interp); +EXTERN const char * Tcl_GetStringResult(Tcl_Interp *interp); /* 175 */ -EXTERN CONST84_RETURN char * Tcl_GetVar(Tcl_Interp *interp, - const char *varName, int flags); -/* 176 */ -EXTERN CONST84_RETURN char * Tcl_GetVar2(Tcl_Interp *interp, - const char *part1, const char *part2, +TCL_DEPRECATED("No longer in use, changed to macro") +const char * Tcl_GetVar(Tcl_Interp *interp, const char *varName, int flags); +/* 176 */ +EXTERN const char * Tcl_GetVar2(Tcl_Interp *interp, const char *part1, + const char *part2, int flags); /* 177 */ EXTERN int Tcl_GlobalEval(Tcl_Interp *interp, const char *command); /* 178 */ -EXTERN int Tcl_GlobalEvalObj(Tcl_Interp *interp, +TCL_DEPRECATED("No longer in use, changed to macro") +int Tcl_GlobalEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 179 */ EXTERN int Tcl_HideCommand(Tcl_Interp *interp, @@ -565,7 +592,7 @@ EXTERN int Tcl_InterpDeleted(Tcl_Interp *interp); /* 185 */ EXTERN int Tcl_IsSafe(Tcl_Interp *interp); /* 186 */ -EXTERN char * Tcl_JoinPath(int argc, CONST84 char *const *argv, +EXTERN char * Tcl_JoinPath(int argc, const char *const *argv, Tcl_DString *resultPtr); /* 187 */ EXTERN int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, @@ -578,7 +605,7 @@ EXTERN int Tcl_MakeSafe(Tcl_Interp *interp); /* 191 */ EXTERN Tcl_Channel Tcl_MakeTcpClientChannel(ClientData tcpSocket); /* 192 */ -EXTERN char * Tcl_Merge(int argc, CONST84 char *const *argv); +EXTERN char * Tcl_Merge(int argc, const char *const *argv); /* 193 */ EXTERN Tcl_HashEntry * Tcl_NextHashEntry(Tcl_HashSearch *searchPtr); /* 194 */ @@ -592,7 +619,7 @@ EXTERN Tcl_Obj * Tcl_ObjSetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, int flags); /* 197 */ EXTERN Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, int argc, - CONST84 char **argv, int flags); + const char **argv, int flags); /* 198 */ EXTERN Tcl_Channel Tcl_OpenFileChannel(Tcl_Interp *interp, const char *fileName, const char *modeString, @@ -614,7 +641,7 @@ EXTERN void Tcl_PrintDouble(Tcl_Interp *interp, double value, /* 203 */ EXTERN int Tcl_PutEnv(const char *assignment); /* 204 */ -EXTERN CONST84_RETURN char * Tcl_PosixError(Tcl_Interp *interp); +EXTERN const char * Tcl_PosixError(Tcl_Interp *interp); /* 205 */ EXTERN void Tcl_QueueEvent(Tcl_Event *evPtr, Tcl_QueuePosition position); @@ -644,8 +671,7 @@ EXTERN int Tcl_RegExpMatch(Tcl_Interp *interp, const char *text, const char *pattern); /* 215 */ EXTERN void Tcl_RegExpRange(Tcl_RegExp regexp, int index, - CONST84 char **startPtr, - CONST84 char **endPtr); + const char **startPtr, const char **endPtr); /* 216 */ EXTERN void Tcl_Release(ClientData clientData); /* 217 */ @@ -656,7 +682,8 @@ EXTERN int Tcl_ScanElement(const char *src, int *flagPtr); EXTERN int Tcl_ScanCountedElement(const char *src, int length, int *flagPtr); /* 220 */ -EXTERN int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode); +TCL_DEPRECATED("") +int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode); /* 221 */ EXTERN int Tcl_ServiceAll(void); /* 222 */ @@ -682,7 +709,8 @@ EXTERN void Tcl_SetErrorCode(Tcl_Interp *interp, ...); /* 229 */ EXTERN void Tcl_SetMaxBlockTime(const Tcl_Time *timePtr); /* 230 */ -EXTERN void Tcl_SetPanicProc(Tcl_PanicProc *panicProc); +EXTERN void Tcl_SetPanicProc( + TCL_NORETURN1 Tcl_PanicProc *panicProc); /* 231 */ EXTERN int Tcl_SetRecursionLimit(Tcl_Interp *interp, int depth); /* 232 */ @@ -699,26 +727,26 @@ EXTERN void Tcl_SetObjResult(Tcl_Interp *interp, /* 236 */ EXTERN void Tcl_SetStdChannel(Tcl_Channel channel, int type); /* 237 */ -EXTERN CONST84_RETURN char * Tcl_SetVar(Tcl_Interp *interp, - const char *varName, const char *newValue, - int flags); -/* 238 */ -EXTERN CONST84_RETURN char * Tcl_SetVar2(Tcl_Interp *interp, - const char *part1, const char *part2, +TCL_DEPRECATED("No longer in use, changed to macro") +const char * Tcl_SetVar(Tcl_Interp *interp, const char *varName, const char *newValue, int flags); +/* 238 */ +EXTERN const char * Tcl_SetVar2(Tcl_Interp *interp, const char *part1, + const char *part2, const char *newValue, + int flags); /* 239 */ -EXTERN CONST84_RETURN char * Tcl_SignalId(int sig); +EXTERN const char * Tcl_SignalId(int sig); /* 240 */ -EXTERN CONST84_RETURN char * Tcl_SignalMsg(int sig); +EXTERN const char * Tcl_SignalMsg(int sig); /* 241 */ EXTERN void Tcl_SourceRCFile(Tcl_Interp *interp); /* 242 */ EXTERN int Tcl_SplitList(Tcl_Interp *interp, const char *listStr, int *argcPtr, - CONST84 char ***argvPtr); + const char ***argvPtr); /* 243 */ EXTERN void Tcl_SplitPath(const char *path, int *argcPtr, - CONST84 char ***argvPtr); + const char ***argvPtr); /* 244 */ EXTERN void Tcl_StaticPackage(Tcl_Interp *interp, const char *pkgName, @@ -727,9 +755,11 @@ EXTERN void Tcl_StaticPackage(Tcl_Interp *interp, /* 245 */ EXTERN int Tcl_StringMatch(const char *str, const char *pattern); /* 246 */ -EXTERN int Tcl_TellOld(Tcl_Channel chan); +TCL_DEPRECATED("") +int Tcl_TellOld(Tcl_Channel chan); /* 247 */ -EXTERN int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, +TCL_DEPRECATED("No longer in use, changed to macro") +int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 248 */ @@ -750,13 +780,15 @@ EXTERN void Tcl_UnlinkVar(Tcl_Interp *interp, EXTERN int Tcl_UnregisterChannel(Tcl_Interp *interp, Tcl_Channel chan); /* 253 */ -EXTERN int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName, +TCL_DEPRECATED("No longer in use, changed to macro") +int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName, int flags); /* 254 */ EXTERN int Tcl_UnsetVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 255 */ -EXTERN void Tcl_UntraceVar(Tcl_Interp *interp, +TCL_DEPRECATED("No longer in use, changed to macro") +void Tcl_UntraceVar(Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); @@ -769,7 +801,8 @@ EXTERN void Tcl_UntraceVar2(Tcl_Interp *interp, EXTERN void Tcl_UpdateLinkedVar(Tcl_Interp *interp, const char *varName); /* 258 */ -EXTERN int Tcl_UpVar(Tcl_Interp *interp, const char *frameName, +TCL_DEPRECATED("No longer in use, changed to macro") +int Tcl_UpVar(Tcl_Interp *interp, const char *frameName, const char *varName, const char *localName, int flags); /* 259 */ @@ -779,7 +812,8 @@ EXTERN int Tcl_UpVar2(Tcl_Interp *interp, const char *frameName, /* 260 */ EXTERN int Tcl_VarEval(Tcl_Interp *interp, ...); /* 261 */ -EXTERN ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, +TCL_DEPRECATED("No longer in use, changed to macro") +ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); @@ -798,40 +832,46 @@ EXTERN int Tcl_DumpActiveMemory(const char *fileName); /* 266 */ EXTERN void Tcl_ValidateAllMemory(const char *file, int line); /* 267 */ -EXTERN void Tcl_AppendResultVA(Tcl_Interp *interp, +TCL_DEPRECATED("see TIP #422") +void Tcl_AppendResultVA(Tcl_Interp *interp, va_list argList); /* 268 */ -EXTERN void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, +TCL_DEPRECATED("see TIP #422") +void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, va_list argList); /* 269 */ EXTERN char * Tcl_HashStats(Tcl_HashTable *tablePtr); /* 270 */ -EXTERN CONST84_RETURN char * Tcl_ParseVar(Tcl_Interp *interp, - const char *start, CONST84 char **termPtr); +EXTERN const char * Tcl_ParseVar(Tcl_Interp *interp, const char *start, + const char **termPtr); /* 271 */ -EXTERN CONST84_RETURN char * Tcl_PkgPresent(Tcl_Interp *interp, - const char *name, const char *version, - int exact); +TCL_DEPRECATED("No longer in use, changed to macro") +const char * Tcl_PkgPresent(Tcl_Interp *interp, const char *name, + const char *version, int exact); /* 272 */ -EXTERN CONST84_RETURN char * Tcl_PkgPresentEx(Tcl_Interp *interp, +EXTERN const char * Tcl_PkgPresentEx(Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 273 */ -EXTERN int Tcl_PkgProvide(Tcl_Interp *interp, const char *name, +TCL_DEPRECATED("No longer in use, changed to macro") +int Tcl_PkgProvide(Tcl_Interp *interp, const char *name, const char *version); /* 274 */ -EXTERN CONST84_RETURN char * Tcl_PkgRequire(Tcl_Interp *interp, - const char *name, const char *version, - int exact); +TCL_DEPRECATED("No longer in use, changed to macro") +const char * Tcl_PkgRequire(Tcl_Interp *interp, const char *name, + const char *version, int exact); /* 275 */ -EXTERN void Tcl_SetErrorCodeVA(Tcl_Interp *interp, +TCL_DEPRECATED("see TIP #422") +void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList); /* 276 */ -EXTERN int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList); +TCL_DEPRECATED("see TIP #422") +int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList); /* 277 */ EXTERN Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options); /* 278 */ -EXTERN void Tcl_PanicVA(const char *format, va_list argList); +TCL_DEPRECATED("see TIP #422") +TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList); /* 279 */ EXTERN void Tcl_GetVersion(int *major, int *minor, int *patchLevel, int *type); @@ -873,7 +913,7 @@ EXTERN int Tcl_EvalObjv(Tcl_Interp *interp, int objc, EXTERN int Tcl_EvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 294 */ -EXTERN void Tcl_ExitThread(int status); +EXTERN TCL_NORETURN void Tcl_ExitThread(int status); /* 295 */ EXTERN int Tcl_ExternalToUtf(Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, @@ -896,7 +936,7 @@ EXTERN Tcl_ThreadId Tcl_GetCurrentThread(void); /* 301 */ EXTERN Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, const char *name); /* 302 */ -EXTERN CONST84_RETURN char * Tcl_GetEncodingName(Tcl_Encoding encoding); +EXTERN const char * Tcl_GetEncodingName(Tcl_Encoding encoding); /* 303 */ EXTERN void Tcl_GetEncodingNames(Tcl_Interp *interp); /* 304 */ @@ -945,30 +985,30 @@ EXTERN void Tcl_ThreadAlert(Tcl_ThreadId threadId); EXTERN void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, Tcl_Event *evPtr, Tcl_QueuePosition position); /* 320 */ -EXTERN Tcl_UniChar Tcl_UniCharAtIndex(const char *src, int index); +EXTERN int Tcl_UniCharAtIndex(const char *src, int index); /* 321 */ -EXTERN Tcl_UniChar Tcl_UniCharToLower(int ch); +EXTERN int Tcl_UniCharToLower(int ch); /* 322 */ -EXTERN Tcl_UniChar Tcl_UniCharToTitle(int ch); +EXTERN int Tcl_UniCharToTitle(int ch); /* 323 */ -EXTERN Tcl_UniChar Tcl_UniCharToUpper(int ch); +EXTERN int Tcl_UniCharToUpper(int ch); /* 324 */ EXTERN int Tcl_UniCharToUtf(int ch, char *buf); /* 325 */ -EXTERN CONST84_RETURN char * Tcl_UtfAtIndex(const char *src, int index); +EXTERN const char * Tcl_UtfAtIndex(const char *src, int index); /* 326 */ EXTERN int Tcl_UtfCharComplete(const char *src, int length); /* 327 */ EXTERN int Tcl_UtfBackslash(const char *src, int *readPtr, char *dst); /* 328 */ -EXTERN CONST84_RETURN char * Tcl_UtfFindFirst(const char *src, int ch); +EXTERN const char * Tcl_UtfFindFirst(const char *src, int ch); /* 329 */ -EXTERN CONST84_RETURN char * Tcl_UtfFindLast(const char *src, int ch); +EXTERN const char * Tcl_UtfFindLast(const char *src, int ch); /* 330 */ -EXTERN CONST84_RETURN char * Tcl_UtfNext(const char *src); +EXTERN const char * Tcl_UtfNext(const char *src); /* 331 */ -EXTERN CONST84_RETURN char * Tcl_UtfPrev(const char *src, const char *start); +EXTERN const char * Tcl_UtfPrev(const char *src, const char *start); /* 332 */ EXTERN int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, @@ -996,9 +1036,11 @@ EXTERN int Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr); /* 340 */ EXTERN char * Tcl_GetString(Tcl_Obj *objPtr); /* 341 */ -EXTERN CONST84_RETURN char * Tcl_GetDefaultEncodingDir(void); +TCL_DEPRECATED("Use Tcl_GetEncodingSearchPath") +const char * Tcl_GetDefaultEncodingDir(void); /* 342 */ -EXTERN void Tcl_SetDefaultEncodingDir(const char *path); +TCL_DEPRECATED("Use Tcl_SetEncodingSearchPath") +void Tcl_SetDefaultEncodingDir(const char *path); /* 343 */ EXTERN void Tcl_AlertNotifier(ClientData clientData); /* 344 */ @@ -1033,7 +1075,8 @@ EXTERN Tcl_UniChar * Tcl_UtfToUniCharDString(const char *src, int length, EXTERN Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, int flags); /* 357 */ -EXTERN Tcl_Obj * Tcl_EvalTokens(Tcl_Interp *interp, +TCL_DEPRECATED("Use Tcl_EvalTokensStandard") +Tcl_Obj * Tcl_EvalTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count); /* 358 */ EXTERN void Tcl_FreeParse(Tcl_Parse *parsePtr); @@ -1045,7 +1088,7 @@ EXTERN void Tcl_LogCommandInfo(Tcl_Interp *interp, EXTERN int Tcl_ParseBraces(Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, - CONST84 char **termPtr); + const char **termPtr); /* 361 */ EXTERN int Tcl_ParseCommand(Tcl_Interp *interp, const char *start, int numBytes, int nested, @@ -1057,7 +1100,7 @@ EXTERN int Tcl_ParseExpr(Tcl_Interp *interp, const char *start, EXTERN int Tcl_ParseQuotedString(Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, - CONST84 char **termPtr); + const char **termPtr); /* 364 */ EXTERN int Tcl_ParseVarName(Tcl_Interp *interp, const char *start, int numBytes, @@ -1103,9 +1146,10 @@ EXTERN void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, /* 380 */ EXTERN int Tcl_GetCharLength(Tcl_Obj *objPtr); /* 381 */ -EXTERN Tcl_UniChar Tcl_GetUniChar(Tcl_Obj *objPtr, int index); +EXTERN int Tcl_GetUniChar(Tcl_Obj *objPtr, int index); /* 382 */ -EXTERN Tcl_UniChar * Tcl_GetUnicode(Tcl_Obj *objPtr); +TCL_DEPRECATED("No longer in use, changed to macro") +Tcl_UniChar * Tcl_GetUnicode(Tcl_Obj *objPtr); /* 383 */ EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, int first, int last); /* 384 */ @@ -1147,8 +1191,7 @@ EXTERN Tcl_Channel Tcl_GetTopChannel(Tcl_Channel chan); /* 397 */ EXTERN int Tcl_ChannelBuffered(Tcl_Channel chan); /* 398 */ -EXTERN CONST84_RETURN char * Tcl_ChannelName( - const Tcl_ChannelType *chanTypePtr); +EXTERN const char * Tcl_ChannelName(const Tcl_ChannelType *chanTypePtr); /* 399 */ EXTERN Tcl_ChannelTypeVersion Tcl_ChannelVersion( const Tcl_ChannelType *chanTypePtr); @@ -1254,13 +1297,15 @@ EXTERN Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel); EXTERN Tcl_UniChar * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr); /* 435 */ -EXTERN int Tcl_GetMathFuncInfo(Tcl_Interp *interp, +TCL_DEPRECATED("") +int Tcl_GetMathFuncInfo(Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, ClientData *clientDataPtr); /* 436 */ -EXTERN Tcl_Obj * Tcl_ListMathFuncs(Tcl_Interp *interp, +TCL_DEPRECATED("") +Tcl_Obj * Tcl_ListMathFuncs(Tcl_Interp *interp, const char *pattern); /* 437 */ EXTERN Tcl_Obj * Tcl_SubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, @@ -1495,7 +1540,7 @@ EXTERN void Tcl_GetCommandFullName(Tcl_Interp *interp, EXTERN int Tcl_FSEvalFileEx(Tcl_Interp *interp, Tcl_Obj *fileName, const char *encodingName); /* 519 */ -EXTERN Tcl_ExitProc * Tcl_SetExitProc(Tcl_ExitProc *proc); +EXTERN Tcl_ExitProc * Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc); /* 520 */ EXTERN void Tcl_LimitAddHandler(Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, @@ -1811,6 +1856,12 @@ EXTERN int Tcl_FSUnloadFile(Tcl_Interp *interp, EXTERN void Tcl_ZlibStreamSetCompressionDictionary( Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); +/* 631 */ +EXTERN Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp, + const char *service, const char *host, + unsigned int flags, + Tcl_TcpAcceptProc *acceptProc, + ClientData callbackData); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -1823,27 +1874,27 @@ typedef struct TclStubs { const TclStubHooks *hooks; int (*tcl_PkgProvideEx) (Tcl_Interp *interp, const char *name, const char *version, const void *clientData); /* 0 */ - CONST84_RETURN char * (*tcl_PkgRequireEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 1 */ - void (*tcl_Panic) (const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 2 */ + const char * (*tcl_PkgRequireEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 1 */ + TCL_NORETURN1 void (*tcl_Panic) (const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 2 */ char * (*tcl_Alloc) (unsigned int size); /* 3 */ void (*tcl_Free) (char *ptr); /* 4 */ char * (*tcl_Realloc) (char *ptr, unsigned int size); /* 5 */ char * (*tcl_DbCkalloc) (unsigned int size, const char *file, int line); /* 6 */ void (*tcl_DbCkfree) (char *ptr, const char *file, int line); /* 7 */ char * (*tcl_DbCkrealloc) (char *ptr, unsigned int size, const char *file, int line); /* 8 */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, ClientData clientData); /* 9 */ #endif /* UNIX */ -#if defined(__WIN32__) /* WIN */ +#if defined(_WIN32) /* WIN */ void (*reserved9)(void); #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, ClientData clientData); /* 9 */ #endif /* MACOSX */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ void (*tcl_DeleteFileHandler) (int fd); /* 10 */ #endif /* UNIX */ -#if defined(__WIN32__) /* WIN */ +#if defined(_WIN32) /* WIN */ void (*reserved10)(void); #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ @@ -1860,11 +1911,11 @@ typedef struct TclStubs { void (*tcl_DbDecrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 19 */ void (*tcl_DbIncrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 20 */ int (*tcl_DbIsShared) (Tcl_Obj *objPtr, const char *file, int line); /* 21 */ - Tcl_Obj * (*tcl_DbNewBooleanObj) (int boolValue, const char *file, int line); /* 22 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_DbNewBooleanObj) (int boolValue, const char *file, int line); /* 22 */ Tcl_Obj * (*tcl_DbNewByteArrayObj) (const unsigned char *bytes, int length, const char *file, int line); /* 23 */ Tcl_Obj * (*tcl_DbNewDoubleObj) (double doubleValue, const char *file, int line); /* 24 */ Tcl_Obj * (*tcl_DbNewListObj) (int objc, Tcl_Obj *const *objv, const char *file, int line); /* 25 */ - Tcl_Obj * (*tcl_DbNewLongObj) (long longValue, const char *file, int line); /* 26 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_DbNewLongObj) (long longValue, const char *file, int line); /* 26 */ Tcl_Obj * (*tcl_DbNewObj) (const char *file, int line); /* 27 */ Tcl_Obj * (*tcl_DbNewStringObj) (const char *bytes, int length, const char *file, int line); /* 28 */ Tcl_Obj * (*tcl_DuplicateObj) (Tcl_Obj *objPtr); /* 29 */ @@ -1874,7 +1925,7 @@ typedef struct TclStubs { unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 33 */ int (*tcl_GetDouble) (Tcl_Interp *interp, const char *src, double *doublePtr); /* 34 */ int (*tcl_GetDoubleFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); /* 35 */ - int (*tcl_GetIndexFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, CONST84 char *const *tablePtr, const char *msg, int flags, int *indexPtr); /* 36 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_GetIndexFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, const char *const *tablePtr, const char *msg, int flags, int *indexPtr); /* 36 */ int (*tcl_GetInt) (Tcl_Interp *interp, const char *src, int *intPtr); /* 37 */ int (*tcl_GetIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr); /* 38 */ int (*tcl_GetLongFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr); /* 39 */ @@ -1887,25 +1938,25 @@ typedef struct TclStubs { int (*tcl_ListObjIndex) (Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj **objPtrPtr); /* 46 */ int (*tcl_ListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, int *lengthPtr); /* 47 */ int (*tcl_ListObjReplace) (Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *const objv[]); /* 48 */ - Tcl_Obj * (*tcl_NewBooleanObj) (int boolValue); /* 49 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_NewBooleanObj) (int boolValue); /* 49 */ Tcl_Obj * (*tcl_NewByteArrayObj) (const unsigned char *bytes, int length); /* 50 */ Tcl_Obj * (*tcl_NewDoubleObj) (double doubleValue); /* 51 */ - Tcl_Obj * (*tcl_NewIntObj) (int intValue); /* 52 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_NewIntObj) (int intValue); /* 52 */ Tcl_Obj * (*tcl_NewListObj) (int objc, Tcl_Obj *const objv[]); /* 53 */ - Tcl_Obj * (*tcl_NewLongObj) (long longValue); /* 54 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_NewLongObj) (long longValue); /* 54 */ Tcl_Obj * (*tcl_NewObj) (void); /* 55 */ Tcl_Obj * (*tcl_NewStringObj) (const char *bytes, int length); /* 56 */ - void (*tcl_SetBooleanObj) (Tcl_Obj *objPtr, int boolValue); /* 57 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_SetBooleanObj) (Tcl_Obj *objPtr, int boolValue); /* 57 */ unsigned char * (*tcl_SetByteArrayLength) (Tcl_Obj *objPtr, int length); /* 58 */ void (*tcl_SetByteArrayObj) (Tcl_Obj *objPtr, const unsigned char *bytes, int length); /* 59 */ void (*tcl_SetDoubleObj) (Tcl_Obj *objPtr, double doubleValue); /* 60 */ - void (*tcl_SetIntObj) (Tcl_Obj *objPtr, int intValue); /* 61 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_SetIntObj) (Tcl_Obj *objPtr, int intValue); /* 61 */ void (*tcl_SetListObj) (Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[]); /* 62 */ - void (*tcl_SetLongObj) (Tcl_Obj *objPtr, long longValue); /* 63 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_SetLongObj) (Tcl_Obj *objPtr, long longValue); /* 63 */ void (*tcl_SetObjLength) (Tcl_Obj *objPtr, int length); /* 64 */ void (*tcl_SetStringObj) (Tcl_Obj *objPtr, const char *bytes, int length); /* 65 */ - void (*tcl_AddErrorInfo) (Tcl_Interp *interp, const char *message); /* 66 */ - void (*tcl_AddObjErrorInfo) (Tcl_Interp *interp, const char *message, int length); /* 67 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_AddErrorInfo) (Tcl_Interp *interp, const char *message); /* 66 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_AddObjErrorInfo) (Tcl_Interp *interp, const char *message, int length); /* 67 */ void (*tcl_AllowExceptions) (Tcl_Interp *interp); /* 68 */ void (*tcl_AppendElement) (Tcl_Interp *interp, const char *element); /* 69 */ void (*tcl_AppendResult) (Tcl_Interp *interp, ...); /* 70 */ @@ -1915,16 +1966,16 @@ typedef struct TclStubs { void (*tcl_AsyncMark) (Tcl_AsyncHandler async); /* 74 */ int (*tcl_AsyncReady) (void); /* 75 */ void (*tcl_BackgroundError) (Tcl_Interp *interp); /* 76 */ - char (*tcl_Backslash) (const char *src, int *readPtr); /* 77 */ + TCL_DEPRECATED_API("Use Tcl_UtfBackslash") char (*tcl_Backslash) (const char *src, int *readPtr); /* 77 */ int (*tcl_BadChannelOption) (Tcl_Interp *interp, const char *optionName, const char *optionList); /* 78 */ void (*tcl_CallWhenDeleted) (Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, ClientData clientData); /* 79 */ void (*tcl_CancelIdleCall) (Tcl_IdleProc *idleProc, ClientData clientData); /* 80 */ int (*tcl_Close) (Tcl_Interp *interp, Tcl_Channel chan); /* 81 */ int (*tcl_CommandComplete) (const char *cmd); /* 82 */ - char * (*tcl_Concat) (int argc, CONST84 char *const *argv); /* 83 */ + char * (*tcl_Concat) (int argc, const char *const *argv); /* 83 */ int (*tcl_ConvertElement) (const char *src, char *dst, int flags); /* 84 */ int (*tcl_ConvertCountedElement) (const char *src, int length, char *dst, int flags); /* 85 */ - int (*tcl_CreateAlias) (Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int argc, CONST84 char *const *argv); /* 86 */ + int (*tcl_CreateAlias) (Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int argc, const char *const *argv); /* 86 */ int (*tcl_CreateAliasObj) (Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int objc, Tcl_Obj *const objv[]); /* 87 */ Tcl_Channel (*tcl_CreateChannel) (const Tcl_ChannelType *typePtr, const char *chanName, ClientData instanceData, int mask); /* 88 */ void (*tcl_CreateChannelHandler) (Tcl_Channel chan, int mask, Tcl_ChannelProc *proc, ClientData clientData); /* 89 */ @@ -1933,7 +1984,7 @@ typedef struct TclStubs { void (*tcl_CreateEventSource) (Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, ClientData clientData); /* 92 */ void (*tcl_CreateExitHandler) (Tcl_ExitProc *proc, ClientData clientData); /* 93 */ Tcl_Interp * (*tcl_CreateInterp) (void); /* 94 */ - void (*tcl_CreateMathFunc) (Tcl_Interp *interp, const char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, ClientData clientData); /* 95 */ + TCL_DEPRECATED_API("") void (*tcl_CreateMathFunc) (Tcl_Interp *interp, const char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, ClientData clientData); /* 95 */ Tcl_Command (*tcl_CreateObjCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 96 */ Tcl_Interp * (*tcl_CreateSlave) (Tcl_Interp *interp, const char *slaveName, int isSafe); /* 97 */ Tcl_TimerToken (*tcl_CreateTimerHandler) (int milliseconds, Tcl_TimerProc *proc, ClientData clientData); /* 98 */ @@ -1965,13 +2016,13 @@ typedef struct TclStubs { void (*tcl_DStringSetLength) (Tcl_DString *dsPtr, int length); /* 124 */ void (*tcl_DStringStartSublist) (Tcl_DString *dsPtr); /* 125 */ int (*tcl_Eof) (Tcl_Channel chan); /* 126 */ - CONST84_RETURN char * (*tcl_ErrnoId) (void); /* 127 */ - CONST84_RETURN char * (*tcl_ErrnoMsg) (int err); /* 128 */ + const char * (*tcl_ErrnoId) (void); /* 127 */ + const char * (*tcl_ErrnoMsg) (int err); /* 128 */ int (*tcl_Eval) (Tcl_Interp *interp, const char *script); /* 129 */ int (*tcl_EvalFile) (Tcl_Interp *interp, const char *fileName); /* 130 */ - int (*tcl_EvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 131 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_EvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 131 */ void (*tcl_EventuallyFree) (ClientData clientData, Tcl_FreeProc *freeProc); /* 132 */ - void (*tcl_Exit) (int status); /* 133 */ + TCL_NORETURN1 void (*tcl_Exit) (int status); /* 133 */ int (*tcl_ExposeCommand) (Tcl_Interp *interp, const char *hiddenCmdToken, const char *cmdName); /* 134 */ int (*tcl_ExprBoolean) (Tcl_Interp *interp, const char *expr, int *ptr); /* 135 */ int (*tcl_ExprBooleanObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *ptr); /* 136 */ @@ -1986,29 +2037,29 @@ typedef struct TclStubs { Tcl_HashEntry * (*tcl_FirstHashEntry) (Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 145 */ int (*tcl_Flush) (Tcl_Channel chan); /* 146 */ void (*tcl_FreeResult) (Tcl_Interp *interp); /* 147 */ - int (*tcl_GetAlias) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *argcPtr, CONST84 char ***argvPtr); /* 148 */ - int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */ + int (*tcl_GetAlias) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *argcPtr, const char ***argvPtr); /* 148 */ + int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */ ClientData (*tcl_GetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr); /* 150 */ Tcl_Channel (*tcl_GetChannel) (Tcl_Interp *interp, const char *chanName, int *modePtr); /* 151 */ int (*tcl_GetChannelBufferSize) (Tcl_Channel chan); /* 152 */ int (*tcl_GetChannelHandle) (Tcl_Channel chan, int direction, ClientData *handlePtr); /* 153 */ ClientData (*tcl_GetChannelInstanceData) (Tcl_Channel chan); /* 154 */ int (*tcl_GetChannelMode) (Tcl_Channel chan); /* 155 */ - CONST84_RETURN char * (*tcl_GetChannelName) (Tcl_Channel chan); /* 156 */ + const char * (*tcl_GetChannelName) (Tcl_Channel chan); /* 156 */ int (*tcl_GetChannelOption) (Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, Tcl_DString *dsPtr); /* 157 */ CONST86 Tcl_ChannelType * (*tcl_GetChannelType) (Tcl_Channel chan); /* 158 */ int (*tcl_GetCommandInfo) (Tcl_Interp *interp, const char *cmdName, Tcl_CmdInfo *infoPtr); /* 159 */ - CONST84_RETURN char * (*tcl_GetCommandName) (Tcl_Interp *interp, Tcl_Command command); /* 160 */ + const char * (*tcl_GetCommandName) (Tcl_Interp *interp, Tcl_Command command); /* 160 */ int (*tcl_GetErrno) (void); /* 161 */ - CONST84_RETURN char * (*tcl_GetHostName) (void); /* 162 */ + const char * (*tcl_GetHostName) (void); /* 162 */ int (*tcl_GetInterpPath) (Tcl_Interp *askInterp, Tcl_Interp *slaveInterp); /* 163 */ Tcl_Interp * (*tcl_GetMaster) (Tcl_Interp *interp); /* 164 */ const char * (*tcl_GetNameOfExecutable) (void); /* 165 */ Tcl_Obj * (*tcl_GetObjResult) (Tcl_Interp *interp); /* 166 */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, ClientData *filePtr); /* 167 */ #endif /* UNIX */ -#if defined(__WIN32__) /* WIN */ +#if defined(_WIN32) /* WIN */ void (*reserved167)(void); #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ @@ -2020,11 +2071,11 @@ typedef struct TclStubs { int (*tcl_GetServiceMode) (void); /* 171 */ Tcl_Interp * (*tcl_GetSlave) (Tcl_Interp *interp, const char *slaveName); /* 172 */ Tcl_Channel (*tcl_GetStdChannel) (int type); /* 173 */ - CONST84_RETURN char * (*tcl_GetStringResult) (Tcl_Interp *interp); /* 174 */ - CONST84_RETURN char * (*tcl_GetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 175 */ - CONST84_RETURN char * (*tcl_GetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 176 */ + const char * (*tcl_GetStringResult) (Tcl_Interp *interp); /* 174 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_GetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 175 */ + const char * (*tcl_GetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 176 */ int (*tcl_GlobalEval) (Tcl_Interp *interp, const char *command); /* 177 */ - int (*tcl_GlobalEvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 178 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_GlobalEvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 178 */ int (*tcl_HideCommand) (Tcl_Interp *interp, const char *cmdName, const char *hiddenCmdToken); /* 179 */ int (*tcl_Init) (Tcl_Interp *interp); /* 180 */ void (*tcl_InitHashTable) (Tcl_HashTable *tablePtr, int keyType); /* 181 */ @@ -2032,25 +2083,25 @@ typedef struct TclStubs { int (*tcl_InputBuffered) (Tcl_Channel chan); /* 183 */ int (*tcl_InterpDeleted) (Tcl_Interp *interp); /* 184 */ int (*tcl_IsSafe) (Tcl_Interp *interp); /* 185 */ - char * (*tcl_JoinPath) (int argc, CONST84 char *const *argv, Tcl_DString *resultPtr); /* 186 */ + char * (*tcl_JoinPath) (int argc, const char *const *argv, Tcl_DString *resultPtr); /* 186 */ int (*tcl_LinkVar) (Tcl_Interp *interp, const char *varName, char *addr, int type); /* 187 */ void (*reserved188)(void); Tcl_Channel (*tcl_MakeFileChannel) (ClientData handle, int mode); /* 189 */ int (*tcl_MakeSafe) (Tcl_Interp *interp); /* 190 */ Tcl_Channel (*tcl_MakeTcpClientChannel) (ClientData tcpSocket); /* 191 */ - char * (*tcl_Merge) (int argc, CONST84 char *const *argv); /* 192 */ + char * (*tcl_Merge) (int argc, const char *const *argv); /* 192 */ Tcl_HashEntry * (*tcl_NextHashEntry) (Tcl_HashSearch *searchPtr); /* 193 */ void (*tcl_NotifyChannel) (Tcl_Channel channel, int mask); /* 194 */ Tcl_Obj * (*tcl_ObjGetVar2) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 195 */ Tcl_Obj * (*tcl_ObjSetVar2) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags); /* 196 */ - Tcl_Channel (*tcl_OpenCommandChannel) (Tcl_Interp *interp, int argc, CONST84 char **argv, int flags); /* 197 */ + Tcl_Channel (*tcl_OpenCommandChannel) (Tcl_Interp *interp, int argc, const char **argv, int flags); /* 197 */ Tcl_Channel (*tcl_OpenFileChannel) (Tcl_Interp *interp, const char *fileName, const char *modeString, int permissions); /* 198 */ Tcl_Channel (*tcl_OpenTcpClient) (Tcl_Interp *interp, int port, const char *address, const char *myaddr, int myport, int async); /* 199 */ Tcl_Channel (*tcl_OpenTcpServer) (Tcl_Interp *interp, int port, const char *host, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData); /* 200 */ void (*tcl_Preserve) (ClientData data); /* 201 */ void (*tcl_PrintDouble) (Tcl_Interp *interp, double value, char *dst); /* 202 */ int (*tcl_PutEnv) (const char *assignment); /* 203 */ - CONST84_RETURN char * (*tcl_PosixError) (Tcl_Interp *interp); /* 204 */ + const char * (*tcl_PosixError) (Tcl_Interp *interp); /* 204 */ void (*tcl_QueueEvent) (Tcl_Event *evPtr, Tcl_QueuePosition position); /* 205 */ int (*tcl_Read) (Tcl_Channel chan, char *bufPtr, int toRead); /* 206 */ void (*tcl_ReapDetachedProcs) (void); /* 207 */ @@ -2061,12 +2112,12 @@ typedef struct TclStubs { Tcl_RegExp (*tcl_RegExpCompile) (Tcl_Interp *interp, const char *pattern); /* 212 */ int (*tcl_RegExpExec) (Tcl_Interp *interp, Tcl_RegExp regexp, const char *text, const char *start); /* 213 */ int (*tcl_RegExpMatch) (Tcl_Interp *interp, const char *text, const char *pattern); /* 214 */ - void (*tcl_RegExpRange) (Tcl_RegExp regexp, int index, CONST84 char **startPtr, CONST84 char **endPtr); /* 215 */ + void (*tcl_RegExpRange) (Tcl_RegExp regexp, int index, const char **startPtr, const char **endPtr); /* 215 */ void (*tcl_Release) (ClientData clientData); /* 216 */ void (*tcl_ResetResult) (Tcl_Interp *interp); /* 217 */ int (*tcl_ScanElement) (const char *src, int *flagPtr); /* 218 */ int (*tcl_ScanCountedElement) (const char *src, int length, int *flagPtr); /* 219 */ - int (*tcl_SeekOld) (Tcl_Channel chan, int offset, int mode); /* 220 */ + TCL_DEPRECATED_API("") int (*tcl_SeekOld) (Tcl_Channel chan, int offset, int mode); /* 220 */ int (*tcl_ServiceAll) (void); /* 221 */ int (*tcl_ServiceEvent) (int flags); /* 222 */ void (*tcl_SetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc *proc, ClientData clientData); /* 223 */ @@ -2076,55 +2127,55 @@ typedef struct TclStubs { void (*tcl_SetErrno) (int err); /* 227 */ void (*tcl_SetErrorCode) (Tcl_Interp *interp, ...); /* 228 */ void (*tcl_SetMaxBlockTime) (const Tcl_Time *timePtr); /* 229 */ - void (*tcl_SetPanicProc) (Tcl_PanicProc *panicProc); /* 230 */ + void (*tcl_SetPanicProc) (TCL_NORETURN1 Tcl_PanicProc *panicProc); /* 230 */ int (*tcl_SetRecursionLimit) (Tcl_Interp *interp, int depth); /* 231 */ void (*tcl_SetResult) (Tcl_Interp *interp, char *result, Tcl_FreeProc *freeProc); /* 232 */ int (*tcl_SetServiceMode) (int mode); /* 233 */ void (*tcl_SetObjErrorCode) (Tcl_Interp *interp, Tcl_Obj *errorObjPtr); /* 234 */ void (*tcl_SetObjResult) (Tcl_Interp *interp, Tcl_Obj *resultObjPtr); /* 235 */ void (*tcl_SetStdChannel) (Tcl_Channel channel, int type); /* 236 */ - CONST84_RETURN char * (*tcl_SetVar) (Tcl_Interp *interp, const char *varName, const char *newValue, int flags); /* 237 */ - CONST84_RETURN char * (*tcl_SetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, const char *newValue, int flags); /* 238 */ - CONST84_RETURN char * (*tcl_SignalId) (int sig); /* 239 */ - CONST84_RETURN char * (*tcl_SignalMsg) (int sig); /* 240 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_SetVar) (Tcl_Interp *interp, const char *varName, const char *newValue, int flags); /* 237 */ + const char * (*tcl_SetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, const char *newValue, int flags); /* 238 */ + const char * (*tcl_SignalId) (int sig); /* 239 */ + const char * (*tcl_SignalMsg) (int sig); /* 240 */ void (*tcl_SourceRCFile) (Tcl_Interp *interp); /* 241 */ - int (*tcl_SplitList) (Tcl_Interp *interp, const char *listStr, int *argcPtr, CONST84 char ***argvPtr); /* 242 */ - void (*tcl_SplitPath) (const char *path, int *argcPtr, CONST84 char ***argvPtr); /* 243 */ + int (*tcl_SplitList) (Tcl_Interp *interp, const char *listStr, int *argcPtr, const char ***argvPtr); /* 242 */ + void (*tcl_SplitPath) (const char *path, int *argcPtr, const char ***argvPtr); /* 243 */ void (*tcl_StaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 244 */ int (*tcl_StringMatch) (const char *str, const char *pattern); /* 245 */ - int (*tcl_TellOld) (Tcl_Channel chan); /* 246 */ - int (*tcl_TraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 247 */ + TCL_DEPRECATED_API("") int (*tcl_TellOld) (Tcl_Channel chan); /* 246 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_TraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 247 */ int (*tcl_TraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 248 */ char * (*tcl_TranslateFileName) (Tcl_Interp *interp, const char *name, Tcl_DString *bufferPtr); /* 249 */ int (*tcl_Ungets) (Tcl_Channel chan, const char *str, int len, int atHead); /* 250 */ void (*tcl_UnlinkVar) (Tcl_Interp *interp, const char *varName); /* 251 */ int (*tcl_UnregisterChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 252 */ - int (*tcl_UnsetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 253 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_UnsetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 253 */ int (*tcl_UnsetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 254 */ - void (*tcl_UntraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 255 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_UntraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 255 */ void (*tcl_UntraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 256 */ void (*tcl_UpdateLinkedVar) (Tcl_Interp *interp, const char *varName); /* 257 */ - int (*tcl_UpVar) (Tcl_Interp *interp, const char *frameName, const char *varName, const char *localName, int flags); /* 258 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_UpVar) (Tcl_Interp *interp, const char *frameName, const char *varName, const char *localName, int flags); /* 258 */ int (*tcl_UpVar2) (Tcl_Interp *interp, const char *frameName, const char *part1, const char *part2, const char *localName, int flags); /* 259 */ int (*tcl_VarEval) (Tcl_Interp *interp, ...); /* 260 */ - ClientData (*tcl_VarTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 261 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") ClientData (*tcl_VarTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 261 */ ClientData (*tcl_VarTraceInfo2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 262 */ int (*tcl_Write) (Tcl_Channel chan, const char *s, int slen); /* 263 */ void (*tcl_WrongNumArgs) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], const char *message); /* 264 */ int (*tcl_DumpActiveMemory) (const char *fileName); /* 265 */ void (*tcl_ValidateAllMemory) (const char *file, int line); /* 266 */ - void (*tcl_AppendResultVA) (Tcl_Interp *interp, va_list argList); /* 267 */ - void (*tcl_AppendStringsToObjVA) (Tcl_Obj *objPtr, va_list argList); /* 268 */ + TCL_DEPRECATED_API("see TIP #422") void (*tcl_AppendResultVA) (Tcl_Interp *interp, va_list argList); /* 267 */ + TCL_DEPRECATED_API("see TIP #422") void (*tcl_AppendStringsToObjVA) (Tcl_Obj *objPtr, va_list argList); /* 268 */ char * (*tcl_HashStats) (Tcl_HashTable *tablePtr); /* 269 */ - CONST84_RETURN char * (*tcl_ParseVar) (Tcl_Interp *interp, const char *start, CONST84 char **termPtr); /* 270 */ - CONST84_RETURN char * (*tcl_PkgPresent) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 271 */ - CONST84_RETURN char * (*tcl_PkgPresentEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 272 */ - int (*tcl_PkgProvide) (Tcl_Interp *interp, const char *name, const char *version); /* 273 */ - CONST84_RETURN char * (*tcl_PkgRequire) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 274 */ - void (*tcl_SetErrorCodeVA) (Tcl_Interp *interp, va_list argList); /* 275 */ - int (*tcl_VarEvalVA) (Tcl_Interp *interp, va_list argList); /* 276 */ + const char * (*tcl_ParseVar) (Tcl_Interp *interp, const char *start, const char **termPtr); /* 270 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_PkgPresent) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 271 */ + const char * (*tcl_PkgPresentEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 272 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_PkgProvide) (Tcl_Interp *interp, const char *name, const char *version); /* 273 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_PkgRequire) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 274 */ + TCL_DEPRECATED_API("see TIP #422") void (*tcl_SetErrorCodeVA) (Tcl_Interp *interp, va_list argList); /* 275 */ + TCL_DEPRECATED_API("see TIP #422") int (*tcl_VarEvalVA) (Tcl_Interp *interp, va_list argList); /* 276 */ Tcl_Pid (*tcl_WaitPid) (Tcl_Pid pid, int *statPtr, int options); /* 277 */ - void (*tcl_PanicVA) (const char *format, va_list argList); /* 278 */ + TCL_DEPRECATED_API("see TIP #422") TCL_NORETURN1 void (*tcl_PanicVA) (const char *format, va_list argList); /* 278 */ void (*tcl_GetVersion) (int *major, int *minor, int *patchLevel, int *type); /* 279 */ void (*tcl_InitMemory) (Tcl_Interp *interp); /* 280 */ Tcl_Channel (*tcl_StackChannel) (Tcl_Interp *interp, const Tcl_ChannelType *typePtr, ClientData instanceData, int mask, Tcl_Channel prevChan); /* 281 */ @@ -2140,7 +2191,7 @@ typedef struct TclStubs { int (*tcl_EvalEx) (Tcl_Interp *interp, const char *script, int numBytes, int flags); /* 291 */ int (*tcl_EvalObjv) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* 292 */ int (*tcl_EvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 293 */ - void (*tcl_ExitThread) (int status); /* 294 */ + TCL_NORETURN1 void (*tcl_ExitThread) (int status); /* 294 */ int (*tcl_ExternalToUtf) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 295 */ char * (*tcl_ExternalToUtfDString) (Tcl_Encoding encoding, const char *src, int srcLen, Tcl_DString *dsPtr); /* 296 */ void (*tcl_FinalizeThread) (void); /* 297 */ @@ -2148,7 +2199,7 @@ typedef struct TclStubs { void (*tcl_FreeEncoding) (Tcl_Encoding encoding); /* 299 */ Tcl_ThreadId (*tcl_GetCurrentThread) (void); /* 300 */ Tcl_Encoding (*tcl_GetEncoding) (Tcl_Interp *interp, const char *name); /* 301 */ - CONST84_RETURN char * (*tcl_GetEncodingName) (Tcl_Encoding encoding); /* 302 */ + const char * (*tcl_GetEncodingName) (Tcl_Encoding encoding); /* 302 */ void (*tcl_GetEncodingNames) (Tcl_Interp *interp); /* 303 */ int (*tcl_GetIndexFromObjStruct) (Tcl_Interp *interp, Tcl_Obj *objPtr, const void *tablePtr, int offset, const char *msg, int flags, int *indexPtr); /* 304 */ void * (*tcl_GetThreadData) (Tcl_ThreadDataKey *keyPtr, int size); /* 305 */ @@ -2166,18 +2217,18 @@ typedef struct TclStubs { Tcl_Obj * (*tcl_SetVar2Ex) (Tcl_Interp *interp, const char *part1, const char *part2, Tcl_Obj *newValuePtr, int flags); /* 317 */ void (*tcl_ThreadAlert) (Tcl_ThreadId threadId); /* 318 */ void (*tcl_ThreadQueueEvent) (Tcl_ThreadId threadId, Tcl_Event *evPtr, Tcl_QueuePosition position); /* 319 */ - Tcl_UniChar (*tcl_UniCharAtIndex) (const char *src, int index); /* 320 */ - Tcl_UniChar (*tcl_UniCharToLower) (int ch); /* 321 */ - Tcl_UniChar (*tcl_UniCharToTitle) (int ch); /* 322 */ - Tcl_UniChar (*tcl_UniCharToUpper) (int ch); /* 323 */ + int (*tcl_UniCharAtIndex) (const char *src, int index); /* 320 */ + int (*tcl_UniCharToLower) (int ch); /* 321 */ + int (*tcl_UniCharToTitle) (int ch); /* 322 */ + int (*tcl_UniCharToUpper) (int ch); /* 323 */ int (*tcl_UniCharToUtf) (int ch, char *buf); /* 324 */ - CONST84_RETURN char * (*tcl_UtfAtIndex) (const char *src, int index); /* 325 */ + const char * (*tcl_UtfAtIndex) (const char *src, int index); /* 325 */ int (*tcl_UtfCharComplete) (const char *src, int length); /* 326 */ int (*tcl_UtfBackslash) (const char *src, int *readPtr, char *dst); /* 327 */ - CONST84_RETURN char * (*tcl_UtfFindFirst) (const char *src, int ch); /* 328 */ - CONST84_RETURN char * (*tcl_UtfFindLast) (const char *src, int ch); /* 329 */ - CONST84_RETURN char * (*tcl_UtfNext) (const char *src); /* 330 */ - CONST84_RETURN char * (*tcl_UtfPrev) (const char *src, const char *start); /* 331 */ + const char * (*tcl_UtfFindFirst) (const char *src, int ch); /* 328 */ + const char * (*tcl_UtfFindLast) (const char *src, int ch); /* 329 */ + const char * (*tcl_UtfNext) (const char *src); /* 330 */ + const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 331 */ int (*tcl_UtfToExternal) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 332 */ char * (*tcl_UtfToExternalDString) (Tcl_Encoding encoding, const char *src, int srcLen, Tcl_DString *dsPtr); /* 333 */ int (*tcl_UtfToLower) (char *src); /* 334 */ @@ -2187,8 +2238,8 @@ typedef struct TclStubs { int (*tcl_WriteChars) (Tcl_Channel chan, const char *src, int srcLen); /* 338 */ int (*tcl_WriteObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 339 */ char * (*tcl_GetString) (Tcl_Obj *objPtr); /* 340 */ - CONST84_RETURN char * (*tcl_GetDefaultEncodingDir) (void); /* 341 */ - void (*tcl_SetDefaultEncodingDir) (const char *path); /* 342 */ + TCL_DEPRECATED_API("Use Tcl_GetEncodingSearchPath") const char * (*tcl_GetDefaultEncodingDir) (void); /* 341 */ + TCL_DEPRECATED_API("Use Tcl_SetEncodingSearchPath") void (*tcl_SetDefaultEncodingDir) (const char *path); /* 342 */ void (*tcl_AlertNotifier) (ClientData clientData); /* 343 */ void (*tcl_ServiceModeHook) (int mode); /* 344 */ int (*tcl_UniCharIsAlnum) (int ch); /* 345 */ @@ -2203,13 +2254,13 @@ typedef struct TclStubs { char * (*tcl_UniCharToUtfDString) (const Tcl_UniChar *uniStr, int uniLength, Tcl_DString *dsPtr); /* 354 */ Tcl_UniChar * (*tcl_UtfToUniCharDString) (const char *src, int length, Tcl_DString *dsPtr); /* 355 */ Tcl_RegExp (*tcl_GetRegExpFromObj) (Tcl_Interp *interp, Tcl_Obj *patObj, int flags); /* 356 */ - Tcl_Obj * (*tcl_EvalTokens) (Tcl_Interp *interp, Tcl_Token *tokenPtr, int count); /* 357 */ + TCL_DEPRECATED_API("Use Tcl_EvalTokensStandard") Tcl_Obj * (*tcl_EvalTokens) (Tcl_Interp *interp, Tcl_Token *tokenPtr, int count); /* 357 */ void (*tcl_FreeParse) (Tcl_Parse *parsePtr); /* 358 */ void (*tcl_LogCommandInfo) (Tcl_Interp *interp, const char *script, const char *command, int length); /* 359 */ - int (*tcl_ParseBraces) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, CONST84 char **termPtr); /* 360 */ + int (*tcl_ParseBraces) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 360 */ int (*tcl_ParseCommand) (Tcl_Interp *interp, const char *start, int numBytes, int nested, Tcl_Parse *parsePtr); /* 361 */ int (*tcl_ParseExpr) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr); /* 362 */ - int (*tcl_ParseQuotedString) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, CONST84 char **termPtr); /* 363 */ + int (*tcl_ParseQuotedString) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 363 */ int (*tcl_ParseVarName) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append); /* 364 */ char * (*tcl_GetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 365 */ int (*tcl_Chdir) (const char *dirName); /* 366 */ @@ -2227,8 +2278,8 @@ typedef struct TclStubs { Tcl_Obj * (*tcl_NewUnicodeObj) (const Tcl_UniChar *unicode, int numChars); /* 378 */ void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int numChars); /* 379 */ int (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 380 */ - Tcl_UniChar (*tcl_GetUniChar) (Tcl_Obj *objPtr, int index); /* 381 */ - Tcl_UniChar * (*tcl_GetUnicode) (Tcl_Obj *objPtr); /* 382 */ + int (*tcl_GetUniChar) (Tcl_Obj *objPtr, int index); /* 381 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_UniChar * (*tcl_GetUnicode) (Tcl_Obj *objPtr); /* 382 */ Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, int first, int last); /* 383 */ void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int length); /* 384 */ int (*tcl_RegExpMatchObj) (Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); /* 385 */ @@ -2244,7 +2295,7 @@ typedef struct TclStubs { int (*tcl_WriteRaw) (Tcl_Channel chan, const char *src, int srcLen); /* 395 */ Tcl_Channel (*tcl_GetTopChannel) (Tcl_Channel chan); /* 396 */ int (*tcl_ChannelBuffered) (Tcl_Channel chan); /* 397 */ - CONST84_RETURN char * (*tcl_ChannelName) (const Tcl_ChannelType *chanTypePtr); /* 398 */ + const char * (*tcl_ChannelName) (const Tcl_ChannelType *chanTypePtr); /* 398 */ Tcl_ChannelTypeVersion (*tcl_ChannelVersion) (const Tcl_ChannelType *chanTypePtr); /* 399 */ Tcl_DriverBlockModeProc * (*tcl_ChannelBlockModeProc) (const Tcl_ChannelType *chanTypePtr); /* 400 */ Tcl_DriverCloseProc * (*tcl_ChannelCloseProc) (const Tcl_ChannelType *chanTypePtr); /* 401 */ @@ -2281,8 +2332,8 @@ typedef struct TclStubs { int (*tcl_AttemptSetObjLength) (Tcl_Obj *objPtr, int length); /* 432 */ Tcl_ThreadId (*tcl_GetChannelThread) (Tcl_Channel channel); /* 433 */ Tcl_UniChar * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 434 */ - int (*tcl_GetMathFuncInfo) (Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, ClientData *clientDataPtr); /* 435 */ - Tcl_Obj * (*tcl_ListMathFuncs) (Tcl_Interp *interp, const char *pattern); /* 436 */ + TCL_DEPRECATED_API("") int (*tcl_GetMathFuncInfo) (Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, ClientData *clientDataPtr); /* 435 */ + TCL_DEPRECATED_API("") Tcl_Obj * (*tcl_ListMathFuncs) (Tcl_Interp *interp, const char *pattern); /* 436 */ Tcl_Obj * (*tcl_SubstObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 437 */ int (*tcl_DetachChannel) (Tcl_Interp *interp, Tcl_Channel channel); /* 438 */ int (*tcl_IsStandardChannel) (Tcl_Channel channel); /* 439 */ @@ -2365,7 +2416,7 @@ typedef struct TclStubs { Tcl_Command (*tcl_GetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 516 */ void (*tcl_GetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 517 */ int (*tcl_FSEvalFileEx) (Tcl_Interp *interp, Tcl_Obj *fileName, const char *encodingName); /* 518 */ - Tcl_ExitProc * (*tcl_SetExitProc) (Tcl_ExitProc *proc); /* 519 */ + Tcl_ExitProc * (*tcl_SetExitProc) (TCL_NORETURN1 Tcl_ExitProc *proc); /* 519 */ void (*tcl_LimitAddHandler) (Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, ClientData clientData, Tcl_LimitHandlerDeleteProc *deleteProc); /* 520 */ void (*tcl_LimitRemoveHandler) (Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, ClientData clientData); /* 521 */ int (*tcl_LimitReady) (Tcl_Interp *interp); /* 522 */ @@ -2477,12 +2528,11 @@ typedef struct TclStubs { void * (*tcl_FindSymbol) (Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol); /* 628 */ int (*tcl_FSUnloadFile) (Tcl_Interp *interp, Tcl_LoadHandle handlePtr); /* 629 */ void (*tcl_ZlibStreamSetCompressionDictionary) (Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); /* 630 */ + Tcl_Channel (*tcl_OpenTcpServerEx) (Tcl_Interp *interp, const char *service, const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData); /* 631 */ } TclStubs; -#ifdef __cplusplus -extern "C" { -#endif extern const TclStubs *tclStubsPtr; + #ifdef __cplusplus } #endif @@ -2511,7 +2561,7 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_DbCkfree) /* 7 */ #define Tcl_DbCkrealloc \ (tclStubsPtr->tcl_DbCkrealloc) /* 8 */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ #define Tcl_CreateFileHandler \ (tclStubsPtr->tcl_CreateFileHandler) /* 9 */ #endif /* UNIX */ @@ -2519,7 +2569,7 @@ extern const TclStubs *tclStubsPtr; #define Tcl_CreateFileHandler \ (tclStubsPtr->tcl_CreateFileHandler) /* 9 */ #endif /* MACOSX */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ #define Tcl_DeleteFileHandler \ (tclStubsPtr->tcl_DeleteFileHandler) /* 10 */ #endif /* UNIX */ @@ -2839,7 +2889,7 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_GetNameOfExecutable) /* 165 */ #define Tcl_GetObjResult \ (tclStubsPtr->tcl_GetObjResult) /* 166 */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ #define Tcl_GetOpenFile \ (tclStubsPtr->tcl_GetOpenFile) /* 167 */ #endif /* UNIX */ @@ -3771,6 +3821,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_FSUnloadFile) /* 629 */ #define Tcl_ZlibStreamSetCompressionDictionary \ (tclStubsPtr->tcl_ZlibStreamSetCompressionDictionary) /* 630 */ +#define Tcl_OpenTcpServerEx \ + (tclStubsPtr->tcl_OpenTcpServerEx) /* 631 */ #endif /* defined(USE_TCL_STUBS) */ @@ -3782,16 +3834,12 @@ extern const TclStubs *tclStubsPtr; # undef Tcl_GetStringResult # undef Tcl_Init # undef Tcl_SetPanicProc -# undef Tcl_SetVar # undef Tcl_ObjSetVar2 # undef Tcl_StaticPackage -# undef TclFSGetNativePath # define Tcl_CreateInterp() (tclStubsPtr->tcl_CreateInterp()) # define Tcl_GetStringResult(interp) (tclStubsPtr->tcl_GetStringResult(interp)) # define Tcl_Init(interp) (tclStubsPtr->tcl_Init(interp)) # define Tcl_SetPanicProc(proc) (tclStubsPtr->tcl_SetPanicProc(proc)) -# define Tcl_SetVar(interp, varName, newValue, flags) \ - (tclStubsPtr->tcl_SetVar(interp, varName, newValue, flags)) # define Tcl_ObjSetVar2(interp, part1, part2, newValue, flags) \ (tclStubsPtr->tcl_ObjSetVar2(interp, part1, part2, newValue, flags)) #endif @@ -3824,13 +3872,13 @@ extern const TclStubs *tclStubsPtr; sizeof(char *), msg, flags, indexPtr) #undef Tcl_NewBooleanObj #define Tcl_NewBooleanObj(boolValue) \ - Tcl_NewIntObj((boolValue)!=0) + Tcl_NewLongObj((boolValue)!=0) #undef Tcl_DbNewBooleanObj #define Tcl_DbNewBooleanObj(boolValue, file, line) \ Tcl_DbNewLongObj((boolValue)!=0, file, line) #undef Tcl_SetBooleanObj #define Tcl_SetBooleanObj(objPtr, boolValue) \ - Tcl_SetIntObj((objPtr), (boolValue)!=0) + Tcl_SetLongObj(objPtr, (boolValue)!=0) #undef Tcl_SetVar #define Tcl_SetVar(interp, varName, newValue, flags) \ Tcl_SetVar2(interp, varName, NULL, newValue, flags) @@ -3852,6 +3900,51 @@ extern const TclStubs *tclStubsPtr; #undef Tcl_UpVar #define Tcl_UpVar(interp, frameName, varName, localName, flags) \ Tcl_UpVar2(interp, frameName, varName, NULL, localName, flags) +#undef Tcl_AddErrorInfo +#define Tcl_AddErrorInfo(interp, message) \ + Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, -1)) +#undef Tcl_AddObjErrorInfo +#define Tcl_AddObjErrorInfo(interp, message, length) \ + Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, length)) +#ifdef TCL_NO_DEPRECATED +#undef Tcl_Eval +#define Tcl_Eval(interp, objPtr) \ + Tcl_EvalEx(interp, objPtr, -1, 0) +#undef Tcl_GlobalEval +#define Tcl_GlobalEval(interp, objPtr) \ + Tcl_EvalEx(interp, objPtr, -1, TCL_EVAL_GLOBAL) +#undef Tcl_SaveResult +#define Tcl_SaveResult(interp, statePtr) \ + do { \ + (statePtr)->objResultPtr = Tcl_GetObjResult(interp); \ + Tcl_IncrRefCount((statePtr)->objResultPtr); \ + Tcl_SetObjResult(interp, Tcl_NewObj()); \ + } while(0) +#undef Tcl_RestoreResult +#define Tcl_RestoreResult(interp, statePtr) \ + do { \ + Tcl_ResetResult(interp); \ + Tcl_SetObjResult(interp, (statePtr)->objResultPtr); \ + Tcl_DecrRefCount((statePtr)->objResultPtr); \ + } while(0) +#undef Tcl_DiscardResult +#define Tcl_DiscardResult(statePtr) \ + Tcl_DecrRefCount((statePtr)->objResultPtr) +#undef Tcl_SetResult +#define Tcl_SetResult(interp, result, freeProc) \ + do { \ + char *__result = result; \ + Tcl_FreeProc *__freeProc = freeProc; \ + Tcl_SetObjResult(interp, Tcl_NewStringObj(__result, -1)); \ + if (__result != NULL && __freeProc != NULL && __freeProc != TCL_VOLATILE) { \ + if (__freeProc == TCL_DYNAMIC) { \ + ckfree(__result); \ + } else { \ + (*__freeProc)(__result); \ + } \ + } \ + } while(0) +#endif /* TCL_NO_DEPRECATED */ #if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) # if defined(__CYGWIN__) && defined(TCL_WIDE_INT_IS_LONG) @@ -3862,20 +3955,14 @@ extern const TclStubs *tclStubsPtr; * possible. Tcl 9 must find a better solution, but that cannot be done * without introducing a binary incompatibility. */ -# undef Tcl_DbNewLongObj # undef Tcl_GetLongFromObj -# undef Tcl_NewLongObj -# undef Tcl_SetLongObj # undef Tcl_ExprLong # undef Tcl_ExprLongObj # undef Tcl_UniCharNcmp # undef Tcl_UtfNcmp # undef Tcl_UtfNcasecmp # undef Tcl_UniCharNcasecmp -# define Tcl_DbNewLongObj ((Tcl_Obj*(*)(long,const char*,int))Tcl_DbNewWideIntObj) # define Tcl_GetLongFromObj ((int(*)(Tcl_Interp*,Tcl_Obj*,long*))Tcl_GetWideIntFromObj) -# define Tcl_NewLongObj ((Tcl_Obj*(*)(long))Tcl_NewWideIntObj) -# define Tcl_SetLongObj ((void(*)(Tcl_Obj*,long))Tcl_SetWideIntObj) # define Tcl_ExprLong TclExprLong static inline int TclExprLong(Tcl_Interp *interp, const char *string, long *ptr){ int intValue; @@ -3901,15 +3988,28 @@ extern const TclStubs *tclStubsPtr; # endif #endif +#undef Tcl_NewLongObj +#define Tcl_NewLongObj(value) Tcl_NewWideIntObj((long)(value)) +#undef Tcl_NewIntObj +#define Tcl_NewIntObj(value) Tcl_NewWideIntObj((int)(value)) +#undef Tcl_DbNewLongObj +#define Tcl_DbNewLongObj(value, file, line) Tcl_DbNewWideIntObj((long)(value), file, line) +#undef Tcl_SetIntObj +#define Tcl_SetIntObj(objPtr, value) Tcl_SetWideIntObj((objPtr), (int)(value)) +#undef Tcl_SetLongObj +#define Tcl_SetLongObj(objPtr, value) Tcl_SetWideIntObj((objPtr), (long)(value)) +#undef Tcl_GetUnicode +#define Tcl_GetUnicode(objPtr) Tcl_GetUnicodeFromObj((objPtr), NULL) + /* * Deprecated Tcl procedures: */ #undef Tcl_EvalObj -#define Tcl_EvalObj(interp,objPtr) \ - Tcl_EvalObjEx((interp),(objPtr),0) +#define Tcl_EvalObj(interp, objPtr) \ + Tcl_EvalObjEx(interp, objPtr, 0) #undef Tcl_GlobalEvalObj -#define Tcl_GlobalEvalObj(interp,objPtr) \ - Tcl_EvalObjEx((interp),(objPtr),TCL_EVAL_GLOBAL) +#define Tcl_GlobalEvalObj(interp, objPtr) \ + Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL) #endif /* _TCLDECLS */ diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index e31d708..1d952ec 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -70,18 +70,12 @@ static inline void DeleteChainTable(struct Dict *dict); static inline Tcl_HashEntry *CreateChainEntry(struct Dict *dict, Tcl_Obj *keyPtr, int *newPtr); static inline int DeleteChainEntry(struct Dict *dict, Tcl_Obj *keyPtr); -static int FinalizeDictUpdate(ClientData data[], - Tcl_Interp *interp, int result); -static int FinalizeDictWith(ClientData data[], - Tcl_Interp *interp, int result); -static int DictForNRCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const *objv); -static int DictMapNRCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const *objv); -static int DictForLoopCallback(ClientData data[], - Tcl_Interp *interp, int result); -static int DictMapLoopCallback(ClientData data[], - Tcl_Interp *interp, int result); +static Tcl_NRPostProc FinalizeDictUpdate; +static Tcl_NRPostProc FinalizeDictWith; +static Tcl_ObjCmdProc DictForNRCmd; +static Tcl_ObjCmdProc DictMapNRCmd; +static Tcl_NRPostProc DictForLoopCallback; +static Tcl_NRPostProc DictMapLoopCallback; /* * Table of dict subcommand names and implementations. @@ -147,14 +141,21 @@ typedef struct Dict { * the dictionary. Used for doing traversal of * the entries in the order that they are * created. */ - int epoch; /* Epoch counter */ - int refcount; /* Reference counter (see above) */ + unsigned int epoch; /* Epoch counter */ + size_t refCount; /* Reference counter (see above) */ Tcl_Obj *chain; /* Linked list used for invalidating the * string representations of updated nested * dictionaries. */ } Dict; /* + * Accessor macro for converting between a Tcl_Obj* and a Dict. Note that this + * must be assignable as well as readable. + */ + +#define DICT(dictObj) ((dictObj)->internalRep.twoPtrValue.ptr1) + +/* * The structure below defines the dictionary object type by means of * functions that can be invoked by generic object code. */ @@ -312,6 +313,7 @@ DeleteChainEntry( return 0; } else { Tcl_Obj *valuePtr = Tcl_GetHashValue(&cPtr->entry); + TclDecrRefCount(valuePtr); } @@ -361,7 +363,7 @@ DupDictInternalRep( Tcl_Obj *srcPtr, Tcl_Obj *copyPtr) { - Dict *oldDict = srcPtr->internalRep.twoPtrValue.ptr1; + Dict *oldDict = DICT(srcPtr); Dict *newDict = ckalloc(sizeof(Dict)); ChainEntry *cPtr; @@ -388,15 +390,16 @@ DupDictInternalRep( * Initialise other fields. */ - newDict->epoch = 0; + newDict->epoch = 1; newDict->chain = NULL; - newDict->refcount = 1; + newDict->refCount = 1; /* * Store in the object. */ - copyPtr->internalRep.twoPtrValue.ptr1 = newDict; + DICT(copyPtr) = newDict; + copyPtr->internalRep.twoPtrValue.ptr2 = NULL; copyPtr->typePtr = &tclDictType; } @@ -422,10 +425,9 @@ static void FreeDictInternalRep( Tcl_Obj *dictPtr) { - Dict *dict = dictPtr->internalRep.twoPtrValue.ptr1; + Dict *dict = DICT(dictPtr); - dict->refcount--; - if (dict->refcount <= 0) { + if (dict->refCount-- <= 1) { DeleteDict(dict); } dictPtr->typePtr = NULL; @@ -485,15 +487,14 @@ static void UpdateStringOfDict( Tcl_Obj *dictPtr) { -#define LOCAL_SIZE 20 - int localFlags[LOCAL_SIZE], *flagPtr = NULL; - Dict *dict = dictPtr->internalRep.twoPtrValue.ptr1; +#define LOCAL_SIZE 64 + char localFlags[LOCAL_SIZE], *flagPtr = NULL; + Dict *dict = DICT(dictPtr); ChainEntry *cPtr; Tcl_Obj *keyPtr, *valuePtr; int i, length, bytesNeeded = 0; const char *elem; char *dst; - const int maxFlags = UINT_MAX / sizeof(int); /* * This field is the most useful one in the whole hash structure, and it @@ -504,7 +505,7 @@ UpdateStringOfDict( /* Handle empty list case first, simplifies what follows */ if (numElems == 0) { - dictPtr->bytes = tclEmptyStringRep; + dictPtr->bytes = &tclEmptyString; dictPtr->length = 0; return; } @@ -515,10 +516,8 @@ UpdateStringOfDict( if (numElems <= LOCAL_SIZE) { flagPtr = localFlags; - } else if (numElems > maxFlags) { - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } else { - flagPtr = ckalloc(numElems * sizeof(int)); + flagPtr = ckalloc(numElems); } for (i=0,cPtr=dict->entryChainHead; i<numElems; i+=2,cPtr=cPtr->nextPtr) { /* @@ -600,7 +599,7 @@ SetDictFromAny( Tcl_Obj *objPtr) { Tcl_HashEntry *hPtr; - int isNew, result; + int isNew; Dict *dict = ckalloc(sizeof(Dict)); InitChainTable(dict); @@ -622,7 +621,7 @@ SetDictFromAny( } for (i=0 ; i<objc ; i+=2) { - + /* Store key and value in the hash table we're building. */ hPtr = CreateChainEntry(dict, objv[i], &isNew); if (!isNew) { @@ -651,10 +650,9 @@ SetDictFromAny( const char *elemStart; int elemSize, literal; - result = TclFindElement(interp, nextElem, (limit - nextElem), - &elemStart, &nextElem, &elemSize, &literal); - if (result != TCL_OK) { - goto errorExit; + if (TclFindDictElement(interp, nextElem, (limit - nextElem), + &elemStart, &nextElem, &elemSize, &literal) != TCL_OK) { + goto errorInFindDictElement; } if (elemStart == limit) { break; @@ -673,11 +671,10 @@ SetDictFromAny( keyPtr->bytes); } - result = TclFindElement(interp, nextElem, (limit - nextElem), - &elemStart, &nextElem, &elemSize, &literal); - if (result != TCL_OK) { + if (TclFindDictElement(interp, nextElem, (limit - nextElem), + &elemStart, &nextElem, &elemSize, &literal) != TCL_OK) { TclDecrRefCount(keyPtr); - goto errorExit; + goto errorInFindDictElement; } if (literal) { @@ -710,10 +707,11 @@ SetDictFromAny( */ TclFreeIntRep(objPtr); - dict->epoch = 0; + dict->epoch = 1; dict->chain = NULL; - dict->refcount = 1; - objPtr->internalRep.twoPtrValue.ptr1 = dict; + dict->refCount = 1; + DICT(objPtr) = dict; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = &tclDictType; return TCL_OK; @@ -723,15 +721,10 @@ SetDictFromAny( "missing value to go with key", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL); } - result = TCL_ERROR; - - errorExit: - if (interp != NULL) { - Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL); - } + errorInFindDictElement: DeleteChainTable(dict); ckfree(dict); - return result; + return TCL_ERROR; } /* @@ -777,12 +770,11 @@ TclTraceDictPath( Dict *dict, *newDict; int i; - if (dictPtr->typePtr != &tclDictType) { - if (SetDictFromAny(interp, dictPtr) != TCL_OK) { - return NULL; - } + if (dictPtr->typePtr != &tclDictType + && SetDictFromAny(interp, dictPtr) != TCL_OK) { + return NULL; } - dict = dictPtr->internalRep.twoPtrValue.ptr1; + dict = DICT(dictPtr); if (flags & DICT_PATH_UPDATE) { dict->chain = NULL; } @@ -818,14 +810,13 @@ TclTraceDictPath( Tcl_SetHashValue(hPtr, tmpObj); } else { tmpObj = Tcl_GetHashValue(hPtr); - if (tmpObj->typePtr != &tclDictType) { - if (SetDictFromAny(interp, tmpObj) != TCL_OK) { - return NULL; - } + if (tmpObj->typePtr != &tclDictType + && SetDictFromAny(interp, tmpObj) != TCL_OK) { + return NULL; } } - newDict = tmpObj->internalRep.twoPtrValue.ptr1; + newDict = DICT(tmpObj); if (flags & DICT_PATH_UPDATE) { if (Tcl_IsShared(tmpObj)) { TclDecrRefCount(tmpObj); @@ -833,7 +824,7 @@ TclTraceDictPath( Tcl_IncrRefCount(tmpObj); Tcl_SetHashValue(hPtr, tmpObj); dict->epoch++; - newDict = tmpObj->internalRep.twoPtrValue.ptr1; + newDict = DICT(tmpObj); } newDict->chain = dictPtr; @@ -868,7 +859,7 @@ static void InvalidateDictChain( Tcl_Obj *dictObj) { - Dict *dict = dictObj->internalRep.twoPtrValue.ptr1; + Dict *dict = DICT(dictObj); do { TclInvalidateStringRep(dictObj); @@ -878,7 +869,7 @@ InvalidateDictChain( break; } dict->chain = NULL; - dict = dictObj->internalRep.twoPtrValue.ptr1; + dict = DICT(dictObj); } while (dict != NULL); } @@ -916,18 +907,15 @@ Tcl_DictObjPut( Tcl_Panic("%s called with shared object", "Tcl_DictObjPut"); } - if (dictPtr->typePtr != &tclDictType) { - int result = SetDictFromAny(interp, dictPtr); - - if (result != TCL_OK) { - return result; - } + if (dictPtr->typePtr != &tclDictType + && SetDictFromAny(interp, dictPtr) != TCL_OK) { + return TCL_ERROR; } if (dictPtr->bytes != NULL) { TclInvalidateStringRep(dictPtr); } - dict = dictPtr->internalRep.twoPtrValue.ptr1; + dict = DICT(dictPtr); hPtr = CreateChainEntry(dict, keyPtr, &isNew); Tcl_IncrRefCount(valuePtr); if (!isNew) { @@ -970,15 +958,13 @@ Tcl_DictObjGet( Dict *dict; Tcl_HashEntry *hPtr; - if (dictPtr->typePtr != &tclDictType) { - int result = SetDictFromAny(interp, dictPtr); - if (result != TCL_OK) { - *valuePtrPtr = NULL; - return result; - } + if (dictPtr->typePtr != &tclDictType + && SetDictFromAny(interp, dictPtr) != TCL_OK) { + *valuePtrPtr = NULL; + return TCL_ERROR; } - dict = dictPtr->internalRep.twoPtrValue.ptr1; + dict = DICT(dictPtr); hPtr = Tcl_FindHashEntry(&dict->table, keyPtr); if (hPtr == NULL) { *valuePtrPtr = NULL; @@ -1019,18 +1005,16 @@ Tcl_DictObjRemove( Tcl_Panic("%s called with shared object", "Tcl_DictObjRemove"); } - if (dictPtr->typePtr != &tclDictType) { - int result = SetDictFromAny(interp, dictPtr); - if (result != TCL_OK) { - return result; - } + if (dictPtr->typePtr != &tclDictType + && SetDictFromAny(interp, dictPtr) != TCL_OK) { + return TCL_ERROR; } - if (dictPtr->bytes != NULL) { - TclInvalidateStringRep(dictPtr); - } - dict = dictPtr->internalRep.twoPtrValue.ptr1; + dict = DICT(dictPtr); if (DeleteChainEntry(dict, keyPtr)) { + if (dictPtr->bytes != NULL) { + TclInvalidateStringRep(dictPtr); + } dict->epoch++; } return TCL_OK; @@ -1062,14 +1046,12 @@ Tcl_DictObjSize( { Dict *dict; - if (dictPtr->typePtr != &tclDictType) { - int result = SetDictFromAny(interp, dictPtr); - if (result != TCL_OK) { - return result; - } + if (dictPtr->typePtr != &tclDictType + && SetDictFromAny(interp, dictPtr) != TCL_OK) { + return TCL_ERROR; } - dict = dictPtr->internalRep.twoPtrValue.ptr1; + dict = DICT(dictPtr); *sizePtr = dict->table.numEntries; return TCL_OK; } @@ -1116,25 +1098,22 @@ Tcl_DictObjFirst( Dict *dict; ChainEntry *cPtr; - if (dictPtr->typePtr != &tclDictType) { - int result = SetDictFromAny(interp, dictPtr); - - if (result != TCL_OK) { - return result; - } + if (dictPtr->typePtr != &tclDictType + && SetDictFromAny(interp, dictPtr) != TCL_OK) { + return TCL_ERROR; } - dict = dictPtr->internalRep.twoPtrValue.ptr1; + dict = DICT(dictPtr); cPtr = dict->entryChainHead; if (cPtr == NULL) { - searchPtr->epoch = -1; + searchPtr->epoch = 0; *donePtr = 1; } else { *donePtr = 0; searchPtr->dictionaryPtr = (Tcl_Dict) dict; searchPtr->epoch = dict->epoch; searchPtr->next = cPtr->nextPtr; - dict->refcount++; + dict->refCount++; if (keyPtrPtr != NULL) { *keyPtrPtr = Tcl_GetHashKey(&dict->table, &cPtr->entry); } @@ -1188,7 +1167,7 @@ Tcl_DictObjNext( * If the searh is done; we do no work. */ - if (searchPtr->epoch == -1) { + if (!searchPtr->epoch) { *donePtr = 1; return; } @@ -1245,11 +1224,10 @@ Tcl_DictObjDone( { Dict *dict; - if (searchPtr->epoch != -1) { - searchPtr->epoch = -1; + if (searchPtr->epoch) { + searchPtr->epoch = 0; dict = (Dict *) searchPtr->dictionaryPtr; - dict->refcount--; - if (dict->refcount <= 0) { + if (dict->refCount-- <= 1) { DeleteDict(dict); } } @@ -1299,11 +1277,12 @@ Tcl_DictObjPutKeyList( return TCL_ERROR; } - dict = dictPtr->internalRep.twoPtrValue.ptr1; + dict = DICT(dictPtr); hPtr = CreateChainEntry(dict, keyv[keyc-1], &isNew); Tcl_IncrRefCount(valuePtr); if (!isNew) { Tcl_Obj *oldValuePtr = Tcl_GetHashValue(hPtr); + TclDecrRefCount(oldValuePtr); } Tcl_SetHashValue(hPtr, valuePtr); @@ -1355,7 +1334,7 @@ Tcl_DictObjRemoveKeyList( return TCL_ERROR; } - dict = dictPtr->internalRep.twoPtrValue.ptr1; + dict = DICT(dictPtr); DeleteChainEntry(dict, keyv[keyc-1]); InvalidateDictChain(dictPtr); return TCL_OK; @@ -1398,10 +1377,11 @@ Tcl_NewDictObj(void) TclInvalidateStringRep(dictPtr); dict = ckalloc(sizeof(Dict)); InitChainTable(dict); - dict->epoch = 0; + dict->epoch = 1; dict->chain = NULL; - dict->refcount = 1; - dictPtr->internalRep.twoPtrValue.ptr1 = dict; + dict->refCount = 1; + DICT(dictPtr) = dict; + dictPtr->internalRep.twoPtrValue.ptr2 = NULL; dictPtr->typePtr = &tclDictType; return dictPtr; #endif @@ -1447,10 +1427,11 @@ Tcl_DbNewDictObj( TclInvalidateStringRep(dictPtr); dict = ckalloc(sizeof(Dict)); InitChainTable(dict); - dict->epoch = 0; + dict->epoch = 1; dict->chain = NULL; - dict->refcount = 1; - dictPtr->internalRep.twoPtrValue.ptr1 = dict; + dict->refCount = 1; + DICT(dictPtr) = dict; + dictPtr->internalRep.twoPtrValue.ptr2 = NULL; dictPtr->typePtr = &tclDictType; return dictPtr; #else /* !TCL_MEM_DEBUG */ @@ -1504,7 +1485,7 @@ DictCreateCmd( /* * The next command is assumed to never fail... */ - Tcl_DictObjPut(interp, dictObj, objv[i], objv[i+1]); + Tcl_DictObjPut(NULL, dictObj, objv[i], objv[i+1]); } Tcl_SetObjResult(interp, dictObj); return TCL_OK; @@ -1629,8 +1610,7 @@ DictReplaceCmd( Tcl_Obj *const *objv) { Tcl_Obj *dictPtr; - int i, result; - int allocatedDict = 0; + int i; if ((objc < 2) || (objc & 1)) { Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key value ...?"); @@ -1638,18 +1618,18 @@ DictReplaceCmd( } dictPtr = objv[1]; + if (dictPtr->typePtr != &tclDictType + && SetDictFromAny(interp, dictPtr) != TCL_OK) { + return TCL_ERROR; + } if (Tcl_IsShared(dictPtr)) { dictPtr = Tcl_DuplicateObj(dictPtr); - allocatedDict = 1; + } + if (dictPtr->bytes != NULL) { + TclInvalidateStringRep(dictPtr); } for (i=2 ; i<objc ; i+=2) { - result = Tcl_DictObjPut(interp, dictPtr, objv[i], objv[i+1]); - if (result != TCL_OK) { - if (allocatedDict) { - TclDecrRefCount(dictPtr); - } - return TCL_ERROR; - } + Tcl_DictObjPut(NULL, dictPtr, objv[i], objv[i+1]); } Tcl_SetObjResult(interp, dictPtr); return TCL_OK; @@ -1681,8 +1661,7 @@ DictRemoveCmd( Tcl_Obj *const *objv) { Tcl_Obj *dictPtr; - int i, result; - int allocatedDict = 0; + int i; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key ...?"); @@ -1690,18 +1669,18 @@ DictRemoveCmd( } dictPtr = objv[1]; + if (dictPtr->typePtr != &tclDictType + && SetDictFromAny(interp, dictPtr) != TCL_OK) { + return TCL_ERROR; + } if (Tcl_IsShared(dictPtr)) { dictPtr = Tcl_DuplicateObj(dictPtr); - allocatedDict = 1; + } + if (dictPtr->bytes != NULL) { + TclInvalidateStringRep(dictPtr); } for (i=2 ; i<objc ; i++) { - result = Tcl_DictObjRemove(interp, dictPtr, objv[i]); - if (result != TCL_OK) { - if (allocatedDict) { - TclDecrRefCount(dictPtr); - } - return TCL_ERROR; - } + Tcl_DictObjRemove(NULL, dictPtr, objv[i]); } Tcl_SetObjResult(interp, dictPtr); return TCL_OK; @@ -1750,10 +1729,9 @@ DictMergeCmd( */ targetObj = objv[1]; - if (targetObj->typePtr != &tclDictType) { - if (SetDictFromAny(interp, targetObj) != TCL_OK) { - return TCL_ERROR; - } + if (targetObj->typePtr != &tclDictType + && SetDictFromAny(interp, targetObj) != TCL_OK) { + return TCL_ERROR; } if (objc == 2) { @@ -1835,12 +1813,9 @@ DictKeysCmd( * need. [Bug 1705778, leak K04] */ - if (objv[1]->typePtr != &tclDictType) { - int result = SetDictFromAny(interp, objv[1]); - - if (result != TCL_OK) { - return result; - } + if (objv[1]->typePtr != &tclDictType + && SetDictFromAny(interp, objv[1]) != TCL_OK) { + return TCL_ERROR; } if (objc == 3) { @@ -2056,13 +2031,11 @@ DictInfoCmd( } dictPtr = objv[1]; - if (dictPtr->typePtr != &tclDictType) { - int result = SetDictFromAny(interp, dictPtr); - if (result != TCL_OK) { - return result; - } + if (dictPtr->typePtr != &tclDictType + && SetDictFromAny(interp, dictPtr) != TCL_OK) { + return TCL_ERROR; } - dict = dictPtr->internalRep.twoPtrValue.ptr1; + dict = DICT(dictPtr); statsStr = Tcl_HashStats(&dict->table); Tcl_SetObjResult(interp, Tcl_NewStringObj(statsStr, -1)); @@ -2099,7 +2072,7 @@ DictIncrCmd( Tcl_Obj *dictPtr, *valuePtr = NULL; if (objc < 3 || objc > 4) { - Tcl_WrongNumArgs(interp, 1, objv, "varName key ?increment?"); + Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?increment?"); return TCL_ERROR; } @@ -2152,10 +2125,10 @@ DictIncrCmd( */ mp_clear(&increment); - Tcl_DictObjPut(interp, dictPtr, objv[2], objv[3]); + Tcl_DictObjPut(NULL, dictPtr, objv[2], objv[3]); } } else { - Tcl_DictObjPut(interp, dictPtr, objv[2], Tcl_NewIntObj(1)); + Tcl_DictObjPut(NULL, dictPtr, objv[2], Tcl_NewIntObj(1)); } } else { /* @@ -2164,7 +2137,7 @@ DictIncrCmd( if (Tcl_IsShared(valuePtr)) { valuePtr = Tcl_DuplicateObj(valuePtr); - Tcl_DictObjPut(interp, dictPtr, objv[2], valuePtr); + Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr); } if (objc == 4) { code = TclIncrObj(interp, valuePtr, objv[3]); @@ -2173,7 +2146,7 @@ DictIncrCmd( Tcl_IncrRefCount(incrPtr); code = TclIncrObj(interp, valuePtr, incrPtr); - Tcl_DecrRefCount(incrPtr); + TclDecrRefCount(incrPtr); } } if (code == TCL_OK) { @@ -2186,7 +2159,7 @@ DictIncrCmd( Tcl_SetObjResult(interp, valuePtr); } } else if (dictPtr->refCount == 0) { - Tcl_DecrRefCount(dictPtr); + TclDecrRefCount(dictPtr); } return code; } @@ -2220,7 +2193,7 @@ DictLappendCmd( int i, allocatedDict = 0, allocatedValue = 0; if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "varName key ?value ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?value ...?"); return TCL_ERROR; } @@ -2264,7 +2237,7 @@ DictLappendCmd( } if (allocatedValue) { - Tcl_DictObjPut(interp, dictPtr, objv[2], valuePtr); + Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr); } else if (dictPtr->bytes != NULL) { TclInvalidateStringRep(dictPtr); } @@ -2304,10 +2277,10 @@ DictAppendCmd( Tcl_Obj *const *objv) { Tcl_Obj *dictPtr, *valuePtr, *resultPtr; - int i, allocatedDict = 0; + int allocatedDict = 0; if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "varName key ?value ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?value ...?"); return TCL_ERROR; } @@ -2327,19 +2300,49 @@ DictAppendCmd( return TCL_ERROR; } - if (valuePtr == NULL) { - TclNewObj(valuePtr); - } else { - if (Tcl_IsShared(valuePtr)) { - valuePtr = Tcl_DuplicateObj(valuePtr); + if ((objc > 3) || (valuePtr == NULL)) { + /* Only go through append activites when something will change. */ + Tcl_Obj *appendObjPtr = NULL; + + if (objc > 3) { + /* Something to append */ + + if (objc == 4) { + appendObjPtr = objv[3]; + } else { + appendObjPtr = TclStringCat(interp, objc-3, objv+3, + TCL_STRING_IN_PLACE); + if (appendObjPtr == NULL) { + return TCL_ERROR; + } + } } - } - for (i=3 ; i<objc ; i++) { - Tcl_AppendObjToObj(valuePtr, objv[i]); + if (appendObjPtr == NULL) { + /* => (objc == 3) => (valuePtr == NULL) */ + TclNewObj(valuePtr); + } else if (valuePtr == NULL) { + valuePtr = appendObjPtr; + appendObjPtr = NULL; + } + + if (appendObjPtr) { + if (Tcl_IsShared(valuePtr)) { + valuePtr = Tcl_DuplicateObj(valuePtr); + } + + Tcl_IncrRefCount(appendObjPtr); + Tcl_AppendObjToObj(valuePtr, appendObjPtr); + Tcl_DecrRefCount(appendObjPtr); + } + + Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr); } - Tcl_DictObjPut(interp, dictPtr, objv[2], valuePtr); + /* + * Even if nothing changed, we still overwrite so that variable + * trace expectations are met. + */ resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr, TCL_LEAVE_ERR_MSG); @@ -2383,7 +2386,7 @@ DictForNRCmd( if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, - "{keyVar valueVar} dictionary script"); + "{keyVarName valueVarName} dictionary script"); return TCL_ERROR; } @@ -2397,6 +2400,7 @@ DictForNRCmd( if (varc != 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "must have exactly two variable names", -1)); + Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "for", NULL); return TCL_ERROR; } searchPtr = TclStackAlloc(interp, sizeof(Tcl_DictSearch)); @@ -2430,12 +2434,14 @@ DictForNRCmd( */ Tcl_IncrRefCount(valueObj); - if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, TCL_LEAVE_ERR_MSG) == NULL) { + if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, + TCL_LEAVE_ERR_MSG) == NULL) { TclDecrRefCount(valueObj); goto error; } TclDecrRefCount(valueObj); - if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, TCL_LEAVE_ERR_MSG) == NULL) { + if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, + TCL_LEAVE_ERR_MSG) == NULL) { goto error; } @@ -2574,7 +2580,7 @@ DictMapNRCmd( if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, - "{keyVar valueVar} dictionary script"); + "{keyVarName valueVarName} dictionary script"); return TCL_ERROR; } @@ -2588,6 +2594,7 @@ DictMapNRCmd( if (varc != 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "must have exactly two variable names", -1)); + Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "map", NULL); return TCL_ERROR; } storagePtr = TclStackAlloc(interp, sizeof(DictMapStorage)); @@ -2782,7 +2789,7 @@ DictSetCmd( int result, allocatedDict = 0; if (objc < 4) { - Tcl_WrongNumArgs(interp, 1, objv, "varName key ?key ...? value"); + Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?key ...? value"); return TCL_ERROR; } @@ -2842,7 +2849,7 @@ DictUnsetCmd( int result, allocatedDict = 0; if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "varName key ?key ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?key ...?"); return TCL_ERROR; } @@ -2949,12 +2956,12 @@ DictFilterCmd( Tcl_DictObjDone(&search); Tcl_DictObjGet(interp, objv[1], objv[3], &valueObj); if (valueObj != NULL) { - Tcl_DictObjPut(interp, resultObj, objv[3], valueObj); + Tcl_DictObjPut(NULL, resultObj, objv[3], valueObj); } } else { while (!done) { if (Tcl_StringMatch(TclGetString(keyObj), pattern)) { - Tcl_DictObjPut(interp, resultObj, keyObj, valueObj); + Tcl_DictObjPut(NULL, resultObj, keyObj, valueObj); } Tcl_DictObjNext(&search, &keyObj, &valueObj, &done); } @@ -2972,7 +2979,7 @@ DictFilterCmd( for (i=3 ; i<objc ; i++) { pattern = TclGetString(objv[i]); if (Tcl_StringMatch(TclGetString(keyObj), pattern)) { - Tcl_DictObjPut(interp, resultObj, keyObj, valueObj); + Tcl_DictObjPut(NULL, resultObj, keyObj, valueObj); break; /* stop inner loop */ } } @@ -2998,7 +3005,7 @@ DictFilterCmd( for (i=3 ; i<objc ; i++) { pattern = TclGetString(objv[i]); if (Tcl_StringMatch(TclGetString(valueObj), pattern)) { - Tcl_DictObjPut(interp, resultObj, keyObj, valueObj); + Tcl_DictObjPut(NULL, resultObj, keyObj, valueObj); break; /* stop inner loop */ } } @@ -3010,7 +3017,7 @@ DictFilterCmd( case FILTER_SCRIPT: if (objc != 5) { Tcl_WrongNumArgs(interp, 1, objv, - "dictionary script {keyVar valueVar} filterScript"); + "dictionary script {keyVarName valueVarName} filterScript"); return TCL_ERROR; } @@ -3026,6 +3033,7 @@ DictFilterCmd( if (varc != 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "must have exactly two variable names", -1)); + Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "filter", NULL); return TCL_ERROR; } keyVarObj = varv[0]; @@ -3064,19 +3072,15 @@ DictFilterCmd( Tcl_IncrRefCount(valueObj); if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, TCL_LEAVE_ERR_MSG) == NULL) { - Tcl_ResetResult(interp); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't set key variable: \"%s\"", - TclGetString(keyVarObj))); + Tcl_AddErrorInfo(interp, + "\n (\"dict filter\" filter script key variable)"); result = TCL_ERROR; goto abnormalResult; } if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, TCL_LEAVE_ERR_MSG) == NULL) { - Tcl_ResetResult(interp); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't set value variable: \"%s\"", - TclGetString(valueVarObj))); + Tcl_AddErrorInfo(interp, + "\n (\"dict filter\" filter script value variable)"); result = TCL_ERROR; goto abnormalResult; } @@ -3099,7 +3103,7 @@ DictFilterCmd( } TclDecrRefCount(boolObj); if (satisfied) { - Tcl_DictObjPut(interp, resultObj, keyObj, valueObj); + Tcl_DictObjPut(NULL, resultObj, keyObj, valueObj); } break; case TCL_BREAK: @@ -3190,7 +3194,7 @@ DictUpdateCmd( if (objc < 5 || !(objc & 1)) { Tcl_WrongNumArgs(interp, 1, objv, - "varName key varName ?key varName ...? script"); + "dictVarName key varName ?key varName ...? script"); return TCL_ERROR; } @@ -3287,18 +3291,17 @@ FinalizeDictUpdate( for (i=0 ; i<objc ; i+=2) { objPtr = Tcl_ObjGetVar2(interp, objv[i+1], NULL, 0); if (objPtr == NULL) { - Tcl_DictObjRemove(interp, dictPtr, objv[i]); + Tcl_DictObjRemove(NULL, dictPtr, objv[i]); } else if (objPtr == dictPtr) { /* * Someone is messing us around, trying to build a recursive * structure. [Bug 1786481] */ - Tcl_DictObjPut(interp, dictPtr, objv[i], - Tcl_DuplicateObj(objPtr)); + Tcl_DictObjPut(NULL, dictPtr, objv[i], Tcl_DuplicateObj(objPtr)); } else { /* Shouldn't fail */ - Tcl_DictObjPut(interp, dictPtr, objv[i], objPtr); + Tcl_DictObjPut(NULL, dictPtr, objv[i], objPtr); } } TclDecrRefCount(argsObj); @@ -3347,7 +3350,7 @@ DictWithCmd( Tcl_Obj *dictPtr, *keysPtr, *pathPtr; if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "dictVar ?key ...? script"); + Tcl_WrongNumArgs(interp, 1, objv, "dictVarName ?key ...? script"); return TCL_ERROR; } @@ -3561,7 +3564,7 @@ TclDictWithFinish( * If the dictionary variable doesn't exist, drop everything silently. */ - dictPtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, + dictPtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, index); if (dictPtr == NULL) { return TCL_OK; @@ -3644,8 +3647,8 @@ TclDictWithFinish( * Write back the outermost dictionary to the variable. */ - if (TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, dictPtr, - TCL_LEAVE_ERR_MSG, index) == NULL) { + if (TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, + dictPtr, TCL_LEAVE_ERR_MSG, index) == NULL) { if (allocdict) { TclDecrRefCount(dictPtr); } diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c new file mode 100644 index 0000000..a0d1258 --- /dev/null +++ b/generic/tclDisassemble.c @@ -0,0 +1,1630 @@ +/* + * tclDisassemble.c -- + * + * This file contains procedures that disassemble bytecode into either + * human-readable or Tcl-processable forms. + * + * Copyright (c) 1996-1998 Sun Microsystems, Inc. + * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. + * Copyright (c) 2013-2016 Donal K. Fellows. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tclInt.h" +#include "tclCompile.h" +#include "tclOOInt.h" +#include <assert.h> + +/* + * Prototypes for procedures defined later in this file: + */ + +static Tcl_Obj * DisassembleByteCodeAsDicts(Tcl_Interp *interp, + Tcl_Obj *objPtr); +static Tcl_Obj * DisassembleByteCodeObj(Tcl_Interp *interp, + Tcl_Obj *objPtr); +static int FormatInstruction(ByteCode *codePtr, + const unsigned char *pc, Tcl_Obj *bufferObj); +static void GetLocationInformation(Proc *procPtr, + Tcl_Obj **fileObjPtr, int *linePtr); +static void PrintSourceToObj(Tcl_Obj *appendObj, + const char *stringPtr, int maxChars); +static void UpdateStringOfInstName(Tcl_Obj *objPtr); + +/* + * The structure below defines an instruction name Tcl object to allow + * reporting of inner contexts in errorstack without string allocation. + */ + +static const Tcl_ObjType tclInstNameType = { + "instname", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + UpdateStringOfInstName, /* updateStringProc */ + NULL, /* setFromAnyProc */ +}; + +/* + * How to get the bytecode out of a Tcl_Obj. + */ + +#define BYTECODE(objPtr) \ + ((ByteCode *) (objPtr)->internalRep.twoPtrValue.ptr1) + +/* + *---------------------------------------------------------------------- + * + * GetLocationInformation -- + * + * This procedure looks up the information about where a procedure was + * originally declared. + * + * Results: + * Writes to the variables pointed at by fileObjPtr and linePtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +GetLocationInformation( + Proc *procPtr, /* What to look up the information for. */ + Tcl_Obj **fileObjPtr, /* Where to write the information about what + * file the code came from. Will be written + * to, either with the object (assume shared!) + * that describes what the file was, or with + * NULL if the information is not + * available. */ + int *linePtr) /* Where to write the information about what + * line number represented the start of the + * code in question. Will be written to, + * either with the line number or with -1 if + * the information is not available. */ +{ + CmdFrame *cfPtr = TclGetCmdFrameForProcedure(procPtr); + + *fileObjPtr = NULL; + *linePtr = -1; + if (cfPtr == NULL) { + return; + } + + /* + * Get the source location data out of the CmdFrame. + */ + + *linePtr = cfPtr->line[0]; + if (cfPtr->type == TCL_LOCATION_SOURCE) { + *fileObjPtr = cfPtr->data.eval.path; + } +} + +#ifdef TCL_COMPILE_DEBUG +/* + *---------------------------------------------------------------------- + * + * TclPrintByteCodeObj -- + * + * This procedure prints ("disassembles") the instructions of a bytecode + * object to stdout. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclPrintByteCodeObj( + Tcl_Interp *interp, /* Used only for getting location info. */ + Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ +{ + Tcl_Obj *bufPtr = DisassembleByteCodeObj(interp, objPtr); + + fprintf(stdout, "\n%s", TclGetString(bufPtr)); + Tcl_DecrRefCount(bufPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclPrintInstruction -- + * + * This procedure prints ("disassembles") one instruction from a bytecode + * object to stdout. + * + * Results: + * Returns the length in bytes of the current instruiction. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclPrintInstruction( + ByteCode *codePtr, /* Bytecode containing the instruction. */ + const unsigned char *pc) /* Points to first byte of instruction. */ +{ + Tcl_Obj *bufferObj; + int numBytes; + + TclNewObj(bufferObj); + numBytes = FormatInstruction(codePtr, pc, bufferObj); + fprintf(stdout, "%s", TclGetString(bufferObj)); + Tcl_DecrRefCount(bufferObj); + return numBytes; +} + +/* + *---------------------------------------------------------------------- + * + * TclPrintObject -- + * + * This procedure prints up to a specified number of characters from the + * argument Tcl object's string representation to a specified file. + * + * Results: + * None. + * + * Side effects: + * Outputs characters to the specified file. + * + *---------------------------------------------------------------------- + */ + +void +TclPrintObject( + FILE *outFile, /* The file to print the source to. */ + Tcl_Obj *objPtr, /* Points to the Tcl object whose string + * representation should be printed. */ + int maxChars) /* Maximum number of chars to print. */ +{ + char *bytes; + int length; + + bytes = TclGetStringFromObj(objPtr, &length); + TclPrintSource(outFile, bytes, TclMin(length, maxChars)); +} + +/* + *---------------------------------------------------------------------- + * + * TclPrintSource -- + * + * This procedure prints up to a specified number of characters from the + * argument string to a specified file. It tries to produce legible + * output by adding backslashes as necessary. + * + * Results: + * None. + * + * Side effects: + * Outputs characters to the specified file. + * + *---------------------------------------------------------------------- + */ + +void +TclPrintSource( + FILE *outFile, /* The file to print the source to. */ + const char *stringPtr, /* The string to print. */ + int maxChars) /* Maximum number of chars to print. */ +{ + Tcl_Obj *bufferObj; + + TclNewObj(bufferObj); + PrintSourceToObj(bufferObj, stringPtr, maxChars); + fprintf(outFile, "%s", TclGetString(bufferObj)); + Tcl_DecrRefCount(bufferObj); +} +#endif /* TCL_COMPILE_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * DisassembleByteCodeObj -- + * + * Given an object which is of bytecode type, return a disassembled + * version of the bytecode (in a new refcount 0 object). No guarantees + * are made about the details of the contents of the result. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Obj * +DisassembleByteCodeObj( + Tcl_Interp *interp, + Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ +{ + ByteCode *codePtr = BYTECODE(objPtr); + unsigned char *codeStart, *codeLimit, *pc; + unsigned char *codeDeltaNext, *codeLengthNext; + unsigned char *srcDeltaNext, *srcLengthNext; + int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i, line; + Interp *iPtr = (Interp *) *codePtr->interpHandle; + Tcl_Obj *bufferObj, *fileObj; + + TclNewObj(bufferObj); + if (!codePtr->refCount) { + return bufferObj; /* Already freed. */ + } + + codeStart = codePtr->codeStart; + codeLimit = codeStart + codePtr->numCodeBytes; + numCmds = codePtr->numCommands; + + /* + * Print header lines describing the ByteCode. + */ + + Tcl_AppendPrintfToObj(bufferObj, + "ByteCode %p, refCt %u, epoch %u, interp %p (epoch %u)\n", + codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr, + iPtr->compileEpoch); + Tcl_AppendToObj(bufferObj, " Source ", -1); + PrintSourceToObj(bufferObj, codePtr->source, + TclMin(codePtr->numSrcBytes, 55)); + GetLocationInformation(codePtr->procPtr, &fileObj, &line); + if (line > -1 && fileObj != NULL) { + Tcl_AppendPrintfToObj(bufferObj, "\n File \"%s\" Line %d", + Tcl_GetString(fileObj), line); + } + Tcl_AppendPrintfToObj(bufferObj, + "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", + numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes, + codePtr->numLitObjects, codePtr->numAuxDataItems, + codePtr->maxStackDepth, +#ifdef TCL_COMPILE_STATS + codePtr->numSrcBytes? + codePtr->structureSize/(float)codePtr->numSrcBytes : +#endif + 0.0); + +#ifdef TCL_COMPILE_STATS + Tcl_AppendPrintfToObj(bufferObj, + " Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n", + (unsigned long) codePtr->structureSize, + (unsigned long) (sizeof(ByteCode) - sizeof(size_t) - sizeof(Tcl_Time)), + codePtr->numCodeBytes, + (unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)), + (unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)), + (unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)), + codePtr->numCmdLocBytes); +#endif /* TCL_COMPILE_STATS */ + + /* + * If the ByteCode is the compiled body of a Tcl procedure, print + * information about that procedure. Note that we don't know the + * procedure's name since ByteCode's can be shared among procedures. + */ + + if (codePtr->procPtr != NULL) { + Proc *procPtr = codePtr->procPtr; + int numCompiledLocals = procPtr->numCompiledLocals; + + Tcl_AppendPrintfToObj(bufferObj, + " Proc %p, refCt %u, args %d, compiled locals %d\n", + procPtr, procPtr->refCount, procPtr->numArgs, + numCompiledLocals); + if (numCompiledLocals > 0) { + CompiledLocal *localPtr = procPtr->firstLocalPtr; + + for (i = 0; i < numCompiledLocals; i++) { + Tcl_AppendPrintfToObj(bufferObj, + " slot %d%s%s%s%s%s%s", i, + (localPtr->flags & (VAR_ARRAY|VAR_LINK)) ? "" : ", scalar", + (localPtr->flags & VAR_ARRAY) ? ", array" : "", + (localPtr->flags & VAR_LINK) ? ", link" : "", + (localPtr->flags & VAR_ARGUMENT) ? ", arg" : "", + (localPtr->flags & VAR_TEMPORARY) ? ", temp" : "", + (localPtr->flags & VAR_RESOLVED) ? ", resolved" : ""); + if (TclIsVarTemporary(localPtr)) { + Tcl_AppendToObj(bufferObj, "\n", -1); + } else { + Tcl_AppendPrintfToObj(bufferObj, ", \"%s\"\n", + localPtr->name); + } + localPtr = localPtr->nextPtr; + } + } + } + + /* + * Print the ExceptionRange array. + */ + + if (codePtr->numExceptRanges > 0) { + Tcl_AppendPrintfToObj(bufferObj, " Exception ranges %d, depth %d:\n", + codePtr->numExceptRanges, codePtr->maxExceptDepth); + for (i = 0; i < codePtr->numExceptRanges; i++) { + ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; + + Tcl_AppendPrintfToObj(bufferObj, + " %d: level %d, %s, pc %d-%d, ", + i, rangePtr->nestingLevel, + (rangePtr->type==LOOP_EXCEPTION_RANGE ? "loop" : "catch"), + rangePtr->codeOffset, + (rangePtr->codeOffset + rangePtr->numCodeBytes - 1)); + switch (rangePtr->type) { + case LOOP_EXCEPTION_RANGE: + Tcl_AppendPrintfToObj(bufferObj, "continue %d, break %d\n", + rangePtr->continueOffset, rangePtr->breakOffset); + break; + case CATCH_EXCEPTION_RANGE: + Tcl_AppendPrintfToObj(bufferObj, "catch %d\n", + rangePtr->catchOffset); + break; + default: + Tcl_Panic("DisassembleByteCodeObj: bad ExceptionRange type %d", + rangePtr->type); + } + } + } + + /* + * If there were no commands (e.g., an expression or an empty string was + * compiled), just print all instructions and return. + */ + + if (numCmds == 0) { + pc = codeStart; + while (pc < codeLimit) { + Tcl_AppendToObj(bufferObj, " ", -1); + pc += FormatInstruction(codePtr, pc, bufferObj); + } + return bufferObj; + } + + /* + * Print table showing the code offset, source offset, and source length + * for each command. These are encoded as a sequence of bytes. + */ + + Tcl_AppendPrintfToObj(bufferObj, " Commands %d:", numCmds); + codeDeltaNext = codePtr->codeDeltaStart; + codeLengthNext = codePtr->codeLengthStart; + srcDeltaNext = codePtr->srcDeltaStart; + srcLengthNext = codePtr->srcLengthStart; + codeOffset = srcOffset = 0; + for (i = 0; i < numCmds; i++) { + if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) { + codeDeltaNext++; + delta = TclGetInt4AtPtr(codeDeltaNext); + codeDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(codeDeltaNext); + codeDeltaNext++; + } + codeOffset += delta; + + if ((unsigned) *codeLengthNext == (unsigned) 0xFF) { + codeLengthNext++; + codeLen = TclGetInt4AtPtr(codeLengthNext); + codeLengthNext += 4; + } else { + codeLen = TclGetInt1AtPtr(codeLengthNext); + codeLengthNext++; + } + + if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) { + srcDeltaNext++; + delta = TclGetInt4AtPtr(srcDeltaNext); + srcDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(srcDeltaNext); + srcDeltaNext++; + } + srcOffset += delta; + + if ((unsigned) *srcLengthNext == (unsigned) 0xFF) { + srcLengthNext++; + srcLen = TclGetInt4AtPtr(srcLengthNext); + srcLengthNext += 4; + } else { + srcLen = TclGetInt1AtPtr(srcLengthNext); + srcLengthNext++; + } + + Tcl_AppendPrintfToObj(bufferObj, "%s%4d: pc %d-%d, src %d-%d", + ((i % 2)? " " : "\n "), + (i+1), codeOffset, (codeOffset + codeLen - 1), + srcOffset, (srcOffset + srcLen - 1)); + } + if (numCmds > 0) { + Tcl_AppendToObj(bufferObj, "\n", -1); + } + + /* + * Print each instruction. If the instruction corresponds to the start of + * a command, print the command's source. Note that we don't need the code + * length here. + */ + + codeDeltaNext = codePtr->codeDeltaStart; + srcDeltaNext = codePtr->srcDeltaStart; + srcLengthNext = codePtr->srcLengthStart; + codeOffset = srcOffset = 0; + pc = codeStart; + for (i = 0; i < numCmds; i++) { + if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) { + codeDeltaNext++; + delta = TclGetInt4AtPtr(codeDeltaNext); + codeDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(codeDeltaNext); + codeDeltaNext++; + } + codeOffset += delta; + + if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) { + srcDeltaNext++; + delta = TclGetInt4AtPtr(srcDeltaNext); + srcDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(srcDeltaNext); + srcDeltaNext++; + } + srcOffset += delta; + + if ((unsigned) *srcLengthNext == (unsigned) 0xFF) { + srcLengthNext++; + srcLen = TclGetInt4AtPtr(srcLengthNext); + srcLengthNext += 4; + } else { + srcLen = TclGetInt1AtPtr(srcLengthNext); + srcLengthNext++; + } + + /* + * Print instructions before command i. + */ + + while ((pc-codeStart) < codeOffset) { + Tcl_AppendToObj(bufferObj, " ", -1); + pc += FormatInstruction(codePtr, pc, bufferObj); + } + + Tcl_AppendPrintfToObj(bufferObj, " Command %d: ", i+1); + PrintSourceToObj(bufferObj, (codePtr->source + srcOffset), + TclMin(srcLen, 55)); + Tcl_AppendToObj(bufferObj, "\n", -1); + } + if (pc < codeLimit) { + /* + * Print instructions after the last command. + */ + + while (pc < codeLimit) { + Tcl_AppendToObj(bufferObj, " ", -1); + pc += FormatInstruction(codePtr, pc, bufferObj); + } + } + return bufferObj; +} + +/* + *---------------------------------------------------------------------- + * + * FormatInstruction -- + * + * Appends a representation of a bytecode instruction to a Tcl_Obj. + * + *---------------------------------------------------------------------- + */ + +static int +FormatInstruction( + ByteCode *codePtr, /* Bytecode containing the instruction. */ + const unsigned char *pc, /* Points to first byte of instruction. */ + Tcl_Obj *bufferObj) /* Object to append instruction info to. */ +{ + Proc *procPtr = codePtr->procPtr; + unsigned char opCode = *pc; + register const InstructionDesc *instDesc = &tclInstructionTable[opCode]; + unsigned char *codeStart = codePtr->codeStart; + unsigned pcOffset = pc - codeStart; + int opnd = 0, i, j, numBytes = 1; + int localCt = procPtr ? procPtr->numCompiledLocals : 0; + CompiledLocal *localPtr = procPtr ? procPtr->firstLocalPtr : NULL; + char suffixBuffer[128]; /* Additional info to print after main opcode + * and immediates. */ + char *suffixSrc = NULL; + Tcl_Obj *suffixObj = NULL; + AuxData *auxPtr = NULL; + + suffixBuffer[0] = '\0'; + Tcl_AppendPrintfToObj(bufferObj, "(%u) %s ", pcOffset, instDesc->name); + for (i = 0; i < instDesc->numOperands; i++) { + switch (instDesc->opTypes[i]) { + case OPERAND_INT1: + opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++; + Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); + break; + case OPERAND_INT4: + opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; + Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); + break; + case OPERAND_UINT1: + opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; + Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); + break; + case OPERAND_UINT4: + opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; + if (opCode == INST_START_CMD) { + sprintf(suffixBuffer+strlen(suffixBuffer), + ", %u cmds start here", opnd); + } + Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); + break; + case OPERAND_OFFSET1: + opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++; + sprintf(suffixBuffer, "pc %u", pcOffset+opnd); + Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); + break; + case OPERAND_OFFSET4: + opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; + if (opCode == INST_START_CMD) { + sprintf(suffixBuffer, "next cmd at pc %u", pcOffset+opnd); + } else { + sprintf(suffixBuffer, "pc %u", pcOffset+opnd); + } + Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); + break; + case OPERAND_LIT1: + opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; + suffixObj = codePtr->objArrayPtr[opnd]; + Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); + break; + case OPERAND_LIT4: + opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; + suffixObj = codePtr->objArrayPtr[opnd]; + Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); + break; + case OPERAND_AUX4: + opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; + Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); + auxPtr = &codePtr->auxDataArrayPtr[opnd]; + break; + case OPERAND_IDX4: + opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; + if (opnd >= -1) { + Tcl_AppendPrintfToObj(bufferObj, "%d ", opnd); + } else if (opnd == -2) { + Tcl_AppendPrintfToObj(bufferObj, "end "); + } else { + Tcl_AppendPrintfToObj(bufferObj, "end-%d ", -2-opnd); + } + break; + case OPERAND_LVT1: + opnd = TclGetUInt1AtPtr(pc+numBytes); + numBytes++; + goto printLVTindex; + case OPERAND_LVT4: + opnd = TclGetUInt4AtPtr(pc+numBytes); + numBytes += 4; + printLVTindex: + if (localPtr != NULL) { + if (opnd >= localCt) { + Tcl_Panic("FormatInstruction: bad local var index %u (%u locals)", + (unsigned) opnd, localCt); + } + for (j = 0; j < opnd; j++) { + localPtr = localPtr->nextPtr; + } + if (TclIsVarTemporary(localPtr)) { + sprintf(suffixBuffer, "temp var %u", (unsigned) opnd); + } else { + sprintf(suffixBuffer, "var "); + suffixSrc = localPtr->name; + } + } + Tcl_AppendPrintfToObj(bufferObj, "%%v%u ", (unsigned) opnd); + break; + case OPERAND_SCLS1: + opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; + Tcl_AppendPrintfToObj(bufferObj, "%s ", + tclStringClassTable[opnd].name); + break; + case OPERAND_NONE: + default: + break; + } + } + if (suffixObj) { + const char *bytes; + int length; + + Tcl_AppendToObj(bufferObj, "\t# ", -1); + bytes = TclGetStringFromObj(codePtr->objArrayPtr[opnd], &length); + PrintSourceToObj(bufferObj, bytes, TclMin(length, 40)); + } else if (suffixBuffer[0]) { + Tcl_AppendPrintfToObj(bufferObj, "\t# %s", suffixBuffer); + if (suffixSrc) { + PrintSourceToObj(bufferObj, suffixSrc, 40); + } + } + Tcl_AppendToObj(bufferObj, "\n", -1); + if (auxPtr && auxPtr->type->printProc) { + Tcl_AppendToObj(bufferObj, "\t\t[", -1); + auxPtr->type->printProc(auxPtr->clientData, bufferObj, codePtr, + pcOffset); + Tcl_AppendToObj(bufferObj, "]\n", -1); + } + return numBytes; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetInnerContext -- + * + * If possible, returns a list capturing the inner context. Otherwise + * return NULL. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclGetInnerContext( + Tcl_Interp *interp, + const unsigned char *pc, + Tcl_Obj **tosPtr) +{ + int objc = 0, off = 0; + Tcl_Obj *result; + Interp *iPtr = (Interp *) interp; + + switch (*pc) { + case INST_STR_LEN: + case INST_LNOT: + case INST_BITNOT: + case INST_UMINUS: + case INST_UPLUS: + case INST_TRY_CVT_TO_NUMERIC: + case INST_EXPAND_STKTOP: + case INST_EXPR_STK: + objc = 1; + break; + + case INST_LIST_IN: + case INST_LIST_NOT_IN: /* Basic list containment operators. */ + case INST_STR_EQ: + case INST_STR_NEQ: /* String (in)equality check */ + case INST_STR_CMP: /* String compare. */ + case INST_STR_INDEX: + case INST_STR_MATCH: + case INST_REGEXP: + case INST_EQ: + case INST_NEQ: + case INST_LT: + case INST_GT: + case INST_LE: + case INST_GE: + case INST_MOD: + case INST_LSHIFT: + case INST_RSHIFT: + case INST_BITOR: + case INST_BITXOR: + case INST_BITAND: + case INST_EXPON: + case INST_ADD: + case INST_SUB: + case INST_DIV: + case INST_MULT: + objc = 2; + break; + + case INST_RETURN_STK: + /* early pop. TODO: dig out opt dict too :/ */ + objc = 1; + break; + + case INST_SYNTAX: + case INST_RETURN_IMM: + objc = 2; + break; + + case INST_INVOKE_STK4: + objc = TclGetUInt4AtPtr(pc+1); + break; + + case INST_INVOKE_STK1: + objc = TclGetUInt1AtPtr(pc+1); + break; + } + + result = iPtr->innerContext; + if (Tcl_IsShared(result)) { + Tcl_DecrRefCount(result); + iPtr->innerContext = result = Tcl_NewListObj(objc + 1, NULL); + Tcl_IncrRefCount(result); + } else { + int len; + + /* + * Reset while keeping the list intrep as much as possible. + */ + + Tcl_ListObjLength(interp, result, &len); + Tcl_ListObjReplace(interp, result, 0, len, 0, NULL); + } + Tcl_ListObjAppendElement(NULL, result, TclNewInstNameObj(*pc)); + + for (; objc>0 ; objc--) { + Tcl_Obj *objPtr; + + objPtr = tosPtr[1 - objc + off]; + if (!objPtr) { + Tcl_Panic("InnerContext: bad tos -- appending null object"); + } + if ((objPtr->refCount<=0) +#ifdef TCL_MEM_DEBUG + || (objPtr->refCount==0x61616161) +#endif + ) { + Tcl_Panic("InnerContext: bad tos -- appending freed object %p", + objPtr); + } + Tcl_ListObjAppendElement(NULL, result, objPtr); + } + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclNewInstNameObj -- + * + * Creates a new InstName Tcl_Obj based on the given instruction + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclNewInstNameObj( + unsigned char inst) +{ + Tcl_Obj *objPtr = Tcl_NewObj(); + + objPtr->typePtr = &tclInstNameType; + objPtr->internalRep.wideValue = (long) inst; + objPtr->bytes = NULL; + + return objPtr; +} + +/* + *---------------------------------------------------------------------- + * + * UpdateStringOfInstName -- + * + * Update the string representation for an instruction name object. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateStringOfInstName( + Tcl_Obj *objPtr) +{ + size_t len, inst = (size_t)objPtr->internalRep.wideValue; + char *s, buf[TCL_INTEGER_SPACE + 5]; + + if (inst > LAST_INST_OPCODE) { + sprintf(buf, "inst_%" TCL_Z_MODIFIER "d", inst); + s = buf; + } else { + s = (char *) tclInstructionTable[inst].name; + } + len = strlen(s); + /* assert (len < UINT_MAX) */ + objPtr->bytes = ckalloc(len + 1); + memcpy(objPtr->bytes, s, len + 1); + objPtr->length = len; +} + +/* + *---------------------------------------------------------------------- + * + * PrintSourceToObj -- + * + * Appends a quoted representation of a string to a Tcl_Obj. + * + *---------------------------------------------------------------------- + */ + +static void +PrintSourceToObj( + Tcl_Obj *appendObj, /* The object to print the source to. */ + const char *stringPtr, /* The string to print. */ + int maxChars) /* Maximum number of chars to print. */ +{ + register const char *p; + register int i = 0, len; + Tcl_UniChar ch = 0; + + if (stringPtr == NULL) { + Tcl_AppendToObj(appendObj, "\"\"", -1); + return; + } + + Tcl_AppendToObj(appendObj, "\"", -1); + p = stringPtr; + for (; (*p != '\0') && (i < maxChars); p+=len) { + + len = TclUtfToUniChar(p, &ch); + switch (ch) { + case '"': + Tcl_AppendToObj(appendObj, "\\\"", -1); + i += 2; + continue; + case '\f': + Tcl_AppendToObj(appendObj, "\\f", -1); + i += 2; + continue; + case '\n': + Tcl_AppendToObj(appendObj, "\\n", -1); + i += 2; + continue; + case '\r': + Tcl_AppendToObj(appendObj, "\\r", -1); + i += 2; + continue; + case '\t': + Tcl_AppendToObj(appendObj, "\\t", -1); + i += 2; + continue; + case '\v': + Tcl_AppendToObj(appendObj, "\\v", -1); + i += 2; + continue; + default: +#if TCL_UTF_MAX > 4 + if (ch > 0xffff) { + Tcl_AppendPrintfToObj(appendObj, "\\U%08x", ch); + i += 10; + } else +#else + /* If len == 0, this means we have a char > 0xffff, resulting in + * TclUtfToUniChar producing a surrogate pair. We want to output + * this pair as a single Unicode character. + */ + if (len == 0) { + int upper = ((ch & 0x3ff) + 1) << 10; + len = TclUtfToUniChar(p, &ch); + Tcl_AppendPrintfToObj(appendObj, "\\U%08x", upper + (ch & 0x3ff)); + i += 10; + } else +#endif + if (ch < 0x20 || ch >= 0x7f) { + Tcl_AppendPrintfToObj(appendObj, "\\u%04x", ch); + i += 6; + } else { + Tcl_AppendPrintfToObj(appendObj, "%c", ch); + i++; + } + continue; + } + } + if (*p != '\0') { + Tcl_AppendToObj(appendObj, "...", -1); + } + Tcl_AppendToObj(appendObj, "\"", -1); +} + +/* + *---------------------------------------------------------------------- + * + * DisassembleByteCodeAsDicts -- + * + * Given an object which is of bytecode type, return a disassembled + * version of the bytecode (in a new refcount 0 object) in a dictionary. + * No guarantees are made about the details of the contents of the + * result, but it is intended to be more readable than the old output + * format. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Obj * +DisassembleByteCodeAsDicts( + Tcl_Interp *interp, /* Used for looking up the CmdFrame for the + * procedure, if one exists. */ + Tcl_Obj *objPtr) /* The bytecode-holding value to take apart */ +{ + ByteCode *codePtr = BYTECODE(objPtr); + Tcl_Obj *description, *literals, *variables, *instructions, *inst; + Tcl_Obj *aux, *exn, *commands, *file; + unsigned char *pc, *opnd, *codeOffPtr, *codeLenPtr, *srcOffPtr, *srcLenPtr; + int codeOffset, codeLength, sourceOffset, sourceLength; + int i, val, line; + + /* + * Get the literals from the bytecode. + */ + + literals = Tcl_NewObj(); + for (i=0 ; i<codePtr->numLitObjects ; i++) { + Tcl_ListObjAppendElement(NULL, literals, codePtr->objArrayPtr[i]); + } + + /* + * Get the variables from the bytecode. + */ + + variables = Tcl_NewObj(); + if (codePtr->procPtr) { + int localCount = codePtr->procPtr->numCompiledLocals; + CompiledLocal *localPtr = codePtr->procPtr->firstLocalPtr; + + for (i=0 ; i<localCount ; i++,localPtr=localPtr->nextPtr) { + Tcl_Obj *descriptor[2]; + + descriptor[0] = Tcl_NewObj(); + if (!(localPtr->flags & (VAR_ARRAY|VAR_LINK))) { + Tcl_ListObjAppendElement(NULL, descriptor[0], + Tcl_NewStringObj("scalar", -1)); + } + if (localPtr->flags & VAR_ARRAY) { + Tcl_ListObjAppendElement(NULL, descriptor[0], + Tcl_NewStringObj("array", -1)); + } + if (localPtr->flags & VAR_LINK) { + Tcl_ListObjAppendElement(NULL, descriptor[0], + Tcl_NewStringObj("link", -1)); + } + if (localPtr->flags & VAR_ARGUMENT) { + Tcl_ListObjAppendElement(NULL, descriptor[0], + Tcl_NewStringObj("arg", -1)); + } + if (localPtr->flags & VAR_TEMPORARY) { + Tcl_ListObjAppendElement(NULL, descriptor[0], + Tcl_NewStringObj("temp", -1)); + } + if (localPtr->flags & VAR_RESOLVED) { + Tcl_ListObjAppendElement(NULL, descriptor[0], + Tcl_NewStringObj("resolved", -1)); + } + if (localPtr->flags & VAR_TEMPORARY) { + Tcl_ListObjAppendElement(NULL, variables, + Tcl_NewListObj(1, descriptor)); + } else { + descriptor[1] = Tcl_NewStringObj(localPtr->name, -1); + Tcl_ListObjAppendElement(NULL, variables, + Tcl_NewListObj(2, descriptor)); + } + } + } + + /* + * Get the instructions from the bytecode. + */ + + instructions = Tcl_NewObj(); + for (pc=codePtr->codeStart; pc<codePtr->codeStart+codePtr->numCodeBytes;){ + const InstructionDesc *instDesc = &tclInstructionTable[*pc]; + int address = pc - codePtr->codeStart; + + inst = Tcl_NewObj(); + Tcl_ListObjAppendElement(NULL, inst, Tcl_NewStringObj( + instDesc->name, -1)); + opnd = pc + 1; + for (i=0 ; i<instDesc->numOperands ; i++) { + switch (instDesc->opTypes[i]) { + case OPERAND_INT1: + val = TclGetInt1AtPtr(opnd); + opnd += 1; + goto formatNumber; + case OPERAND_UINT1: + val = TclGetUInt1AtPtr(opnd); + opnd += 1; + goto formatNumber; + case OPERAND_INT4: + val = TclGetInt4AtPtr(opnd); + opnd += 4; + goto formatNumber; + case OPERAND_UINT4: + val = TclGetUInt4AtPtr(opnd); + opnd += 4; + formatNumber: + Tcl_ListObjAppendElement(NULL, inst, Tcl_NewIntObj(val)); + break; + + case OPERAND_OFFSET1: + val = TclGetInt1AtPtr(opnd); + opnd += 1; + goto formatAddress; + case OPERAND_OFFSET4: + val = TclGetInt4AtPtr(opnd); + opnd += 4; + formatAddress: + Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( + "pc %d", address + val)); + break; + + case OPERAND_LIT1: + val = TclGetUInt1AtPtr(opnd); + opnd += 1; + goto formatLiteral; + case OPERAND_LIT4: + val = TclGetUInt4AtPtr(opnd); + opnd += 4; + formatLiteral: + Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( + "@%d", val)); + break; + + case OPERAND_LVT1: + val = TclGetUInt1AtPtr(opnd); + opnd += 1; + goto formatVariable; + case OPERAND_LVT4: + val = TclGetUInt4AtPtr(opnd); + opnd += 4; + formatVariable: + Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( + "%%%d", val)); + break; + case OPERAND_IDX4: + val = TclGetInt4AtPtr(opnd); + opnd += 4; + if (val >= -1) { + Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( + ".%d", val)); + } else if (val == -2) { + Tcl_ListObjAppendElement(NULL, inst, Tcl_NewStringObj( + ".end", -1)); + } else { + Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( + ".end-%d", -2-val)); + } + break; + case OPERAND_AUX4: + val = TclGetInt4AtPtr(opnd); + opnd += 4; + Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( + "?%d", val)); + break; + case OPERAND_SCLS1: + val = TclGetUInt1AtPtr(opnd); + opnd++; + Tcl_ListObjAppendElement(NULL, inst, Tcl_ObjPrintf( + "=%s", tclStringClassTable[val].name)); + break; + case OPERAND_NONE: + Tcl_Panic("opcode %d with more than zero 'no' operands", *pc); + } + } + Tcl_DictObjPut(NULL, instructions, Tcl_NewIntObj(address), inst); + pc += instDesc->numBytes; + } + + /* + * Get the auxiliary data from the bytecode. + */ + + aux = Tcl_NewObj(); + for (i=0 ; i<codePtr->numAuxDataItems ; i++) { + AuxData *auxData = &codePtr->auxDataArrayPtr[i]; + Tcl_Obj *auxDesc = Tcl_NewStringObj(auxData->type->name, -1); + + if (auxData->type->disassembleProc) { + Tcl_Obj *desc = Tcl_NewObj(); + + Tcl_DictObjPut(NULL, desc, Tcl_NewStringObj("name", -1), auxDesc); + auxDesc = desc; + auxData->type->disassembleProc(auxData->clientData, auxDesc, + codePtr, 0); + } else if (auxData->type->printProc) { + Tcl_Obj *desc = Tcl_NewObj(); + + auxData->type->printProc(auxData->clientData, desc, codePtr, 0); + Tcl_ListObjAppendElement(NULL, auxDesc, desc); + } + Tcl_ListObjAppendElement(NULL, aux, auxDesc); + } + + /* + * Get the exception ranges from the bytecode. + */ + + exn = Tcl_NewObj(); + for (i=0 ; i<codePtr->numExceptRanges ; i++) { + ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; + + switch (rangePtr->type) { + case LOOP_EXCEPTION_RANGE: + Tcl_ListObjAppendElement(NULL, exn, Tcl_ObjPrintf( + "type %s level %d from %d to %d break %d continue %d", + "loop", rangePtr->nestingLevel, rangePtr->codeOffset, + rangePtr->codeOffset + rangePtr->numCodeBytes - 1, + rangePtr->breakOffset, rangePtr->continueOffset)); + break; + case CATCH_EXCEPTION_RANGE: + Tcl_ListObjAppendElement(NULL, exn, Tcl_ObjPrintf( + "type %s level %d from %d to %d catch %d", + "catch", rangePtr->nestingLevel, rangePtr->codeOffset, + rangePtr->codeOffset + rangePtr->numCodeBytes - 1, + rangePtr->catchOffset)); + break; + } + } + + /* + * Get the command information from the bytecode. + * + * The way these are encoded in the bytecode is non-trivial; the Decode + * macro (which updates its argument and returns the next decoded value) + * handles this so that the rest of the code does not. + */ + +#define Decode(ptr) \ + ((TclGetUInt1AtPtr(ptr) == 0xFF) \ + ? ((ptr)+=5 , TclGetInt4AtPtr((ptr)-4)) \ + : ((ptr)+=1 , TclGetInt1AtPtr((ptr)-1))) + + commands = Tcl_NewObj(); + codeOffPtr = codePtr->codeDeltaStart; + codeLenPtr = codePtr->codeLengthStart; + srcOffPtr = codePtr->srcDeltaStart; + srcLenPtr = codePtr->srcLengthStart; + codeOffset = sourceOffset = 0; + for (i=0 ; i<codePtr->numCommands ; i++) { + Tcl_Obj *cmd; + + codeOffset += Decode(codeOffPtr); + codeLength = Decode(codeLenPtr); + sourceOffset += Decode(srcOffPtr); + sourceLength = Decode(srcLenPtr); + cmd = Tcl_NewObj(); + Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("codefrom", -1), + Tcl_NewIntObj(codeOffset)); + Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("codeto", -1), + Tcl_NewIntObj(codeOffset + codeLength - 1)); + + /* + * Convert byte offsets to character offsets; important if multibyte + * characters are present in the source! + */ + + Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptfrom", -1), + Tcl_NewIntObj(Tcl_NumUtfChars(codePtr->source, + sourceOffset))); + Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptto", -1), + Tcl_NewIntObj(Tcl_NumUtfChars(codePtr->source, + sourceOffset + sourceLength - 1))); + Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("script", -1), + Tcl_NewStringObj(codePtr->source+sourceOffset, sourceLength)); + Tcl_ListObjAppendElement(NULL, commands, cmd); + } + +#undef Decode + + /* + * Get the source file and line number information from the CmdFrame + * system if it is available. + */ + + GetLocationInformation(codePtr->procPtr, &file, &line); + + /* + * Build the overall result. + */ + + description = Tcl_NewObj(); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("literals", -1), + literals); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("variables", -1), + variables); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("exception", -1), exn); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("instructions", -1), + instructions); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("auxiliary", -1), aux); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("commands", -1), + commands); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("script", -1), + Tcl_NewStringObj(codePtr->source, codePtr->numSrcBytes)); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("namespace", -1), + Tcl_NewStringObj(codePtr->nsPtr->fullName, -1)); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("stackdepth", -1), + Tcl_NewIntObj(codePtr->maxStackDepth)); + Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("exceptdepth", -1), + Tcl_NewIntObj(codePtr->maxExceptDepth)); + if (line > -1) { + Tcl_DictObjPut(NULL, description, + Tcl_NewStringObj("initiallinenumber", -1), + Tcl_NewIntObj(line)); + } + if (file) { + Tcl_DictObjPut(NULL, description, + Tcl_NewStringObj("sourcefile", -1), file); + } + return description; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DisassembleObjCmd -- + * + * Implementation of the "::tcl::unsupported::disassemble" command. This + * command is not documented, but will disassemble procedures, lambda + * terms and general scripts. Note that will compile terms if necessary + * in order to disassemble them. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_DisassembleObjCmd( + ClientData clientData, /* What type of operation. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + static const char *const types[] = { + "constructor", "destructor", + "lambda", "method", "objmethod", "proc", "script", NULL + }; + enum Types { + DISAS_CLASS_CONSTRUCTOR, DISAS_CLASS_DESTRUCTOR, + DISAS_LAMBDA, DISAS_CLASS_METHOD, DISAS_OBJECT_METHOD, DISAS_PROC, + DISAS_SCRIPT + }; + int idx, result; + Tcl_Obj *codeObjPtr = NULL; + Proc *procPtr = NULL; + Tcl_HashEntry *hPtr; + Object *oPtr; + Method *methodPtr; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "type ..."); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], types, "type", 0, &idx)!=TCL_OK){ + return TCL_ERROR; + } + + switch ((enum Types) idx) { + case DISAS_LAMBDA: { + Command cmd; + Tcl_Obj *nsObjPtr; + Tcl_Namespace *nsPtr; + + /* + * Compile (if uncompiled) and disassemble a lambda term. + * + * WARNING! Pokes inside the lambda objtype. + */ + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "lambdaTerm"); + return TCL_ERROR; + } + if (objv[2]->typePtr == &tclLambdaType) { + procPtr = objv[2]->internalRep.twoPtrValue.ptr1; + } + if (procPtr == NULL || procPtr->iPtr != (Interp *) interp) { + result = tclLambdaType.setFromAnyProc(interp, objv[2]); + if (result != TCL_OK) { + return result; + } + procPtr = objv[2]->internalRep.twoPtrValue.ptr1; + } + + memset(&cmd, 0, sizeof(Command)); + nsObjPtr = objv[2]->internalRep.twoPtrValue.ptr2; + result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); + if (result != TCL_OK) { + return result; + } + cmd.nsPtr = (Namespace *) nsPtr; + procPtr->cmdPtr = &cmd; + result = TclPushProcCallFrame(procPtr, interp, objc, objv, 1); + if (result != TCL_OK) { + return result; + } + TclPopStackFrame(interp); + codeObjPtr = procPtr->bodyPtr; + break; + } + case DISAS_PROC: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "procName"); + return TCL_ERROR; + } + + procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2])); + if (procPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't a procedure", TclGetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROC", + TclGetString(objv[2]), NULL); + return TCL_ERROR; + } + + /* + * Compile (if uncompiled) and disassemble a procedure. + */ + + result = TclPushProcCallFrame(procPtr, interp, 2, objv+1, 1); + if (result != TCL_OK) { + return result; + } + TclPopStackFrame(interp); + codeObjPtr = procPtr->bodyPtr; + break; + case DISAS_SCRIPT: + /* + * Compile and disassemble a script. + */ + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "script"); + return TCL_ERROR; + } + if ((objv[2]->typePtr != &tclByteCodeType) + && (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK)) { + return TCL_ERROR; + } + codeObjPtr = objv[2]; + break; + + case DISAS_CLASS_CONSTRUCTOR: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "className"); + return TCL_ERROR; + } + + /* + * Look up the body of a constructor. + */ + + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->classPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" is not a class", TclGetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", + TclGetString(objv[2]), NULL); + return TCL_ERROR; + } + + methodPtr = oPtr->classPtr->constructorPtr; + if (methodPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" has no defined constructor", + TclGetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", + "CONSRUCTOR", NULL); + return TCL_ERROR; + } + procPtr = TclOOGetProcFromMethod(methodPtr); + if (procPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "body not available for this kind of constructor", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", + "METHODTYPE", NULL); + return TCL_ERROR; + } + + /* + * Compile if necessary. + */ + + if (procPtr->bodyPtr->typePtr != &tclByteCodeType) { + Command cmd; + + /* + * Yes, this is ugly, but we need to pass the namespace in to the + * compiler in two places. + */ + + cmd.nsPtr = (Namespace *) oPtr->namespacePtr; + procPtr->cmdPtr = &cmd; + result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, + (Namespace *) oPtr->namespacePtr, "body of constructor", + TclGetString(objv[2])); + procPtr->cmdPtr = NULL; + if (result != TCL_OK) { + return result; + } + } + codeObjPtr = procPtr->bodyPtr; + break; + + case DISAS_CLASS_DESTRUCTOR: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "className"); + return TCL_ERROR; + } + + /* + * Look up the body of a destructor. + */ + + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->classPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" is not a class", TclGetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", + TclGetString(objv[2]), NULL); + return TCL_ERROR; + } + + methodPtr = oPtr->classPtr->destructorPtr; + if (methodPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" has no defined destructor", + TclGetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", + "DESRUCTOR", NULL); + return TCL_ERROR; + } + procPtr = TclOOGetProcFromMethod(methodPtr); + if (procPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "body not available for this kind of destructor", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", + "METHODTYPE", NULL); + return TCL_ERROR; + } + + /* + * Compile if necessary. + */ + + if (procPtr->bodyPtr->typePtr != &tclByteCodeType) { + Command cmd; + + /* + * Yes, this is ugly, but we need to pass the namespace in to the + * compiler in two places. + */ + + cmd.nsPtr = (Namespace *) oPtr->namespacePtr; + procPtr->cmdPtr = &cmd; + result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, + (Namespace *) oPtr->namespacePtr, "body of destructor", + TclGetString(objv[2])); + procPtr->cmdPtr = NULL; + if (result != TCL_OK) { + return result; + } + } + codeObjPtr = procPtr->bodyPtr; + break; + + case DISAS_CLASS_METHOD: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "className methodName"); + return TCL_ERROR; + } + + /* + * Look up the body of a class method. + */ + + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->classPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" is not a class", TclGetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", + TclGetString(objv[2]), NULL); + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, + (char *) objv[3]); + goto methodBody; + case DISAS_OBJECT_METHOD: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "objectName methodName"); + return TCL_ERROR; + } + + /* + * Look up the body of an instance method. + */ + + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->methodsPtr == NULL) { + goto unknownMethod; + } + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[3]); + + /* + * Compile (if necessary) and disassemble a method body. + */ + + methodBody: + if (hPtr == NULL) { + unknownMethod: + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown method \"%s\"", TclGetString(objv[3]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", + TclGetString(objv[3]), NULL); + return TCL_ERROR; + } + procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr)); + if (procPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "body not available for this kind of method", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", + "METHODTYPE", NULL); + return TCL_ERROR; + } + if (procPtr->bodyPtr->typePtr != &tclByteCodeType) { + Command cmd; + + /* + * Yes, this is ugly, but we need to pass the namespace in to the + * compiler in two places. + */ + + cmd.nsPtr = (Namespace *) oPtr->namespacePtr; + procPtr->cmdPtr = &cmd; + result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, + (Namespace *) oPtr->namespacePtr, "body of method", + TclGetString(objv[3])); + procPtr->cmdPtr = NULL; + if (result != TCL_OK) { + return result; + } + } + codeObjPtr = procPtr->bodyPtr; + break; + default: + CLANG_ASSERT(0); + } + + /* + * Do the actual disassembly. + */ + + if (BYTECODE(codeObjPtr)->flags & TCL_BYTECODE_PRECOMPILED) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may not disassemble prebuilt bytecode", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", + "BYTECODE", NULL); + return TCL_ERROR; + } + if (PTR2INT(clientData)) { + Tcl_SetObjResult(interp, + DisassembleByteCodeAsDicts(interp, codeObjPtr)); + } else { + Tcl_SetObjResult(interp, + DisassembleByteCodeObj(interp, codeObjPtr)); + } + return TCL_OK; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * tab-width: 8 + * End: + */ diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 2cc55d6..f6744e9 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -18,7 +18,7 @@ typedef size_t (LengthProc)(const char *src); * convert between various character sets and UTF-8. */ -typedef struct Encoding { +typedef struct { char *name; /* Name of encoding. Malloced because (1) hash * table entry that owns this encoding may be * freed prior to this encoding being freed, @@ -46,7 +46,7 @@ typedef struct Encoding { * nullSize is 2, this is a function that * returns the number of bytes in a 0x0000 * terminated string. */ - int refCount; /* Number of uses of this structure. */ + size_t refCount; /* Number of uses of this structure. */ Tcl_HashEntry *hPtr; /* Hash table entry that owns this encoding. */ } Encoding; @@ -57,7 +57,7 @@ typedef struct Encoding { * encoding. */ -typedef struct TableEncodingData { +typedef struct { int fallback; /* Character (in this encoding) to substitute * when this encoding cannot represent a UTF-8 * character. */ @@ -91,7 +91,7 @@ typedef struct TableEncodingData { * for switching character sets. */ -typedef struct EscapeSubTable { +typedef struct { unsigned sequenceLen; /* Length of following string. */ char sequence[16]; /* Escape code that marks this encoding. */ char name[32]; /* Name for encoding. */ @@ -100,7 +100,7 @@ typedef struct EscapeSubTable { * yet. */ } EscapeSubTable; -typedef struct EscapeEncodingData { +typedef struct { int fallback; /* Character (in this encoding) to substitute * when this encoding cannot represent a UTF-8 * character. */ @@ -180,8 +180,9 @@ TCL_DECLARE_MUTEX(encodingMutex) * the system encoding will be used to perform the conversion. */ -static Tcl_Encoding defaultEncoding; -static Tcl_Encoding systemEncoding; +static Tcl_Encoding defaultEncoding = NULL; +static Tcl_Encoding systemEncoding = NULL; +Tcl_Encoding tclIdentityEncoding = NULL; /* * The following variable is used in the sparse matrix code for a @@ -304,7 +305,7 @@ Tcl_GetEncodingFromObj( Tcl_Obj *objPtr, Tcl_Encoding *encodingPtr) { - const char *name = Tcl_GetString(objPtr); + const char *name = TclGetString(objPtr); if (objPtr->typePtr != &encodingType) { Tcl_Encoding encoding = Tcl_GetEncoding(interp, name); @@ -354,6 +355,7 @@ DupEncodingIntRep( Tcl_Obj *dupPtr) { dupPtr->internalRep.twoPtrValue.ptr1 = Tcl_GetEncoding(NULL, srcPtr->bytes); + dupPtr->typePtr = &encodingType; } /* @@ -561,13 +563,13 @@ TclInitEncodingSubsystem(void) * formed UTF-8 into a properly formed stream. */ - type.encodingName = "identity"; + type.encodingName = NULL; type.toUtfProc = BinaryProc; type.fromUtfProc = BinaryProc; type.freeProc = NULL; type.nullSize = 1; type.clientData = NULL; - Tcl_CreateEncoding(&type); + tclIdentityEncoding = Tcl_CreateEncoding(&type); type.encodingName = "utf-8"; type.toUtfProc = UtfExtToUtfIntProc; @@ -651,6 +653,10 @@ TclFinalizeEncodingSubsystem(void) Tcl_MutexLock(&encodingMutex); encodingsInitialized = 0; FreeEncoding(systemEncoding); + systemEncoding = NULL; + defaultEncoding = NULL; + FreeEncoding(tclIdentityEncoding); + tclIdentityEncoding = NULL; hPtr = Tcl_FirstHashEntry(&encodingTable, &search); while (hPtr != NULL) { @@ -687,6 +693,7 @@ TclFinalizeEncodingSubsystem(void) *------------------------------------------------------------------------- */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 const char * Tcl_GetDefaultEncodingDir(void) { @@ -699,7 +706,7 @@ Tcl_GetDefaultEncodingDir(void) } Tcl_ListObjIndex(NULL, searchPath, 0, &first); - return Tcl_GetString(first); + return TclGetString(first); } /* @@ -730,6 +737,7 @@ Tcl_SetDefaultEncodingDir( Tcl_ListObjReplace(NULL, searchPath, 0, 0, 1, &directory); Tcl_SetEncodingSearchPath(searchPath); } +#endif /* *------------------------------------------------------------------------- @@ -838,18 +846,16 @@ FreeEncoding( if (encodingPtr == NULL) { return; } - if (encodingPtr->refCount<=0) { - Tcl_Panic("FreeEncoding: refcount problem !!!"); - } - encodingPtr->refCount--; - if (encodingPtr->refCount == 0) { + if (encodingPtr->refCount-- <= 1) { if (encodingPtr->freeProc != NULL) { encodingPtr->freeProc(encodingPtr->clientData); } if (encodingPtr->hPtr != NULL) { Tcl_DeleteHashEntry(encodingPtr->hPtr); } - ckfree(encodingPtr->name); + if (encodingPtr->name) { + ckfree(encodingPtr->name); + } ckfree(encodingPtr); } } @@ -971,7 +977,7 @@ Tcl_GetEncodingNames( * Side effects: * The reference count of the new system encoding is incremented. The * reference count of the old system encoding is decremented and it may - * be freed. + * be freed. All VFS cached information is invalidated. * *------------------------------------------------------------------------ */ @@ -1002,6 +1008,7 @@ Tcl_SetSystemEncoding( FreeEncoding(systemEncoding); systemEncoding = encoding; Tcl_MutexUnlock(&encodingMutex); + Tcl_FSMountsChanged(NULL); return TCL_OK; } @@ -1037,9 +1044,24 @@ Tcl_CreateEncoding( const Tcl_EncodingType *typePtr) /* The encoding type. */ { + Encoding *encodingPtr = ckalloc(sizeof(Encoding)); + encodingPtr->name = NULL; + encodingPtr->toUtfProc = typePtr->toUtfProc; + encodingPtr->fromUtfProc = typePtr->fromUtfProc; + encodingPtr->freeProc = typePtr->freeProc; + encodingPtr->nullSize = typePtr->nullSize; + encodingPtr->clientData = typePtr->clientData; + if (typePtr->nullSize == 1) { + encodingPtr->lengthProc = (LengthProc *) strlen; + } else { + encodingPtr->lengthProc = (LengthProc *) unilen; + } + encodingPtr->refCount = 1; + encodingPtr->hPtr = NULL; + + if (typePtr->encodingName) { Tcl_HashEntry *hPtr; int isNew; - Encoding *encodingPtr; char *name; Tcl_MutexLock(&encodingMutex); @@ -1050,30 +1072,17 @@ Tcl_CreateEncoding( * reference goes away. */ - encodingPtr = Tcl_GetHashValue(hPtr); - encodingPtr->hPtr = NULL; + Encoding *replaceMe = Tcl_GetHashValue(hPtr); + replaceMe->hPtr = NULL; } name = ckalloc(strlen(typePtr->encodingName) + 1); - - encodingPtr = ckalloc(sizeof(Encoding)); encodingPtr->name = strcpy(name, typePtr->encodingName); - encodingPtr->toUtfProc = typePtr->toUtfProc; - encodingPtr->fromUtfProc = typePtr->fromUtfProc; - encodingPtr->freeProc = typePtr->freeProc; - encodingPtr->nullSize = typePtr->nullSize; - encodingPtr->clientData = typePtr->clientData; - if (typePtr->nullSize == 1) { - encodingPtr->lengthProc = (LengthProc *) strlen; - } else { - encodingPtr->lengthProc = (LengthProc *) unilen; - } - encodingPtr->refCount = 1; encodingPtr->hPtr = hPtr; Tcl_SetHashValue(hPtr, encodingPtr); Tcl_MutexUnlock(&encodingMutex); - + } return (Tcl_Encoding) encodingPtr; } @@ -1201,7 +1210,10 @@ Tcl_ExternalToUtf( * output buffer. */ { const Encoding *encodingPtr; - int result, srcRead, dstWrote, dstChars; + int result, srcRead, dstWrote, dstChars = 0; + int noTerminate = flags & TCL_ENCODING_NO_TERMINATE; + int charLimited = (flags & TCL_ENCODING_CHAR_LIMIT) && dstCharsPtr; + int maxChars = INT_MAX; Tcl_EncodingState state; if (encoding == NULL) { @@ -1226,19 +1238,40 @@ Tcl_ExternalToUtf( } if (dstCharsPtr == NULL) { dstCharsPtr = &dstChars; + flags &= ~TCL_ENCODING_CHAR_LIMIT; + } else if (charLimited) { + maxChars = *dstCharsPtr; } - /* - * If there are any null characters in the middle of the buffer, they will - * converted to the UTF-8 null character (\xC080). To get the actual \0 at - * the end of the destination buffer, we need to append it manually. - */ + if (!noTerminate) { + /* + * If there are any null characters in the middle of the buffer, + * they will converted to the UTF-8 null character (\xC080). To get + * the actual \0 at the end of the destination buffer, we need to + * append it manually. First make room for it... + */ - dstLen--; - result = encodingPtr->toUtfProc(encodingPtr->clientData, src, srcLen, - flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, - dstCharsPtr); - dst[*dstWrotePtr] = '\0'; + dstLen--; + } + do { + int savedFlags = flags; + Tcl_EncodingState savedState = *statePtr; + + result = encodingPtr->toUtfProc(encodingPtr->clientData, src, srcLen, + flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, + dstCharsPtr); + if (*dstCharsPtr <= maxChars) { + break; + } + dstLen = Tcl_UtfAtIndex(dst, maxChars) - 1 - dst + TCL_UTF_MAX; + flags = savedFlags; + *statePtr = savedState; + } while (1); + if (!noTerminate) { + /* ...and then append it */ + + dst[*dstWrotePtr] = '\0'; + } return result; } @@ -1421,7 +1454,7 @@ Tcl_UtfToExternal( * * Side effects: * The absolute pathname for the application is computed and stored to be - * returned later be [info nameofexecutable]. + * returned later by [info nameofexecutable]. * *--------------------------------------------------------------------------- */ @@ -1488,10 +1521,10 @@ OpenEncodingFileChannel( } } if (!verified) { - const char *dirString = Tcl_GetString(directory); + const char *dirString = TclGetString(directory); for (i=0; i<numDirs && !verified; i++) { - if (strcmp(dirString, Tcl_GetString(dir[i])) == 0) { + if (strcmp(dirString, TclGetString(dir[i])) == 0) { verified = 1; } } @@ -1732,7 +1765,7 @@ LoadTableEncoding( const char *p; Tcl_ReadChars(chan, objPtr, 3 + 16 * (16 * 4 + 1), 0); - p = Tcl_GetString(objPtr); + p = TclGetString(objPtr); hi = (staticHex[UCHAR(p[0])] << 4) + staticHex[UCHAR(p[1])]; dataPtr->toUnicode[hi] = pageMemPtr; p += 2; @@ -2102,6 +2135,9 @@ BinaryProc( if (dstLen < 0) { dstLen = 0; } + if ((flags & TCL_ENCODING_CHAR_LIMIT) && srcLen > *dstCharsPtr) { + srcLen = *dstCharsPtr; + } if (srcLen > dstLen) { srcLen = dstLen; result = TCL_CONVERT_NOSPACE; @@ -2262,9 +2298,12 @@ UtfToUtfProc( { const char *srcStart, *srcEnd, *srcClose; const char *dstStart, *dstEnd; - int result, numChars; - Tcl_UniChar ch; + int result, numChars, charLimit = INT_MAX; + Tcl_UniChar *chPtr = (Tcl_UniChar *) statePtr; + if (flags & TCL_ENCODING_START) { + *statePtr = 0; + } result = TCL_OK; srcStart = src; @@ -2273,11 +2312,14 @@ UtfToUtfProc( if ((flags & TCL_ENCODING_END) == 0) { srcClose -= TCL_UTF_MAX; } + if (flags & TCL_ENCODING_CHAR_LIMIT) { + charLimit = *dstCharsPtr; + } dstStart = dst; dstEnd = dst + dstLen - TCL_UTF_MAX; - for (numChars = 0; src < srcEnd; numChars++) { + for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) { if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) { /* * If there is more string to follow, this will ensure that the @@ -2293,13 +2335,13 @@ UtfToUtfProc( } if (UCHAR(*src) < 0x80 && !(UCHAR(*src) == 0 && pureNullMode == 0)) { /* - * Copy 7bit chatacters, but skip null-bytes when we are in input + * Copy 7bit characters, but skip null-bytes when we are in input * mode, so that they get converted to 0xc080. */ *dst++ = *src++; } else if (pureNullMode == 1 && UCHAR(*src) == 0xc0 && - UCHAR(*(src+1)) == 0x80) { + (src + 1 < srcEnd) && UCHAR(*(src+1)) == 0x80) { /* * Convert 0xc080 to real nulls when we are in output mode. */ @@ -2308,17 +2350,24 @@ UtfToUtfProc( src += 2; } else if (!Tcl_UtfCharComplete(src, srcEnd - src)) { /* - * Always check before using Tcl_UtfToUniChar. Not doing can so - * cause it run beyond the endof the buffer! If we happen such an - * incomplete char its byts are made to represent themselves. + * Always check before using TclUtfToUniChar. Not doing can so + * cause it run beyond the end of the buffer! If we happen such an + * incomplete char its bytes are made to represent themselves. */ - ch = (unsigned char) *src; + *chPtr = (unsigned char) *src; src += 1; - dst += Tcl_UniCharToUtf(ch, dst); + dst += Tcl_UniCharToUtf(*chPtr, dst); } else { - src += Tcl_UtfToUniChar(src, &ch); - dst += Tcl_UniCharToUtf(ch, dst); + int len = TclUtfToUniChar(src, chPtr); + src += len; + dst += Tcl_UniCharToUtf(*chPtr, dst); +#if TCL_UTF_MAX <= 4 + if (!len) { + src += TclUtfToUniChar(src, chPtr); + dst += Tcl_UniCharToUtf(*chPtr, dst); + } +#endif } } @@ -2373,9 +2422,15 @@ UnicodeToUtfProc( { const char *srcStart, *srcEnd; const char *dstEnd, *dstStart; - int result, numChars; - Tcl_UniChar ch; + int result, numChars, charLimit = INT_MAX; + Tcl_UniChar *chPtr = (Tcl_UniChar *) statePtr; + if (flags & TCL_ENCODING_START) { + *statePtr = 0; + } + if (flags & TCL_ENCODING_CHAR_LIMIT) { + charLimit = *dstCharsPtr; + } result = TCL_OK; if ((srcLen % sizeof(Tcl_UniChar)) != 0) { result = TCL_CONVERT_MULTIBYTE; @@ -2389,7 +2444,7 @@ UnicodeToUtfProc( dstStart = dst; dstEnd = dst + dstLen - TCL_UTF_MAX; - for (numChars = 0; src < srcEnd; numChars++) { + for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) { if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; @@ -2400,11 +2455,11 @@ UnicodeToUtfProc( * Tcl_UniChar-size data. */ - ch = *(Tcl_UniChar *)src; - if (ch && ch < 0x80) { - *dst++ = (ch & 0xFF); + *chPtr = *(Tcl_UniChar *)src; + if (*chPtr && *chPtr < 0x80) { + *dst++ = (*chPtr & 0xFF); } else { - dst += Tcl_UniCharToUtf(ch, dst); + dst += Tcl_UniCharToUtf(*chPtr, dst); } src += sizeof(Tcl_UniChar); } @@ -2461,8 +2516,11 @@ UtfToUnicodeProc( { const char *srcStart, *srcEnd, *srcClose, *dstStart, *dstEnd; int result, numChars; - Tcl_UniChar ch; + Tcl_UniChar *chPtr = (Tcl_UniChar *) statePtr; + if (flags & TCL_ENCODING_START) { + *statePtr = 0; + } srcStart = src; srcEnd = src + srcLen; srcClose = srcEnd; @@ -2487,21 +2545,34 @@ UtfToUnicodeProc( if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; - } - src += TclUtfToUniChar(src, &ch); + } + src += TclUtfToUniChar(src, chPtr); /* * Need to handle this in a way that won't cause misalignment by * casting dst to a Tcl_UniChar. [Bug 1122671] - * XXX: This hard-codes the assumed size of Tcl_UniChar as 2. */ #ifdef WORDS_BIGENDIAN - *dst++ = (ch >> 8); - *dst++ = (ch & 0xFF); +#if TCL_UTF_MAX > 4 + *dst++ = (*chPtr >> 24); + *dst++ = ((*chPtr >> 16) & 0xFF); + *dst++ = ((*chPtr >> 8) & 0xFF); + *dst++ = (*chPtr & 0xFF); +#else + *dst++ = (*chPtr >> 8); + *dst++ = (*chPtr & 0xFF); +#endif +#else +#if TCL_UTF_MAX > 4 + *dst++ = (*chPtr & 0xFF); + *dst++ = ((*chPtr >> 8) & 0xFF); + *dst++ = ((*chPtr >> 16) & 0xFF); + *dst++ = (*chPtr >> 24); #else - *dst++ = (ch & 0xFF); - *dst++ = (ch >> 8); + *dst++ = (*chPtr & 0xFF); + *dst++ = (*chPtr >> 8); +#endif #endif } *srcReadPtr = src - srcStart; @@ -2557,12 +2628,15 @@ TableToUtfProc( { const char *srcStart, *srcEnd; const char *dstEnd, *dstStart, *prefixBytes; - int result, byte, numChars; - Tcl_UniChar ch; + int result, byte, numChars, charLimit = INT_MAX; + Tcl_UniChar ch = 0; const unsigned short *const *toUnicode; const unsigned short *pageZero; TableEncodingData *dataPtr = clientData; + if (flags & TCL_ENCODING_CHAR_LIMIT) { + charLimit = *dstCharsPtr; + } srcStart = src; srcEnd = src + srcLen; @@ -2574,7 +2648,7 @@ TableToUtfProc( pageZero = toUnicode[0]; result = TCL_OK; - for (numChars = 0; src < srcEnd; numChars++) { + for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) { if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; @@ -2667,7 +2741,7 @@ TableFromUtfProc( { const char *srcStart, *srcEnd, *srcClose; const char *dstStart, *dstEnd, *prefixBytes; - Tcl_UniChar ch; + Tcl_UniChar ch = 0; int result, len, word, numChars; TableEncodingData *dataPtr = clientData; const unsigned short *const *fromUnicode; @@ -2699,7 +2773,7 @@ TableFromUtfProc( } len = TclUtfToUniChar(src, &ch); -#if TCL_UTF_MAX > 3 +#if TCL_UTF_MAX > 4 /* * This prevents a crash condition. More evaluation is required for * full support of int Tcl_UniChar. [Bug 1004065] @@ -2708,6 +2782,10 @@ TableFromUtfProc( if (ch & 0xffff0000) { word = 0; } else +#else + if (!len) { + word = 0; + } else #endif word = fromUnicode[(ch >> 8)][ch & 0xff]; @@ -2788,8 +2866,11 @@ Iso88591ToUtfProc( { const char *srcStart, *srcEnd; const char *dstEnd, *dstStart; - int result, numChars; + int result, numChars, charLimit = INT_MAX; + if (flags & TCL_ENCODING_CHAR_LIMIT) { + charLimit = *dstCharsPtr; + } srcStart = src; srcEnd = src + srcLen; @@ -2797,8 +2878,8 @@ Iso88591ToUtfProc( dstEnd = dst + dstLen - TCL_UTF_MAX; result = TCL_OK; - for (numChars = 0; src < srcEnd; numChars++) { - Tcl_UniChar ch; + for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) { + Tcl_UniChar ch = 0; if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; @@ -2884,7 +2965,7 @@ Iso88591FromUtfProc( dstEnd = dst + dstLen - 1; for (numChars = 0; src < srcEnd; numChars++) { - Tcl_UniChar ch; + Tcl_UniChar ch = 0; int len; if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) { @@ -2902,12 +2983,18 @@ Iso88591FromUtfProc( * Check for illegal characters. */ - if (ch > 0xff) { + if (ch > 0xff +#if TCL_UTF_MAX <= 4 + || !len +#endif + ) { if (flags & TCL_ENCODING_STOPONERROR) { result = TCL_CONVERT_UNKNOWN; break; } - +#if TCL_UTF_MAX <= 4 + if (!len) len = 4; +#endif /* * Plunge on, using '?' as a fallback character. */ @@ -2958,7 +3045,9 @@ TableFreeProc( */ ckfree(dataPtr->toUnicode); + dataPtr->toUnicode = NULL; ckfree(dataPtr->fromUnicode); + dataPtr->fromUnicode = NULL; ckfree(dataPtr); } @@ -3011,9 +3100,12 @@ EscapeToUtfProc( const char *prefixBytes, *tablePrefixBytes, *srcStart, *srcEnd; const unsigned short *const *tableToUnicode; const Encoding *encodingPtr; - int state, result, numChars; + int state, result, numChars, charLimit = INT_MAX; const char *dstStart, *dstEnd; + if (flags & TCL_ENCODING_CHAR_LIMIT) { + charLimit = *dstCharsPtr; + } result = TCL_OK; tablePrefixBytes = NULL; /* lint. */ tableToUnicode = NULL; /* lint. */ @@ -3031,7 +3123,7 @@ EscapeToUtfProc( state = 0; } - for (numChars = 0; src < srcEnd; ) { + for (numChars = 0; src < srcEnd && numChars <= charLimit; ) { int byte, hi, lo, ch; if (dst > dstEnd) { @@ -3266,7 +3358,7 @@ EscapeFromUtfProc( for (numChars = 0; src < srcEnd; numChars++) { unsigned len; int word; - Tcl_UniChar ch; + Tcl_UniChar ch = 0; if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) { /* @@ -3311,7 +3403,7 @@ EscapeFromUtfProc( /* * The state variable has the value of oldState when word is 0. - * In this case, the escape sequense should not be copied to dst + * In this case, the escape sequence should not be copied to dst * because the current character set is not changed. */ @@ -3431,6 +3523,7 @@ EscapeFreeProc( subTablePtr = dataPtr->subTables; for (i = 0; i < dataPtr->numSubTables; i++) { FreeEncoding((Tcl_Encoding) subTablePtr->encodingPtr); + subTablePtr->encodingPtr = NULL; subTablePtr++; } } @@ -3535,11 +3628,11 @@ unilen( static void InitializeEncodingSearchPath( char **valuePtr, - int *lengthPtr, + unsigned int *lengthPtr, Tcl_Encoding *encodingPtr) { const char *bytes; - int i, numDirs, numBytes; + int i, numDirs; Tcl_Obj *libPathObj, *encodingObj, *searchPathObj; TclNewLiteralStringObj(encodingObj, "encoding"); @@ -3569,11 +3662,11 @@ InitializeEncodingSearchPath( if (*encodingPtr) { ((Encoding *)(*encodingPtr))->refCount++; } - bytes = Tcl_GetStringFromObj(searchPathObj, &numBytes); + bytes = TclGetString(searchPathObj); - *lengthPtr = numBytes; - *valuePtr = ckalloc(numBytes + 1); - memcpy(*valuePtr, bytes, (size_t) numBytes + 1); + *lengthPtr = searchPathObj->length; + *valuePtr = ckalloc(*lengthPtr + 1); + memcpy(*valuePtr, bytes, *lengthPtr + 1); Tcl_DecrRefCount(searchPathObj); } diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index b3a802a..84ed9e3 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -28,11 +28,10 @@ static int NsEnsembleStringOrder(const void *strPtr1, const void *strPtr2); static void DeleteEnsembleConfig(ClientData clientData); static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr, - EnsembleConfig *ensemblePtr, - const char *subcmdName, Tcl_Obj *prefixObjPtr); + EnsembleConfig *ensemblePtr, Tcl_HashEntry *hPtr, + Tcl_Obj *fix); static void FreeEnsembleCmdRep(Tcl_Obj *objPtr); static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); -static void StringOfEnsembleCmdRep(Tcl_Obj *objPtr); static void CompileToInvokedCommand(Tcl_Interp *interp, Tcl_Parse *parsePtr, Tcl_Obj *replacements, Command *cmdPtr, CompileEnv *envPtr); @@ -40,6 +39,8 @@ static int CompileBasicNArgCommand(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, CompileEnv *envPtr); +static Tcl_NRPostProc FreeER; + /* * The lists of subcommands and options for the [namespace ensemble] command. */ @@ -75,14 +76,29 @@ enum EnsConfigOpts { * that implements it. */ -const Tcl_ObjType tclEnsembleCmdType = { +static const Tcl_ObjType ensembleCmdType = { "ensembleCommand", /* the type's name */ FreeEnsembleCmdRep, /* freeIntRepProc */ DupEnsembleCmdRep, /* dupIntRepProc */ - StringOfEnsembleCmdRep, /* updateStringProc */ + NULL, /* updateStringProc */ NULL /* setFromAnyProc */ }; +/* + * The internal rep for caching ensemble subcommand lookups and spelling + * corrections. + */ + +typedef struct { + unsigned int epoch; /* Used to confirm when the data in this + * really structure matches up with the + * ensemble. */ + Command *token; /* Reference to the command for which this + * structure is a cache of the resolution. */ + Tcl_Obj *fix; /* Corrected spelling, if needed. */ + Tcl_HashEntry *hPtr; /* Direct link to entry in the subcommand hash + * table. */ +} EnsembleCmdRep; static inline Tcl_Obj * NewNsObj( @@ -92,9 +108,8 @@ NewNsObj( if (namespacePtr == TclGetGlobalNamespace(nsPtr->interp)) { return Tcl_NewStringObj("::", 2); - } else { - return Tcl_NewStringObj(nsPtr->fullName, -1); } + return Tcl_NewStringObj(nsPtr->fullName, -1); } /* @@ -127,10 +142,12 @@ TclNamespaceEnsembleCmd( Tcl_Obj *const objv[]) { Tcl_Namespace *namespacePtr; - Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp); + Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp), *cxtPtr, + *foundNsPtr, *altFoundNsPtr, *actualCxtPtr; Tcl_Command token; Tcl_DictSearch search; Tcl_Obj *listObj; + const char *simpleName; int index, done; if (nsPtr == NULL || nsPtr->flags & NS_DYING) { @@ -176,13 +193,8 @@ TclNamespaceEnsembleCmd( objv += 2; objc -= 2; - /* - * Work out what name to use for the command to create. If supplied, - * it is either fully specified or relative to the current namespace. - * If not supplied, it is exactly the name of the current namespace. - */ - - name = nsPtr->fullName; + name = nsPtr->name; + cxtPtr = (Namespace *) nsPtr->parentPtr; /* * Parse the option list, applying type checks as we go. Note that we @@ -202,6 +214,7 @@ TclNamespaceEnsembleCmd( switch ((enum EnsCreateOpts) index) { case CRT_CMD: name = TclGetString(objv[1]); + cxtPtr = nsPtr; continue; case CRT_SUBCMDS: if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { @@ -285,7 +298,8 @@ TclNamespaceEnsembleCmd( Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj, newList); } - Tcl_DictObjNext(&search, &subcmdWordsObj,&listObj, &done); + Tcl_DictObjNext(&search, &subcmdWordsObj, &listObj, + &done); } while (!done); if (allocatedMapFlag) { @@ -318,6 +332,10 @@ TclNamespaceEnsembleCmd( } } + TclGetNamespaceForQualName(interp, name, cxtPtr, + TCL_CREATE_NS_IF_UNKNOWN, &foundNsPtr, &altFoundNsPtr, + &actualCxtPtr, &simpleName); + /* * Create the ensemble. Note that this might delete another ensemble * linked to the same namespace, so we must be careful. However, we @@ -325,7 +343,8 @@ TclNamespaceEnsembleCmd( * we've created it (and after any deletions have occurred.) */ - token = Tcl_CreateEnsemble(interp, name, NULL, + token = TclCreateEnsembleInNs(interp, simpleName, + (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0)); Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj); Tcl_SetEnsembleMappingDict(interp, token, mapObj); @@ -554,7 +573,8 @@ TclNamespaceEnsembleCmd( Tcl_AppendStringsToObj(newCmd, "::", NULL); } Tcl_AppendObjToObj(newCmd, listv[0]); - Tcl_ListObjReplace(NULL, newList, 0,1, 1,&newCmd); + Tcl_ListObjReplace(NULL, newList, 0, 1, 1, + &newCmd); if (patchedDict == NULL) { patchedDict = Tcl_DuplicateObj(objv[1]); } @@ -617,48 +637,36 @@ TclNamespaceEnsembleCmd( /* *---------------------------------------------------------------------- * - * Tcl_CreateEnsemble -- + * TclCreateEnsembleInNs -- * - * Create a simple ensemble attached to the given namespace. - * - * Results: - * The token for the command created. - * - * Side effects: - * The ensemble is created and marked for compilation. + * Like Tcl_CreateEnsemble, but additionally accepts as an argument the + * name of the namespace to create the command in. * *---------------------------------------------------------------------- */ Tcl_Command -Tcl_CreateEnsemble( +TclCreateEnsembleInNs( Tcl_Interp *interp, - const char *name, - Tcl_Namespace *namespacePtr, + const char *name, /* Simple name of command to create (no + * namespace components). */ + Tcl_Namespace *nameNsPtr, /* Name of namespace to create the command + * in. */ + Tcl_Namespace *ensembleNsPtr, + /* Name of the namespace for the ensemble. */ int flags) { - Namespace *nsPtr = (Namespace *) namespacePtr; - EnsembleConfig *ensemblePtr = ckalloc(sizeof(EnsembleConfig)); - Tcl_Obj *nameObj = NULL; - - if (nsPtr == NULL) { - nsPtr = (Namespace *) TclGetCurrentNamespace(interp); - } - - /* - * Make the name of the ensemble into a fully qualified name. This might - * allocate a temporary object. - */ + Namespace *nsPtr = (Namespace *) ensembleNsPtr; + EnsembleConfig *ensemblePtr; + Tcl_Command token; - if (!(name[0] == ':' && name[1] == ':')) { - nameObj = NewNsObj((Tcl_Namespace *) nsPtr); - if (nsPtr->parentPtr == NULL) { - Tcl_AppendStringsToObj(nameObj, name, NULL); - } else { - Tcl_AppendStringsToObj(nameObj, "::", name, NULL); - } - Tcl_IncrRefCount(nameObj); - name = TclGetString(nameObj); + ensemblePtr = ckalloc(sizeof(EnsembleConfig)); + token = TclNRCreateCommandInNs(interp, name, + (Tcl_Namespace *) nameNsPtr, TclEnsembleImplementationCmd, + NsEnsembleImplementationCmdNR, ensemblePtr, DeleteEnsembleConfig); + if (token == NULL) { + ckfree(ensemblePtr); + return NULL; } ensemblePtr->nsPtr = nsPtr; @@ -671,9 +679,7 @@ Tcl_CreateEnsemble( ensemblePtr->numParameters = 0; ensemblePtr->parameterList = NULL; ensemblePtr->unknownHandler = NULL; - ensemblePtr->token = Tcl_NRCreateCommand(interp, name, - TclEnsembleImplementationCmd, NsEnsembleImplementationCmdNR, - ensemblePtr, DeleteEnsembleConfig); + ensemblePtr->token = token; ensemblePtr->next = (EnsembleConfig *) nsPtr->ensembles; nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr; @@ -690,15 +696,52 @@ Tcl_CreateEnsemble( ((Command *) ensemblePtr->token)->compileProc = TclCompileEnsemble; } - if (nameObj != NULL) { - TclDecrRefCount(nameObj); - } return ensemblePtr->token; } /* *---------------------------------------------------------------------- * + * Tcl_CreateEnsemble + * + * Create a simple ensemble attached to the given namespace. Deprecated + * (internally) by TclCreateEnsembleInNs. + * + * Value + * + * The token for the command created. + * + * Effect + * The ensemble is created and marked for compilation. + * + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +Tcl_CreateEnsemble( + Tcl_Interp *interp, + const char *name, + Tcl_Namespace *namespacePtr, + int flags) +{ + Namespace *nsPtr = (Namespace *) namespacePtr, *foundNsPtr, *altNsPtr, + *actualNsPtr; + const char * simpleName; + + if (nsPtr == NULL) { + nsPtr = (Namespace *) TclGetCurrentNamespace(interp); + } + + TclGetNamespaceForQualName(interp, name, nsPtr, TCL_CREATE_NS_IF_UNKNOWN, + &foundNsPtr, &altNsPtr, &actualNsPtr, &simpleName); + return TclCreateEnsembleInNs(interp, simpleName, + (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, flags); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_SetEnsembleSubcommandList -- * * Set the subcommand list for a particular ensemble. @@ -1587,7 +1630,7 @@ TclMakeEnsemble( Tcl_DStringFree(&buf); Tcl_DStringFree(&hiddenBuf); if (nameParts != NULL) { - ckfree((char *) nameParts); + ckfree(nameParts); } return ensemble; } @@ -1642,6 +1685,8 @@ NsEnsembleImplementationCmdNR( * names. */ int reparseCount = 0; /* Number of reparses. */ Tcl_Obj *errorObj; /* Used for building error messages. */ + Tcl_Obj *subObj; + int subIdx; /* * Must recheck objc, since numParameters might have changed. Cf. test @@ -1649,24 +1694,18 @@ NsEnsembleImplementationCmdNR( */ restartEnsembleParse: - if (objc < 2 + ensemblePtr->numParameters) { + subIdx = 1 + ensemblePtr->numParameters; + if (objc < subIdx + 1) { /* * We don't have a subcommand argument. Make error message. */ Tcl_DString buf; /* Message being built */ - Tcl_Obj **elemPtrs; /* Parameter names */ - int len; /* Number of parameters to append */ Tcl_DStringInit(&buf); - if (ensemblePtr->parameterList == NULL) { - len = 0; - } else if (TclListObjGetElements(NULL, ensemblePtr->parameterList, - &len, &elemPtrs) != TCL_OK) { - Tcl_Panic("List of ensemble parameters is not a list"); - } - for (; len>0; len--,elemPtrs++) { - TclDStringAppendObj(&buf, *elemPtrs); + if (ensemblePtr->parameterList) { + Tcl_DStringAppend(&buf, + TclGetString(ensemblePtr->parameterList), -1); TclDStringAppendLiteral(&buf, " "); } TclDStringAppendLiteral(&buf, "subcommand ?arg ...?"); @@ -1694,6 +1733,8 @@ NsEnsembleImplementationCmdNR( * up in there and go straight to dispatch. */ + subObj = objv[subIdx]; + if (ensemblePtr->epoch == ensemblePtr->nsPtr->exportLookupEpoch) { /* * Table of subcommands is still valid; therefore there might be a @@ -1702,15 +1743,16 @@ NsEnsembleImplementationCmdNR( * part where we do the invocation of the subcommand. */ - if (objv[1+ensemblePtr->numParameters]->typePtr==&tclEnsembleCmdType){ - EnsembleCmdRep *ensembleCmd = objv[1+ensemblePtr->numParameters] - ->internalRep.twoPtrValue.ptr1; + if (subObj->typePtr==&ensembleCmdType){ + EnsembleCmdRep *ensembleCmd = subObj->internalRep.twoPtrValue.ptr1; - if (ensembleCmd->nsPtr == ensemblePtr->nsPtr && - ensembleCmd->epoch == ensemblePtr->epoch && - ensembleCmd->token == ensemblePtr->token) { - prefixObj = ensembleCmd->realPrefixObj; + if (ensembleCmd->epoch == ensemblePtr->epoch && + ensembleCmd->token == (Command *)ensemblePtr->token) { + prefixObj = Tcl_GetHashValue(ensembleCmd->hPtr); Tcl_IncrRefCount(prefixObj); + if (ensembleCmd->fix) { + TclSpellFix(interp, objv, objc, subIdx, subObj, ensembleCmd->fix); + } goto runResultingSubcommand; } } @@ -1725,18 +1767,14 @@ NsEnsembleImplementationCmdNR( */ hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, - TclGetString(objv[1 + ensemblePtr->numParameters])); + TclGetString(subObj)); if (hPtr != NULL) { - char *fullName = Tcl_GetHashKey(&ensemblePtr->subcommandTable, hPtr); - - prefixObj = Tcl_GetHashValue(hPtr); /* * Cache for later in the subcommand object. */ - MakeCachedEnsembleCommand(objv[1 + ensemblePtr->numParameters], - ensemblePtr, fullName, prefixObj); + MakeCachedEnsembleCommand(subObj, ensemblePtr, hPtr, NULL); } else if (!(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX)) { /* * Could not map, no prefixing, go to unknown/error handling. @@ -1756,9 +1794,9 @@ NsEnsembleImplementationCmdNR( char *fullName = NULL; /* Full name of the subcommand. */ int stringLength, i; int tableLength = ensemblePtr->subcommandTable.numEntries; + Tcl_Obj *fix; - subcmdName = TclGetString(objv[1 + ensemblePtr->numParameters]); - stringLength = objv[1 + ensemblePtr->numParameters]->length; + subcmdName = TclGetStringFromObj(subObj, &stringLength); for (i=0 ; i<tableLength ; i++) { register int cmp = strncmp(subcmdName, ensemblePtr->subcommandArrayPtr[i], @@ -1798,16 +1836,22 @@ NsEnsembleImplementationCmdNR( Tcl_Panic("full name %s not found in supposedly synchronized hash", fullName); } - prefixObj = Tcl_GetHashValue(hPtr); + + /* + * Record the spelling correction for usage message. + */ + + fix = Tcl_NewStringObj(fullName, -1); /* * Cache for later in the subcommand object. */ - MakeCachedEnsembleCommand(objv[1 + ensemblePtr->numParameters], - ensemblePtr, fullName, prefixObj); + MakeCachedEnsembleCommand(subObj, ensemblePtr, hPtr, fix); + TclSpellFix(interp, objv, objc, subIdx, subObj, fix); } + prefixObj = Tcl_GetHashValue(hPtr); Tcl_IncrRefCount(prefixObj); runResultingSubcommand: @@ -1826,47 +1870,26 @@ NsEnsembleImplementationCmdNR( */ { - Tcl_Obj **prefixObjv; /* The list of objects to substitute in as the - * target command prefix. */ Tcl_Obj *copyPtr; /* The actual list of words to dispatch to. * Will be freed by the dispatch engine. */ - int prefixObjc, copyObjc; - Interp *iPtr = (Interp *) interp; + Tcl_Obj **copyObjv; + int copyObjc, prefixObjc; - /* - * Get the prefix that we're rewriting to. To do this we need to - * ensure that the internal representation of the list does not change - * so that we can safely keep the internal representations of the - * elements in the list. - * - * TODO: Use conventional list operations to make this code sane! - */ + Tcl_ListObjLength(NULL, prefixObj, &prefixObjc); - TclListObjGetElements(NULL, prefixObj, &prefixObjc, &prefixObjv); - - copyObjc = objc - 2 + prefixObjc; - copyPtr = Tcl_NewListObj(copyObjc, NULL); - if (copyObjc > 0) { - register Tcl_Obj **copyObjv; - /* Space used to construct the list of - * arguments to pass to the command that - * implements the ensemble subcommand. */ - register List *listRepPtr = copyPtr->internalRep.twoPtrValue.ptr1; - register int i; - - listRepPtr->elemCount = copyObjc; - copyObjv = &listRepPtr->elements; - memcpy(copyObjv, prefixObjv, sizeof(Tcl_Obj *) * prefixObjc); - memcpy(copyObjv+prefixObjc, objv+1, - sizeof(Tcl_Obj *) * ensemblePtr->numParameters); - memcpy(copyObjv+prefixObjc+ensemblePtr->numParameters, - objv+ensemblePtr->numParameters+2, - sizeof(Tcl_Obj *) * (objc-ensemblePtr->numParameters-2)); - - for (i=0; i < copyObjc; i++) { - Tcl_IncrRefCount(copyObjv[i]); - } - } + if (objc == 2) { + copyPtr = TclListObjCopy(NULL, prefixObj); + } else { + copyPtr = Tcl_NewListObj(objc - 2 + prefixObjc, NULL); + Tcl_ListObjAppendList(NULL, copyPtr, prefixObj); + Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0, + ensemblePtr->numParameters, objv + 1); + Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0, + objc - 2 - ensemblePtr->numParameters, + objv + 2 + ensemblePtr->numParameters); + } + Tcl_IncrRefCount(copyPtr); + TclNRAddCallback(interp, TclNRReleaseValues, copyPtr, NULL, NULL, NULL); TclDecrRefCount(prefixObj); /* @@ -1875,25 +1898,10 @@ NsEnsembleImplementationCmdNR( * count both as inserted and removed arguments. */ - if (iPtr->ensembleRewrite.sourceObjs == NULL) { - iPtr->ensembleRewrite.sourceObjs = objv; - iPtr->ensembleRewrite.numRemovedObjs = - 2 + ensemblePtr->numParameters; - iPtr->ensembleRewrite.numInsertedObjs = - prefixObjc + ensemblePtr->numParameters; + if (TclInitRewriteEnsemble(interp, 2 + ensemblePtr->numParameters, + prefixObjc + ensemblePtr->numParameters, objv)) { TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); - } else { - register int ni = 2 + ensemblePtr->numParameters - - iPtr->ensembleRewrite.numInsertedObjs; - /* Position in objv of new front of insertion - * relative to old one. */ - if (ni > 0) { - iPtr->ensembleRewrite.numRemovedObjs += ni; - iPtr->ensembleRewrite.numInsertedObjs += prefixObjc-1; - } else { - iPtr->ensembleRewrite.numInsertedObjs += prefixObjc-2; - } } /* @@ -1901,7 +1909,9 @@ NsEnsembleImplementationCmdNR( */ TclSkipTailcall(interp); - return TclNREvalObjEx(interp, copyPtr, TCL_EVAL_INVOKE, NULL,INT_MIN); + Tcl_ListObjGetElements(NULL, copyPtr, ©Objc, ©Objv); + ((Interp *)interp)->lookupNsPtr = ensemblePtr->nsPtr; + return TclNREvalObjv(interp, copyObjc, copyObjv, TCL_EVAL_INVOKE, NULL); } unknownOrAmbiguousSubcommand: @@ -1933,20 +1943,17 @@ NsEnsembleImplementationCmdNR( Tcl_ResetResult(interp); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND", - TclGetString(objv[1+ensemblePtr->numParameters]), NULL); + TclGetString(subObj), NULL); if (ensemblePtr->subcommandTable.numEntries == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown subcommand \"%s\": namespace %s does not" - " export any commands", - TclGetString(objv[1+ensemblePtr->numParameters]), + " export any commands", TclGetString(subObj), ensemblePtr->nsPtr->fullName)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND", - TclGetString(objv[1+ensemblePtr->numParameters]), NULL); return TCL_ERROR; } errorObj = Tcl_ObjPrintf("unknown%s subcommand \"%s\": must be ", (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? " or ambiguous" : ""), - TclGetString(objv[1+ensemblePtr->numParameters])); + TclGetString(subObj)); if (ensemblePtr->subcommandTable.numEntries == 1) { Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[0], -1); } else { @@ -2012,7 +2019,7 @@ TclInitRewriteEnsemble( if (numIns < numRemoved) { iPtr->ensembleRewrite.numRemovedObjs += numRemoved - numIns; - iPtr->ensembleRewrite.numInsertedObjs += numInserted - 1; + iPtr->ensembleRewrite.numInsertedObjs = numInserted; } else { iPtr->ensembleRewrite.numInsertedObjs += numInserted - numRemoved; } @@ -2053,6 +2060,155 @@ TclResetRewriteEnsemble( } /* + *---------------------------------------------------------------------- + * + * TclSpellFix -- + * + * Record a spelling correction that needs making in the + * generation of the WrongNumArgs usage message. + * + * Results: + * None. + * + * Side effects: + * Can create an alternative ensemble rewrite structure. + * + *---------------------------------------------------------------------- + */ + +static int +FreeER( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_Obj **tmp = (Tcl_Obj **)data[0]; + + ckfree(tmp[2]); + ckfree(tmp); + return result; +} + +void +TclSpellFix( + Tcl_Interp *interp, + Tcl_Obj *const *objv, + int objc, + int badIdx, + Tcl_Obj *bad, + Tcl_Obj *fix) +{ + Interp *iPtr = (Interp *) interp; + Tcl_Obj *const *search; + Tcl_Obj **store; + int idx; + int size; + + if (iPtr->ensembleRewrite.sourceObjs == NULL) { + iPtr->ensembleRewrite.sourceObjs = objv; + iPtr->ensembleRewrite.numRemovedObjs = 0; + iPtr->ensembleRewrite.numInsertedObjs = 0; + } + + /* + * Compute the valid length of the ensemble root. + */ + + size = iPtr->ensembleRewrite.numRemovedObjs + objc + - iPtr->ensembleRewrite.numInsertedObjs; + + search = iPtr->ensembleRewrite.sourceObjs; + if (search[0] == NULL) { + /* + * Awful casting abuse here... + */ + search = (Tcl_Obj *const *) search[1]; + } + + if (badIdx < iPtr->ensembleRewrite.numInsertedObjs) { + /* + * Misspelled value was inserted. We cannot directly jump to the bad + * value, but have to search. + */ + + idx = 1; + while (idx < size) { + if (search[idx] == bad) { + break; + } + idx++; + } + if (idx == size) { + return; + } + } else { + /* Jump to the misspelled value. */ + idx = iPtr->ensembleRewrite.numRemovedObjs + badIdx + - iPtr->ensembleRewrite.numInsertedObjs; + + /* Verify */ + if (search[idx] != bad) { + Tcl_Panic("SpellFix: programming error"); + } + } + + search = iPtr->ensembleRewrite.sourceObjs; + if (search[0] == NULL) { + store = (Tcl_Obj **) search[2]; + } else { + Tcl_Obj **tmp = ckalloc(3 * sizeof(Tcl_Obj *)); + + tmp[0] = NULL; + tmp[1] = (Tcl_Obj *) iPtr->ensembleRewrite.sourceObjs; + tmp[2] = (Tcl_Obj *) ckalloc(size * sizeof(Tcl_Obj *)); + memcpy(tmp[2], tmp[1], size * sizeof(Tcl_Obj *)); + + iPtr->ensembleRewrite.sourceObjs = (Tcl_Obj *const *) tmp; + TclNRAddCallback(interp, FreeER, tmp, NULL, NULL, NULL); + store = (Tcl_Obj **)tmp[2]; + } + + store[idx] = fix; + Tcl_IncrRefCount(fix); + TclNRAddCallback(interp, TclNRReleaseValues, fix, NULL, NULL, NULL); +} + +/* + *---------------------------------------------------------------------- + * + * TclFetchEnsembleRoot -- + * + * Returns the root of ensemble rewriting, if any. + * If no root exists, returns objv instead. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj *const * +TclFetchEnsembleRoot( + Tcl_Interp *interp, + Tcl_Obj *const *objv, + int objc, + int *objcPtr) +{ + Interp *iPtr = (Interp *) interp; + + if (iPtr->ensembleRewrite.sourceObjs) { + *objcPtr = objc + iPtr->ensembleRewrite.numRemovedObjs + - iPtr->ensembleRewrite.numInsertedObjs; + return iPtr->ensembleRewrite.sourceObjs; + } + *objcPtr = objc; + return objv; +} + +/* * ---------------------------------------------------------------------- * * EnsmebleUnknownCallback -- @@ -2217,17 +2373,17 @@ static void MakeCachedEnsembleCommand( Tcl_Obj *objPtr, EnsembleConfig *ensemblePtr, - const char *subcommandName, - Tcl_Obj *prefixObjPtr) + Tcl_HashEntry *hPtr, + Tcl_Obj *fix) { register EnsembleCmdRep *ensembleCmd; - int length; - if (objPtr->typePtr == &tclEnsembleCmdType) { + if (objPtr->typePtr == &ensembleCmdType) { ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; - Tcl_DecrRefCount(ensembleCmd->realPrefixObj); - TclNsDecrRefCount(ensembleCmd->nsPtr); - ckfree(ensembleCmd->fullSubcmdName); + TclCleanupCommandMacro(ensembleCmd->token); + if (ensembleCmd->fix) { + Tcl_DecrRefCount(ensembleCmd->fix); + } } else { /* * Kill the old internal rep, and replace it with a brand new one of @@ -2237,22 +2393,21 @@ MakeCachedEnsembleCommand( TclFreeIntRep(objPtr); ensembleCmd = ckalloc(sizeof(EnsembleCmdRep)); objPtr->internalRep.twoPtrValue.ptr1 = ensembleCmd; - objPtr->typePtr = &tclEnsembleCmdType; + objPtr->typePtr = &ensembleCmdType; } /* * Populate the internal rep. */ - ensembleCmd->nsPtr = ensemblePtr->nsPtr; ensembleCmd->epoch = ensemblePtr->epoch; - ensembleCmd->token = ensemblePtr->token; - ensemblePtr->nsPtr->refCount++; - ensembleCmd->realPrefixObj = prefixObjPtr; - length = strlen(subcommandName)+1; - ensembleCmd->fullSubcmdName = ckalloc(length); - memcpy(ensembleCmd->fullSubcmdName, subcommandName, (unsigned) length); - Tcl_IncrRefCount(ensembleCmd->realPrefixObj); + ensembleCmd->token = (Command *) ensemblePtr->token; + ensembleCmd->token->refCount++; + if (fix) { + Tcl_IncrRefCount(fix); + } + ensembleCmd->fix = fix; + ensembleCmd->hPtr = hPtr; } /* @@ -2276,13 +2431,31 @@ MakeCachedEnsembleCommand( */ static void +ClearTable( + EnsembleConfig *ensemblePtr) +{ + Tcl_HashTable *hash = &ensemblePtr->subcommandTable; + + if (hash->numEntries != 0) { + Tcl_HashSearch search; + Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(hash, &search); + + while (hPtr != NULL) { + Tcl_Obj *prefixObj = Tcl_GetHashValue(hPtr); + Tcl_DecrRefCount(prefixObj); + hPtr = Tcl_NextHashEntry(&search); + } + ckfree((char *) ensemblePtr->subcommandArrayPtr); + } + Tcl_DeleteHashTable(hash); +} + +static void DeleteEnsembleConfig( ClientData clientData) { EnsembleConfig *ensemblePtr = clientData; Namespace *nsPtr = ensemblePtr->nsPtr; - Tcl_HashSearch search; - Tcl_HashEntry *hEnt; /* * Unlink from the ensemble chain if it has not been marked as having been @@ -2316,17 +2489,7 @@ DeleteEnsembleConfig( * Kill the pointer-containing fields. */ - if (ensemblePtr->subcommandTable.numEntries != 0) { - ckfree(ensemblePtr->subcommandArrayPtr); - } - hEnt = Tcl_FirstHashEntry(&ensemblePtr->subcommandTable, &search); - while (hEnt != NULL) { - Tcl_Obj *prefixObj = Tcl_GetHashValue(hEnt); - - Tcl_DecrRefCount(prefixObj); - hEnt = Tcl_NextHashEntry(&search); - } - Tcl_DeleteHashTable(&ensemblePtr->subcommandTable); + ClearTable(ensemblePtr); if (ensemblePtr->subcmdList != NULL) { Tcl_DecrRefCount(ensemblePtr->subcmdList); } @@ -2382,100 +2545,107 @@ BuildEnsembleConfig( int i, j, isNew; Tcl_HashTable *hash = &ensemblePtr->subcommandTable; Tcl_HashEntry *hPtr; - - if (hash->numEntries != 0) { - /* - * Remove pre-existing table. - */ - - ckfree(ensemblePtr->subcommandArrayPtr); - hPtr = Tcl_FirstHashEntry(hash, &search); - while (hPtr != NULL) { - Tcl_Obj *prefixObj = Tcl_GetHashValue(hPtr); - - Tcl_DecrRefCount(prefixObj); - hPtr = Tcl_NextHashEntry(&search); - } - Tcl_DeleteHashTable(hash); - Tcl_InitHashTable(hash, TCL_STRING_KEYS); - } - - /* - * See if we've got an export list. If so, we will only export exactly - * those commands, which may be either implemented by the prefix in the - * subcommandDict or mapped directly onto the namespace's commands. - */ - - if (ensemblePtr->subcmdList != NULL) { - Tcl_Obj **subcmdv, *target, *cmdObj, *cmdPrefixObj; - int subcmdc; - - TclListObjGetElements(NULL, ensemblePtr->subcmdList, &subcmdc, - &subcmdv); - for (i=0 ; i<subcmdc ; i++) { - const char *name = TclGetString(subcmdv[i]); - - hPtr = Tcl_CreateHashEntry(hash, name, &isNew); - - /* - * Skip non-unique cases. + Tcl_Obj *mapDict = ensemblePtr->subcommandDict; + Tcl_Obj *subList = ensemblePtr->subcmdList; + + ClearTable(ensemblePtr); + Tcl_InitHashTable(hash, TCL_STRING_KEYS); + + if (subList) { + int subc; + Tcl_Obj **subv, *target, *cmdObj, *cmdPrefixObj; + char *name; + + /* + * There is a list of exactly what subcommands go in the table. + * Must determine the target for each. + */ + + Tcl_ListObjGetElements(NULL, subList, &subc, &subv); + if (subList == mapDict) { + /* + * Strange case where explicit list of subcommands is same value + * as the dict mapping to targets. + */ + + for (i = 0; i < subc; i += 2) { + name = TclGetString(subv[i]); + hPtr = Tcl_CreateHashEntry(hash, name, &isNew); + if (!isNew) { + cmdObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr); + Tcl_DecrRefCount(cmdObj); + } + Tcl_SetHashValue(hPtr, subv[i+1]); + Tcl_IncrRefCount(subv[i+1]); + + name = TclGetString(subv[i+1]); + hPtr = Tcl_CreateHashEntry(hash, name, &isNew); + if (isNew) { + cmdObj = Tcl_NewStringObj(name, -1); + cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); + Tcl_SetHashValue(hPtr, cmdPrefixObj); + Tcl_IncrRefCount(cmdPrefixObj); + } + } + } else { + /* + * Usual case where we can freely act on the list and dict. */ - if (!isNew) { - continue; - } + for (i = 0; i < subc; i++) { + name = TclGetString(subv[i]); + hPtr = Tcl_CreateHashEntry(hash, name, &isNew); + if (!isNew) { + continue; + } - /* - * Look in our dictionary (if present) for the command. - */ - - if (ensemblePtr->subcommandDict != NULL) { - Tcl_DictObjGet(NULL, ensemblePtr->subcommandDict, subcmdv[i], - &target); - if (target != NULL) { - Tcl_SetHashValue(hPtr, target); - Tcl_IncrRefCount(target); - continue; - } - } - - /* - * Not there, so map onto the namespace. Note in this case that we - * do not guarantee that the command is actually there; that is - * the programmer's responsibility (or [::unknown] of course). - */ - - cmdObj = NewNsObj((Tcl_Namespace *) ensemblePtr->nsPtr); - if (ensemblePtr->nsPtr->parentPtr != NULL) { - Tcl_AppendStringsToObj(cmdObj, "::", name, NULL); - } else { - Tcl_AppendStringsToObj(cmdObj, name, NULL); - } - cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); - Tcl_SetHashValue(hPtr, cmdPrefixObj); - Tcl_IncrRefCount(cmdPrefixObj); - } - } else if (ensemblePtr->subcommandDict != NULL) { - /* - * No subcmd list, but we do have a mapping dictionary so we should - * use the keys of that. Convert the dictionary's contents into the - * form required for the ensemble's internal hashtable. - */ - - Tcl_DictSearch dictSearch; - Tcl_Obj *keyObj, *valueObj; - int done; - - Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch, - &keyObj, &valueObj, &done); - while (!done) { - const char *name = TclGetString(keyObj); + /* + * Lookup target in the dictionary. + */ - hPtr = Tcl_CreateHashEntry(hash, name, &isNew); - Tcl_SetHashValue(hPtr, valueObj); - Tcl_IncrRefCount(valueObj); - Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done); - } + if (mapDict) { + Tcl_DictObjGet(NULL, mapDict, subv[i], &target); + if (target) { + Tcl_SetHashValue(hPtr, target); + Tcl_IncrRefCount(target); + continue; + } + } + + /* + * target was not in the dictionary so map onto the namespace. + * Note in this case that we do not guarantee that the command + * is actually there; that is the programmer's responsibility + * (or [::unknown] of course). + */ + + cmdObj = Tcl_NewStringObj(name, -1); + cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); + Tcl_SetHashValue(hPtr, cmdPrefixObj); + Tcl_IncrRefCount(cmdPrefixObj); + } + } + } else if (mapDict) { + /* + * No subcmd list, but we do have a mapping dictionary so we should + * use the keys of that. Convert the dictionary's contents into the + * form required for the ensemble's internal hashtable. + */ + + Tcl_DictSearch dictSearch; + Tcl_Obj *keyObj, *valueObj; + int done; + + Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch, + &keyObj, &valueObj, &done); + while (!done) { + char *name = TclGetString(keyObj); + + hPtr = Tcl_CreateHashEntry(hash, name, &isNew); + Tcl_SetHashValue(hPtr, valueObj); + Tcl_IncrRefCount(valueObj); + Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done); + } } else { /* * Discover what commands are actually exported by the namespace. @@ -2511,11 +2681,7 @@ BuildEnsembleConfig( if (isNew) { Tcl_Obj *cmdObj, *cmdPrefixObj; - TclNewObj(cmdObj); - Tcl_AppendStringsToObj(cmdObj, - ensemblePtr->nsPtr->fullName, - (ensemblePtr->nsPtr->parentPtr ? "::" : ""), - nsCmdName, NULL); + cmdObj = Tcl_NewStringObj(nsCmdName, -1); cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); Tcl_SetHashValue(hPtr, cmdPrefixObj); Tcl_IncrRefCount(cmdPrefixObj); @@ -2633,9 +2799,10 @@ FreeEnsembleCmdRep( { EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; - Tcl_DecrRefCount(ensembleCmd->realPrefixObj); - ckfree(ensembleCmd->fullSubcmdName); - TclNsDecrRefCount(ensembleCmd->nsPtr); + TclCleanupCommandMacro(ensembleCmd->token); + if (ensembleCmd->fix) { + Tcl_DecrRefCount(ensembleCmd->fix); + } ckfree(ensembleCmd); objPtr->typePtr = NULL; } @@ -2665,48 +2832,17 @@ DupEnsembleCmdRep( { EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; EnsembleCmdRep *ensembleCopy = ckalloc(sizeof(EnsembleCmdRep)); - int length = strlen(ensembleCmd->fullSubcmdName); - copyPtr->typePtr = &tclEnsembleCmdType; + copyPtr->typePtr = &ensembleCmdType; copyPtr->internalRep.twoPtrValue.ptr1 = ensembleCopy; - ensembleCopy->nsPtr = ensembleCmd->nsPtr; ensembleCopy->epoch = ensembleCmd->epoch; ensembleCopy->token = ensembleCmd->token; - ensembleCopy->nsPtr->refCount++; - ensembleCopy->realPrefixObj = ensembleCmd->realPrefixObj; - Tcl_IncrRefCount(ensembleCopy->realPrefixObj); - ensembleCopy->fullSubcmdName = ckalloc(length + 1); - memcpy(ensembleCopy->fullSubcmdName, ensembleCmd->fullSubcmdName, - (unsigned) length+1); -} - -/* - *---------------------------------------------------------------------- - * - * StringOfEnsembleCmdRep -- - * - * Creates a string representation of a Tcl_Obj that holds a subcommand - * of an ensemble. - * - * Results: - * None. - * - * Side effects: - * The object gains a string (UTF-8) representation. - * - *---------------------------------------------------------------------- - */ - -static void -StringOfEnsembleCmdRep( - Tcl_Obj *objPtr) -{ - EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; - int length = strlen(ensembleCmd->fullSubcmdName); - - objPtr->length = length; - objPtr->bytes = ckalloc(length + 1); - memcpy(objPtr->bytes, ensembleCmd->fullSubcmdName, (unsigned) length+1); + ensembleCopy->token->refCount++; + ensembleCopy->fix = ensembleCmd->fix; + if (ensembleCopy->fix) { + Tcl_IncrRefCount(ensembleCopy->fix); + } + ensembleCopy->hPtr = ensembleCmd->hPtr; } /* @@ -2748,15 +2884,9 @@ TclCompileEnsemble( int ourResult = TCL_ERROR; unsigned numBytes; const char *word; + DefineLineInformation; Tcl_IncrRefCount(replaced); - - /* - * This is where we return to if we are parsing multiple nested compiled - * ensembles. [info object] is such a beast. - */ - - checkNextWord: if (parsePtr->numWords < depth + 1) { goto failed; } @@ -2768,6 +2898,12 @@ TclCompileEnsemble( goto failed; } + /* + * This is where we return to if we are parsing multiple nested compiled + * ensembles. [info object] is such a beast. + */ + + checkNextWord: word = tokenPtr[1].start; numBytes = tokenPtr[1].size; @@ -2824,7 +2960,7 @@ TclCompileEnsemble( goto failed; } for (i=0 ; i<len ; i++) { - str = Tcl_GetStringFromObj(elems[i], &sclen); + str = TclGetStringFromObj(elems[i], &sclen); if ((sclen == (int) numBytes) && !memcmp(word, str, numBytes)) { /* * Exact match! Excellent! @@ -2978,6 +3114,17 @@ TclCompileEnsemble( if (cmdPtr->compileProc == TclCompileEnsemble) { tokenPtr = TokenAfter(tokenPtr); + if (parsePtr->numWords < depth + 1 + || tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + /* + * Too hard because the user has done something unpleasant like + * omitting the sub-ensemble's command name or used a non-constant + * name for a sub-ensemble's command name; we respond by bailing + * out completely (this is a rare case). [Bug 6d2f249a01] + */ + + goto cleanup; + } ensemble = (Tcl_Command) cmdPtr; goto checkNextWord; } @@ -2997,6 +3144,23 @@ TclCompileEnsemble( } /* + * Throw out any line information generated by the failed compile attempt. + */ + + while (mapPtr->nuloc - 1 > eclIndex) { + mapPtr->nuloc--; + ckfree(mapPtr->loc[mapPtr->nuloc].line); + mapPtr->loc[mapPtr->nuloc].line = NULL; + } + + /* + * Reset the index of next command. Toss out any from failed nested + * partial compiles. + */ + + envPtr->numCommands = mapPtr->nuloc; + + /* * Failed to do a full compile for some reason. Try to do a direct invoke * instead of going through the ensemble lookup process again. */ @@ -3008,8 +3172,24 @@ TclCompileEnsemble( cmdPtr = oldCmdPtr; depth--; } - (void) Tcl_ListObjReplace(NULL, replaced, depth, 2, 0, NULL); } + /* + * The length of the "replaced" list must be depth-1. Trim back + * any extra elements that might have been appended by failing + * pathways above. + */ + (void) Tcl_ListObjReplace(NULL, replaced, depth-1, LIST_MAX, 0, NULL); + + /* + * TODO: Reconsider whether we ought to call CompileToInvokedCommand() + * when depth==1. In that case we are choosing to emit the + * INST_INVOKE_REPLACE bytecode when there is in fact no replacing + * to be done. It would be equally functional and presumably more + * performant to fall through to cleanup below, return TCL_ERROR, + * and let the compiler harness emit the INST_INVOKE_STK + * implementation for us. + */ + CompileToInvokedCommand(interp, parsePtr, replaced, cmdPtr, envPtr); ourResult = TCL_OK; } @@ -3037,6 +3217,11 @@ TclAttemptCompileProc( Tcl_Token *saveTokenPtr = parsePtr->tokenPtr; int savedStackDepth = envPtr->currStackDepth; unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart; + int savedAuxDataArrayNext = envPtr->auxDataArrayNext; + int savedExceptArrayNext = envPtr->exceptArrayNext; +#ifdef TCL_COMPILE_DEBUG + int savedExceptDepth = envPtr->exceptDepth; +#endif DefineLineInformation; if (cmdPtr->compileProc == NULL) { @@ -3070,7 +3255,7 @@ TclAttemptCompileProc( result = cmdPtr->compileProc(interp, parsePtr, cmdPtr, envPtr); /* - * Undo the shift. + * Undo the shift. */ mapPtr->loc[eclIndex].line -= (depth - 1); @@ -3085,7 +3270,45 @@ TclAttemptCompileProc( * we avoid compiling subcommands that recursively call TclCompileScript(). */ +#ifdef TCL_COMPILE_DEBUG + if (envPtr->exceptDepth != savedExceptDepth) { + Tcl_Panic("ExceptionRange Starts and Ends do not balance"); + } +#endif + if (result != TCL_OK) { + ExceptionAux *auxPtr = envPtr->exceptAuxArrayPtr; + + for (i = 0; i < savedExceptArrayNext; i++) { + while (auxPtr->numBreakTargets > 0 + && auxPtr->breakTargets[auxPtr->numBreakTargets - 1] + >= savedCodeNext) { + auxPtr->numBreakTargets--; + } + while (auxPtr->numContinueTargets > 0 + && auxPtr->continueTargets[auxPtr->numContinueTargets - 1] + >= savedCodeNext) { + auxPtr->numContinueTargets--; + } + auxPtr++; + } + envPtr->exceptArrayNext = savedExceptArrayNext; + + if (savedAuxDataArrayNext != envPtr->auxDataArrayNext) { + AuxData *auxDataPtr = envPtr->auxDataArrayPtr; + AuxData *auxDataEnd = auxDataPtr; + + auxDataPtr += savedAuxDataArrayNext; + auxDataEnd += envPtr->auxDataArrayNext; + + while (auxDataPtr < auxDataEnd) { + if (auxDataPtr->type->freeProc != NULL) { + auxDataPtr->type->freeProc(auxDataPtr->clientData); + } + auxDataPtr++; + } + envPtr->auxDataArrayNext = savedAuxDataArrayNext; + } envPtr->currStackDepth = savedStackDepth; envPtr->codeNext = envPtr->codeStart + savedCodeNext; #ifdef TCL_COMPILE_DEBUG @@ -3126,7 +3349,7 @@ CompileToInvokedCommand( Tcl_Token *tokPtr; Tcl_Obj *objPtr, **words; char *bytes; - int length, i, numWords, cmdLit; + int i, numWords, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME; DefineLineInformation; /* @@ -3139,15 +3362,15 @@ CompileToInvokedCommand( for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++, tokPtr = TokenAfter(tokPtr)) { if (i > 0 && i < numWords+1) { - bytes = Tcl_GetStringFromObj(words[i-1], &length); - PushLiteral(envPtr, bytes, length); + bytes = TclGetString(words[i-1]); + PushLiteral(envPtr, bytes, words[i-1]->length); continue; } SetLineInformation(i); if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) { - int literal = TclRegisterNewLiteral(envPtr, - tokPtr[1].start, tokPtr[1].size); + int literal = TclRegisterLiteral(envPtr, + tokPtr[1].start, tokPtr[1].size, 0); if (envPtr->clNext) { TclContinuationsEnterDerived( @@ -3168,8 +3391,11 @@ CompileToInvokedCommand( objPtr = Tcl_NewObj(); Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); - bytes = Tcl_GetStringFromObj(objPtr, &length); - cmdLit = TclRegisterNewCmdLiteral(envPtr, bytes, length); + bytes = TclGetString(objPtr); + if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) { + extraLiteralFlags |= LITERAL_UNSHARED; + } + cmdLit = TclRegisterLiteral(envPtr, bytes, objPtr->length, extraLiteralFlags); TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLit), cmdPtr); TclEmitPush(cmdLit, envPtr); TclDecrRefCount(objPtr); @@ -3178,9 +3404,7 @@ CompileToInvokedCommand( * Do the replacing dispatch. */ - TclEmitInstInt4(INST_INVOKE_REPLACE, parsePtr->numWords, envPtr); - TclEmitInt1(numWords+1, envPtr); - TclAdjustStackDepth(-1, envPtr); /* Correction to stack depth calcs. */ + TclEmitInvoke(envPtr, INST_INVOKE_REPLACE, parsePtr->numWords,numWords+1); } /* diff --git a/generic/tclEnv.c b/generic/tclEnv.c index b5ae6ea..40ced17 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -43,11 +43,6 @@ static char * EnvTraceProc(ClientData clientData, Tcl_Interp *interp, static void ReplaceString(const char *oldStr, char *newStr); MODULE_SCOPE void TclSetEnv(const char *name, const char *value); MODULE_SCOPE void TclUnsetEnv(const char *name); - -#if defined(__CYGWIN__) - static void TclCygwinPutenv(char *string); -# define putenv TclCygwinPutenv -#endif /* *---------------------------------------------------------------------- @@ -76,36 +71,56 @@ TclSetupEnv( Tcl_Interp *interp) /* Interpreter whose "env" array is to be * managed. */ { + Var *varPtr, *arrayPtr; + Tcl_Obj *varNamePtr; Tcl_DString envString; - char *p1, *p2; - int i; + Tcl_HashTable namesHash; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; /* * Synchronize the values in the environ array with the contents of the * Tcl "env" variable. To do this: - * 1) Remove the trace that fires when the "env" var is unset. - * 2) Unset the "env" variable. - * 3) If there are no environ variables, create an empty "env" array. - * Otherwise populate the array with current values. - * 4) Add a trace that synchronizes the "env" array. + * 1) Remove the trace that fires when the "env" var is updated. + * 2) Find the existing contents of the "env", storing in a hash table. + * 3) Create/update elements for each environ variable, removing + * elements from the hash table as we go. + * 4) Remove the elements for each remaining entry in the hash table, + * which must have existed before yet have no analog in the environ + * variable. + * 5) Add a trace that synchronizes the "env" array. */ Tcl_UntraceVar2(interp, "env", NULL, TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc, NULL); - Tcl_UnsetVar2(interp, "env", NULL, TCL_GLOBAL_ONLY); + /* + * Find out what elements are currently in the global env array. + */ - if (environ[0] == NULL) { - Tcl_Obj *varNamePtr; + TclNewLiteralStringObj(varNamePtr, "env"); + Tcl_IncrRefCount(varNamePtr); + Tcl_InitObjHashTable(&namesHash); + varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL, TCL_GLOBAL_ONLY, + /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); + TclFindArrayPtrElements(varPtr, &namesHash); + + /* + * Go through the environment array and transfer its values into Tcl. At + * the same time, remove those elements we add/update from the hash table + * of existing elements, so that after this part processes, that table + * will hold just the parts to remove. + */ + + if (environ[0] != NULL) { + int i; - TclNewLiteralStringObj(varNamePtr, "env"); - Tcl_IncrRefCount(varNamePtr); - TclArraySet(interp, varNamePtr, NULL); - Tcl_DecrRefCount(varNamePtr); - } else { Tcl_MutexLock(&envMutex); for (i = 0; environ[i] != NULL; i++) { + Tcl_Obj *obj1, *obj2; + char *p1, *p2; + p1 = Tcl_ExternalToUtfDString(NULL, environ[i], -1, &envString); p2 = strchr(p1, '='); if (p2 == NULL) { @@ -115,16 +130,46 @@ TclSetupEnv( * '='; ignore the entry. */ + Tcl_DStringFree(&envString); continue; } p2++; p2[-1] = '\0'; - Tcl_SetVar2(interp, "env", p1, p2, TCL_GLOBAL_ONLY); + obj1 = Tcl_NewStringObj(p1, -1); + obj2 = Tcl_NewStringObj(p2, -1); Tcl_DStringFree(&envString); + + Tcl_IncrRefCount(obj1); + Tcl_IncrRefCount(obj2); + Tcl_ObjSetVar2(interp, varNamePtr, obj1, obj2, TCL_GLOBAL_ONLY); + hPtr = Tcl_FindHashEntry(&namesHash, obj1); + if (hPtr != NULL) { + Tcl_DeleteHashEntry(hPtr); + } + Tcl_DecrRefCount(obj1); + Tcl_DecrRefCount(obj2); } Tcl_MutexUnlock(&envMutex); } + /* + * Delete those elements that existed in the array but which had no + * counterparts in the environment array. + */ + + for (hPtr=Tcl_FirstHashEntry(&namesHash, &search); hPtr!=NULL; + hPtr=Tcl_NextHashEntry(&search)) { + Tcl_Obj *elemName = Tcl_GetHashValue(hPtr); + + TclObjUnsetVar2(interp, varNamePtr, elemName, TCL_GLOBAL_ONLY); + } + Tcl_DeleteHashTable(&namesHash); + Tcl_DecrRefCount(varNamePtr); + + /* + * Re-establish the trace. + */ + Tcl_TraceVar2(interp, "env", NULL, TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc, NULL); @@ -395,7 +440,7 @@ TclUnsetEnv( * that no = should be included, and Windows requires it. */ -#if defined(__WIN32__) || defined(__CYGWIN__) +#if defined(_WIN32) string = ckalloc(length + 2); memcpy(string, name, (size_t) length); string[length] = '='; @@ -404,7 +449,7 @@ TclUnsetEnv( string = ckalloc(length + 1); memcpy(string, name, (size_t) length); string[length] = '\0'; -#endif /* WIN32 */ +#endif /* _WIN32 */ Tcl_UtfToExternalDString(NULL, string, -1, &envString); string = ckrealloc(string, Tcl_DStringLength(&envString) + 1); @@ -507,7 +552,8 @@ TclGetEnv( * array. * * Results: - * Always returns NULL to indicate success. + * Returns NULL to indicate success, or an error-message if the array + * element being handled doesn't exist. * * Side effects: * Environment variable changes get propagated. If the whole "env" array @@ -677,111 +723,30 @@ TclFinalizeEnvironment(void) * strings. This may leak more memory that strictly necessary, since some * of the strings may no longer be in the environment. However, * determining which ones are ok to delete is n-squared, and is pretty - * unlikely, so we don't bother. + * unlikely, so we don't bother. However, in the case of DPURIFY, just + * free all strings in the cache. */ if (env.cache) { +#ifdef PURIFY + int i; + for (i = 0; i < env.cacheSize; i++) { + ckfree(env.cache[i]); + } +#endif ckfree(env.cache); env.cache = NULL; env.cacheSize = 0; #ifndef USE_PUTENV + if ((env.ourEnviron != NULL)) { + ckfree(env.ourEnviron); + env.ourEnviron = NULL; + } env.ourEnvironSize = 0; #endif } } -#if defined(__CYGWIN__) - -/* - * When using cygwin, when an environment variable changes, we need to synch - * with both the cygwin 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). - */ -DLLIMPORT extern void __stdcall SetEnvironmentVariableA(const char*, const char *); - -static void -TclCygwinPutenv( - char *str) -{ - char *name, *value; - - /* - * Get the name and value, so that we can change the environment variable - * for Windows. - */ - - name = alloca(strlen(str) + 1); - strcpy(name, str); - for (value=name ; *value!='=' && *value!='\0' ; ++value) { - /* Empty body */ - } - if (*value == '\0') { - /* Can't happen. */ - return; - } - *(value++) = '\0'; - if (*value == '\0') { - value = NULL; - } - - /* - * Set the cygwin 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 know 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) { - SetEnvironmentVariableA("PATH", NULL); - unsetenv("PATH"); - } - - SetEnvironmentVariableA(name, value); - } else { - char *buf; - - /* - * Eliminate any Path variable, to prevent any confusion. - */ - - SetEnvironmentVariableA("Path", NULL); - unsetenv("Path"); - - if (value == NULL) { - buf = NULL; - } else { - int size; - - size = cygwin_conv_path_list(0, value, NULL, 0); - buf = alloca(size + 1); - cygwin_conv_path_list(0, value, buf, size); - } - - SetEnvironmentVariableA(name, buf); - } -} -#endif /* __CYGWIN__ */ - /* * Local Variables: * mode: c diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 686b80d..913ff0f 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -37,7 +37,7 @@ typedef struct BgError { * pending background errors for the interpreter. */ -typedef struct ErrAssocData { +typedef struct { Tcl_Interp *interp; /* Interpreter in which error occurred. */ Tcl_Obj *cmdPrefix; /* First word(s) of the handler command */ BgError *firstBgPtr; /* First in list of all background errors @@ -89,7 +89,7 @@ static int subsystemsInitialized = 0; * non-NULL value. */ -static Tcl_ExitProc *appExitPtr = NULL; +static TCL_NORETURN1 Tcl_ExitProc *appExitPtr = NULL; typedef struct ThreadSpecificData { ExitHandler *firstExitPtr; /* First in list of all exit handlers for this @@ -100,7 +100,7 @@ typedef struct ThreadSpecificData { } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; -#ifdef TCL_THREADS +#if TCL_THREADS typedef struct { Tcl_ThreadCreateProc *proc; /* Main() function of the thread */ ClientData clientData; /* The one argument to Main() */ @@ -119,6 +119,7 @@ static char * VwaitVarProc(ClientData clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); static void InvokeExitHandlers(void); +static void FinalizeThread(int quick); /* *---------------------------------------------------------------------- @@ -262,7 +263,7 @@ HandleBgErrors( if (errChannel != NULL) { Tcl_Obj *options = Tcl_GetReturnOptions(interp, code); - Tcl_Obj *keyPtr, *valuePtr; + Tcl_Obj *keyPtr, *valuePtr = NULL; TclNewLiteralStringObj(keyPtr, "-errorinfo"); Tcl_IncrRefCount(keyPtr); @@ -314,7 +315,7 @@ TclDefaultBgErrorHandlerObjCmd( { Tcl_Obj *keyPtr, *valuePtr; Tcl_Obj *tempObjv[2]; - int code, level; + int result, code, level; Tcl_InterpState saved; if (objc != 3) { @@ -328,9 +329,9 @@ TclDefaultBgErrorHandlerObjCmd( TclNewLiteralStringObj(keyPtr, "-level"); Tcl_IncrRefCount(keyPtr); - Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr); + result = Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr); Tcl_DecrRefCount(keyPtr); - if (valuePtr == NULL) { + if (result != TCL_OK || valuePtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing return option \"-level\"", -1)); Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); @@ -341,9 +342,9 @@ TclDefaultBgErrorHandlerObjCmd( } TclNewLiteralStringObj(keyPtr, "-code"); Tcl_IncrRefCount(keyPtr); - Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr); + result = Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr); Tcl_DecrRefCount(keyPtr); - if (valuePtr == NULL) { + if (result != TCL_OK || valuePtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing return option \"-code\"", -1)); Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); @@ -406,17 +407,17 @@ TclDefaultBgErrorHandlerObjCmd( TclNewLiteralStringObj(keyPtr, "-errorcode"); Tcl_IncrRefCount(keyPtr); - Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr); + result = Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr); Tcl_DecrRefCount(keyPtr); - if (valuePtr) { + if (result == TCL_OK && valuePtr != NULL) { Tcl_SetObjErrorCode(interp, valuePtr); } TclNewLiteralStringObj(keyPtr, "-errorinfo"); Tcl_IncrRefCount(keyPtr); - Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr); + result = Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr); Tcl_DecrRefCount(keyPtr); - if (valuePtr) { + if (result == TCL_OK && valuePtr != NULL) { Tcl_AppendObjToErrorInfo(interp, valuePtr); } @@ -856,7 +857,7 @@ Tcl_DeleteThreadExitHandler( Tcl_ExitProc * Tcl_SetExitProc( - Tcl_ExitProc *proc) /* New exit handler for app or NULL */ + TCL_NORETURN1 Tcl_ExitProc *proc) /* New exit handler for app or NULL */ { Tcl_ExitProc *prevExitProc; @@ -891,7 +892,7 @@ Tcl_SetExitProc( *---------------------------------------------------------------------- */ static void -InvokeExitHandlers(void) +InvokeExitHandlers(void) { ExitHandler *exitPtr; @@ -932,12 +933,12 @@ InvokeExitHandlers(void) *---------------------------------------------------------------------- */ -void +TCL_NORETURN void Tcl_Exit( int status) /* Exit status for application; typically 0 * for normal return, 1 for error return. */ { - Tcl_ExitProc *currentAppExitPtr; + TCL_NORETURN1 Tcl_ExitProc *currentAppExitPtr; Tcl_MutexLock(&exitMutex); currentAppExitPtr = appExitPtr; @@ -967,23 +968,23 @@ Tcl_Exit( /* * Fast and deterministic exit (default behavior) */ - + InvokeExitHandlers(); - + /* * Ensure the thread-specific data is initialised as it is used in * Tcl_FinalizeThread() */ - + (void) TCL_TSD_INIT(&dataKey); - + /* * Now finalize the calling thread only (others are not safely * reachable). Among other things, this triggers a flush of the * Tcl_Channels that may have data enqueued. */ - - Tcl_FinalizeThread(); + + FinalizeThread(/* quick */ 1); } TclpExit(status); Tcl_Panic("OS exit failed!"); @@ -1042,6 +1043,9 @@ TclInitSubsystems(void) #if USE_TCLALLOC TclInitAlloc(); /* Process wide mutex init */ #endif +#if TCL_THREADS && defined(USE_THREAD_ALLOC) + TclInitThreadAlloc(); /* Setup thread allocator caches */ +#endif #ifdef TCL_MEM_DEBUG TclInitDbCkalloc(); /* Process wide mutex init */ #endif @@ -1053,7 +1057,6 @@ TclInitSubsystems(void) * mutexes. */ TclInitIOSubsystem(); /* Inits a tsd key (noop). */ TclInitEncodingSubsystem(); /* Process wide encoding init. */ - TclpSetInterfaces(); TclInitNamespaceSubsystem();/* Register ns obj type (mutexed). */ subsystemsInitialized = 1; } @@ -1089,7 +1092,7 @@ Tcl_Finalize(void) * Invoke exit handlers first. */ - InvokeExitHandlers(); + InvokeExitHandlers(); TclpInitLock(); if (subsystemsInitialized == 0) { @@ -1171,8 +1174,6 @@ Tcl_Finalize(void) TclFinalizeEncodingSubsystem(); - Tcl_SetPanicProc(NULL); - /* * Repeat finalization of the thread local storage once more. Although * this step is already done by the Tcl_FinalizeThread call above, series @@ -1185,7 +1186,7 @@ Tcl_Finalize(void) * This fixes the Tcl Bug #990552. */ - TclFinalizeThreadData(); + TclFinalizeThreadData(/* quick */ 0); /* * Now we can free constants for conversions to/from double. @@ -1219,7 +1220,7 @@ Tcl_Finalize(void) * Close down the thread-specific object allocator. */ -#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) +#if TCL_THREADS && defined(USE_THREAD_ALLOC) TclFinalizeThreadAlloc(); #endif @@ -1271,6 +1272,13 @@ Tcl_Finalize(void) void Tcl_FinalizeThread(void) { + FinalizeThread(/* quick */ 0); +} + +void +FinalizeThread( + int quick) +{ ExitHandler *exitPtr; ThreadSpecificData *tsdPtr; @@ -1311,8 +1319,7 @@ Tcl_FinalizeThread(void) * * Fix [Bug #571002] */ - - TclFinalizeThreadData(); + TclFinalizeThreadData(quick); } /* @@ -1457,6 +1464,8 @@ VwaitVarProc( int *donePtr = clientData; *donePtr = 1; + Tcl_UntraceVar(interp, name1, TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + VwaitVarProc, clientData); return NULL; } @@ -1529,7 +1538,7 @@ Tcl_UpdateObjCmd( return TCL_OK; } -#ifdef TCL_THREADS +#if TCL_THREADS /* *---------------------------------------------------------------------- * @@ -1592,7 +1601,7 @@ Tcl_CreateThread( int flags) /* Flags controlling behaviour of the new * thread. */ { -#ifdef TCL_THREADS +#if TCL_THREADS ThreadClientData *cdPtr = ckalloc(sizeof(ThreadClientData)); int result; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index f6072a1..82de752 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -20,10 +20,7 @@ #include "tclOOInt.h" #include "tommath.h" #include <math.h> - -#if NRE_ENABLE_ASSERTS #include <assert.h> -#endif /* * Hack to determine whether we may expect IEEE floating point. The hack is @@ -37,14 +34,14 @@ #endif /* - * A mask (should be 2**n-1) that is used to work out when the bytecode engine - * should call Tcl_AsyncReady() to see whether there is a signal that needs - * handling. + * A counter that is used to work out when the bytecode engine should call + * Tcl_AsyncReady() to see whether there is a signal that needs handling, and + * other expensive periodic operations. */ -#ifndef ASYNC_CHECK_COUNT_MASK -# define ASYNC_CHECK_COUNT_MASK 63 -#endif /* !ASYNC_CHECK_COUNT_MASK */ +#ifndef ASYNC_CHECK_COUNT +# define ASYNC_CHECK_COUNT 64 +#endif /* !ASYNC_CHECK_COUNT */ /* * Boolean flag indicating whether the Tcl bytecode interpreter has been @@ -81,9 +78,7 @@ int tclTraceExec = 0; static const char *const operatorStrings[] = { "||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>", - "+", "-", "*", "/", "%", "+", "-", "~", "!", - "BUILTIN FUNCTION", "FUNCTION", - "", "", "", "", "", "", "", "", "eq", "ne" + "+", "-", "*", "/", "%", "+", "-", "~", "!" }; /* @@ -174,29 +169,24 @@ static BuiltinFunc const tclBuiltinFuncTable[] = { typedef struct TEBCdata { ByteCode *codePtr; /* Constant until the BC returns */ /* -----------------------------------------*/ - const unsigned char *pc; /* These fields are used on return TO this */ - ptrdiff_t *catchTop; /* this level: they record the state when a */ - int cleanup; /* new codePtr was received for NR */ - Tcl_Obj *auxObjList; /* execution. */ - int checkInterp; - CmdFrame cmdFrame; + ptrdiff_t *catchTop; /* These fields are used on return TO this */ + Tcl_Obj *auxObjList; /* this level: they record the state when a */ + CmdFrame cmdFrame; /* new codePtr was received for NR */ + /* execution. */ void *stack[1]; /* Start of the actual combined catch and obj * stacks; the struct will be expanded as * necessary */ } TEBCdata; #define TEBC_YIELD() \ - do { \ - esPtr->tosPtr = tosPtr; \ - TD->pc = pc; \ - TD->cleanup = cleanup; \ - TclNRAddCallback(interp, TEBCresume, TD, INT2PTR(1), NULL, NULL); \ + do { \ + esPtr->tosPtr = tosPtr; \ + TclNRAddCallback(interp, TEBCresume, \ + TD, pc, INT2PTR(cleanup), NULL); \ } while (0) #define TEBC_DATA_DIG() \ do { \ - pc = TD->pc; \ - cleanup = TD->cleanup; \ tosPtr = esPtr->tosPtr; \ } while (0) @@ -205,14 +195,14 @@ typedef struct TEBCdata { if (auxObjList) { \ objPtr->length += auxObjList->length; \ } \ - objPtr->internalRep.ptrAndLongRep.ptr = auxObjList; \ + objPtr->internalRep.twoPtrValue.ptr1 = auxObjList; \ auxObjList = objPtr; \ } while (0) #define POP_TAUX_OBJ() \ do { \ tmpPtr = auxObjList; \ - auxObjList = tmpPtr->internalRep.ptrAndLongRep.ptr; \ + auxObjList = tmpPtr->internalRep.twoPtrValue.ptr1; \ Tcl_DecrRefCount(tmpPtr); \ } while (0) @@ -293,12 +283,14 @@ VarHashCreateVar( switch (nCleanup) { \ case 1: goto cleanup1_pushObjResultPtr; \ case 2: goto cleanup2_pushObjResultPtr; \ + case 0: break; \ } \ } else { \ pc += (pcAdjustment); \ switch (nCleanup) { \ case 1: goto cleanup1; \ case 2: goto cleanup2; \ + case 0: break; \ } \ } \ } while (0) @@ -318,6 +310,70 @@ VarHashCreateVar( } \ } while (0) +#ifndef TCL_COMPILE_DEBUG +#define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \ + do { \ + pc += (pcAdjustment); \ + switch (*pc) { \ + case INST_JUMP_FALSE1: \ + NEXT_INST_F(((condition)? 2 : TclGetInt1AtPtr(pc+1)), (cleanup), 0); \ + case INST_JUMP_TRUE1: \ + NEXT_INST_F(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \ + case INST_JUMP_FALSE4: \ + NEXT_INST_F(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup), 0); \ + case INST_JUMP_TRUE4: \ + NEXT_INST_F(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \ + default: \ + if ((condition) < 0) { \ + TclNewIntObj(objResultPtr, -1); \ + } else { \ + objResultPtr = TCONST((condition) > 0); \ + } \ + NEXT_INST_F(0, (cleanup), 1); \ + } \ + } while (0) +#define JUMP_PEEPHOLE_V(condition, pcAdjustment, cleanup) \ + do { \ + pc += (pcAdjustment); \ + switch (*pc) { \ + case INST_JUMP_FALSE1: \ + NEXT_INST_V(((condition)? 2 : TclGetInt1AtPtr(pc+1)), (cleanup), 0); \ + case INST_JUMP_TRUE1: \ + NEXT_INST_V(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \ + case INST_JUMP_FALSE4: \ + NEXT_INST_V(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup), 0); \ + case INST_JUMP_TRUE4: \ + NEXT_INST_V(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \ + default: \ + if ((condition) < 0) { \ + TclNewIntObj(objResultPtr, -1); \ + } else { \ + objResultPtr = TCONST((condition) > 0); \ + } \ + NEXT_INST_V(0, (cleanup), 1); \ + } \ + } while (0) +#else /* TCL_COMPILE_DEBUG */ +#define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \ + do{ \ + if ((condition) < 0) { \ + TclNewIntObj(objResultPtr, -1); \ + } else { \ + objResultPtr = TCONST((condition) > 0); \ + } \ + NEXT_INST_F((pcAdjustment), (cleanup), 1); \ + } while (0) +#define JUMP_PEEPHOLE_V(condition, pcAdjustment, cleanup) \ + do{ \ + if ((condition) < 0) { \ + TclNewIntObj(objResultPtr, -1); \ + } else { \ + objResultPtr = TCONST((condition) > 0); \ + } \ + NEXT_INST_V((pcAdjustment), (cleanup), 1); \ + } while (0) +#endif + /* * Macros used to cache often-referenced Tcl evaluation stack information * in local variables. Note that a DECACHE_STACK_INFO()-CACHE_STACK_INFO() @@ -360,6 +416,8 @@ VarHashCreateVar( #define CURR_DEPTH ((ptrdiff_t) (tosPtr - initTosPtr)) +#define STACK_BASE(esPtr) ((esPtr)->stackWords - 1) + /* * Macros used to trace instruction execution. The macros TRACE, * TRACE_WITH_OBJ, and O2S are only used inside TclNRExecuteByteCode. O2S is @@ -381,6 +439,8 @@ VarHashCreateVar( printf a; \ break; \ } +# define TRACE_ERROR(interp) \ + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); # define TRACE_WITH_OBJ(a, objPtr) \ while (traceInstructions) { \ fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \ @@ -397,6 +457,7 @@ VarHashCreateVar( #else /* !TCL_COMPILE_DEBUG */ # define TRACE(a) # define TRACE_APPEND(a) +# define TRACE_ERROR(interp) # define TRACE_WITH_OBJ(a, objPtr) # define O2S(objPtr) #endif /* TCL_COMPILE_DEBUG */ @@ -437,29 +498,8 @@ VarHashCreateVar( * ClientData *ptrPtr, int *tPtr); */ -#ifdef TCL_WIDE_INT_IS_LONG #define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ (((objPtr)->typePtr == &tclIntType) \ - ? (*(tPtr) = TCL_NUMBER_LONG, \ - *(ptrPtr) = (ClientData) \ - (&((objPtr)->internalRep.longValue)), TCL_OK) : \ - ((objPtr)->typePtr == &tclDoubleType) \ - ? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \ - ? (*(tPtr) = TCL_NUMBER_NAN) \ - : (*(tPtr) = TCL_NUMBER_DOUBLE)), \ - *(ptrPtr) = (ClientData) \ - (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ - ((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \ - (((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \ - ? TCL_ERROR : \ - TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) -#else /* !TCL_WIDE_INT_IS_LONG */ -#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ - (((objPtr)->typePtr == &tclIntType) \ - ? (*(tPtr) = TCL_NUMBER_LONG, \ - *(ptrPtr) = (ClientData) \ - (&((objPtr)->internalRep.longValue)), TCL_OK) : \ - ((objPtr)->typePtr == &tclWideIntType) \ ? (*(tPtr) = TCL_NUMBER_WIDE, \ *(ptrPtr) = (ClientData) \ (&((objPtr)->internalRep.wideValue)), TCL_OK) : \ @@ -469,49 +509,9 @@ VarHashCreateVar( : (*(tPtr) = TCL_NUMBER_DOUBLE)), \ *(ptrPtr) = (ClientData) \ (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ - ((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \ - (((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \ - ? TCL_ERROR : \ + (((objPtr)->bytes != NULL) && ((objPtr)->length == 0)) \ + ? TCL_ERROR : \ TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) -#endif /* TCL_WIDE_INT_IS_LONG */ - -/* - * Macro used in this file to save a function call for common uses of - * Tcl_GetBooleanFromObj(). The ANSI C "prototype" is: - * - * MODULE_SCOPE int TclGetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - * int *boolPtr); - */ - -#define TclGetBooleanFromObj(interp, objPtr, boolPtr) \ - ((((objPtr)->typePtr == &tclIntType) \ - || ((objPtr)->typePtr == &tclBooleanType)) \ - ? (*(boolPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \ - : Tcl_GetBooleanFromObj((interp), (objPtr), (boolPtr))) - -/* - * Macro used in this file to save a function call for common uses of - * Tcl_GetWideIntFromObj(). The ANSI C "prototype" is: - * - * MODULE_SCOPE int TclGetWideIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - * Tcl_WideInt *wideIntPtr); - */ - -#ifdef TCL_WIDE_INT_IS_LONG -#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ - (((objPtr)->typePtr == &tclIntType) \ - ? (*(wideIntPtr) = (Tcl_WideInt) \ - ((objPtr)->internalRep.longValue), TCL_OK) : \ - Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) -#else /* !TCL_WIDE_INT_IS_LONG */ -#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ - (((objPtr)->typePtr == &tclWideIntType) \ - ? (*(wideIntPtr) = (objPtr)->internalRep.wideValue, TCL_OK) : \ - ((objPtr)->typePtr == &tclIntType) \ - ? (*(wideIntPtr) = (Tcl_WideInt) \ - ((objPtr)->internalRep.longValue), TCL_OK) : \ - Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) -#endif /* TCL_WIDE_INT_IS_LONG */ /* * Macro used to make the check for type overflow more mnemonic. This works by @@ -541,40 +541,6 @@ VarHashCreateVar( * Auxiliary tables used to compute powers of small integers. */ -#if (LONG_MAX == 0x7fffffff) - -/* - * Maximum base that, when raised to powers 2, 3, ... 8, fits in a 32-bit - * signed integer. - */ - -static const long MaxBase32[] = {46340, 1290, 215, 73, 35, 21, 14}; -static const size_t MaxBase32Size = sizeof(MaxBase32)/sizeof(long); - -/* - * Table giving 3, 4, ..., 11, raised to the powers 9, 10, ..., as far as they - * fit in a 32-bit signed integer. Exp32Index[i] gives the starting index of - * powers of i+3; Exp32Value[i] gives the corresponding powers. - */ - -static const unsigned short Exp32Index[] = { - 0, 11, 18, 23, 26, 29, 31, 32, 33 -}; -static const size_t Exp32IndexSize = - sizeof(Exp32Index) / sizeof(unsigned short); -static const long Exp32Value[] = { - 19683, 59049, 177147, 531441, 1594323, 4782969, 14348907, 43046721, - 129140163, 387420489, 1162261467, 262144, 1048576, 4194304, - 16777216, 67108864, 268435456, 1073741824, 1953125, 9765625, - 48828125, 244140625, 1220703125, 10077696, 60466176, 362797056, - 40353607, 282475249, 1977326743, 134217728, 1073741824, 387420489, - 1000000000 -}; -static const size_t Exp32ValueSize = sizeof(Exp32Value)/sizeof(long); -#endif /* LONG_MAX == 0x7fffffff -- 32 bit machine */ - -#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) - /* * Maximum base that, when raised to powers 2, 3, ..., 16, fits in a * Tcl_WideInt. @@ -678,7 +644,6 @@ static const Tcl_WideInt Exp64Value[] = { (Tcl_WideInt)371293*371293*371293*13*13 }; static const size_t Exp64ValueSize = sizeof(Exp64Value) / sizeof(Tcl_WideInt); -#endif /* (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) */ /* * Markers for ExecuteExtendedBinaryMathOp. @@ -709,8 +674,6 @@ static ByteCode * CompileExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr); static void DeleteExecStack(ExecStack *esPtr); static void DupExprCodeInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); -MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr, - Tcl_Obj *value2Ptr); static Tcl_Obj * ExecuteExtendedBinaryMathOp(Tcl_Interp *interp, int opcode, Tcl_Obj **constants, Tcl_Obj *valuePtr, Tcl_Obj *value2Ptr); @@ -718,7 +681,7 @@ static Tcl_Obj * ExecuteExtendedUnaryMathOp(int opcode, Tcl_Obj *valuePtr); static void FreeExprCodeInternalRep(Tcl_Obj *objPtr); static ExceptionRange * GetExceptRangeForPc(const unsigned char *pc, - int catchOnly, ByteCode *codePtr); + int searchMode, ByteCode *codePtr); static const char * GetSrcInfoForPc(const unsigned char *pc, ByteCode *codePtr, int *lengthPtr, const unsigned char **pcBeg, int *cmdIdxPtr); @@ -734,7 +697,8 @@ static Tcl_Obj ** StackAllocWords(Tcl_Interp *interp, int numWords); static Tcl_Obj ** StackReallocWords(Tcl_Interp *interp, int numWords); static Tcl_NRPostProc CopyCallback; static Tcl_NRPostProc ExprObjCallback; - +static Tcl_NRPostProc FinalizeOONext; +static Tcl_NRPostProc FinalizeOONextFilter; static Tcl_NRPostProc TEBCresume; /* @@ -872,9 +836,9 @@ TclCreateExecEnv( + (size_t) (size-1) * sizeof(Tcl_Obj *)); eePtr->execStackPtr = esPtr; - TclNewBooleanObj(eePtr->constants[0], 0); + TclNewIntObj(eePtr->constants[0], 0); Tcl_IncrRefCount(eePtr->constants[0]); - TclNewBooleanObj(eePtr->constants[1], 1); + TclNewIntObj(eePtr->constants[1], 1); Tcl_IncrRefCount(eePtr->constants[1]); eePtr->interp = interp; eePtr->callbackPtr = NULL; @@ -885,11 +849,10 @@ TclCreateExecEnv( esPtr->nextPtr = NULL; esPtr->markerPtr = NULL; esPtr->endPtr = &esPtr->stackWords[size-1]; - esPtr->tosPtr = &esPtr->stackWords[-1]; + esPtr->tosPtr = STACK_BASE(esPtr); Tcl_MutexLock(&execMutex); if (!execInitialized) { - TclInitAuxDataTypeTable(); InitByteCodeExecution(interp); execInitialized = 1; } @@ -988,7 +951,6 @@ TclFinalizeExecution(void) Tcl_MutexLock(&execMutex); execInitialized = 0; Tcl_MutexUnlock(&execMutex); - TclFinalizeAuxDataTypeTable(); } /* @@ -1097,7 +1059,7 @@ GrowEvaluationStack( } needed = growth + moveWords + WALLOCALIGN; - + /* * Check if there is enough room in the next stack (if there is one, it * should be both empty and the last one!) @@ -1106,8 +1068,8 @@ GrowEvaluationStack( if (esPtr->nextPtr) { oldPtr = esPtr; esPtr = oldPtr->nextPtr; - currElems = esPtr->endPtr - &esPtr->stackWords[-1]; - if (esPtr->markerPtr || (esPtr->tosPtr != &esPtr->stackWords[-1])) { + currElems = esPtr->endPtr - STACK_BASE(esPtr); + if (esPtr->markerPtr || (esPtr->tosPtr != STACK_BASE(esPtr))) { Tcl_Panic("STACK: Stack after current is in use"); } if (esPtr->nextPtr) { @@ -1119,7 +1081,7 @@ GrowEvaluationStack( DeleteExecStack(esPtr); esPtr = oldPtr; } else { - currElems = esPtr->endPtr - &esPtr->stackWords[-1]; + currElems = esPtr->endPtr - STACK_BASE(esPtr); } /* @@ -1135,7 +1097,7 @@ GrowEvaluationStack( #else newElems = needed; #endif - + newBytes = sizeof(ExecStack) + (newElems-1) * sizeof(Tcl_Obj *); oldPtr = esPtr; @@ -1238,7 +1200,7 @@ TclStackFree( Tcl_Obj **markerPtr, *marker; if (iPtr == NULL || iPtr->execEnvPtr == NULL) { - ckfree((char *) freePtr); + ckfree(freePtr); return; } @@ -1273,10 +1235,10 @@ TclStackFree( while (esPtr->nextPtr) { esPtr = esPtr->nextPtr; } - esPtr->tosPtr = &esPtr->stackWords[-1]; + esPtr->tosPtr = STACK_BASE(esPtr); while (esPtr->prevPtr) { ExecStack *tmpPtr = esPtr->prevPtr; - if (tmpPtr->tosPtr == &tmpPtr->stackWords[-1]) { + if (tmpPtr->tosPtr == STACK_BASE(tmpPtr)) { DeleteExecStack(tmpPtr); } else { break; @@ -1299,12 +1261,12 @@ TclStackAlloc( int numBytes) { Interp *iPtr = (Interp *) interp; - int numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); + int numWords; if (iPtr == NULL || iPtr->execEnvPtr == NULL) { return (void *) ckalloc(numBytes); } - + numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); return (void *) StackAllocWords(interp, numWords); } @@ -1462,11 +1424,9 @@ ExprObjCallback( * * Results: * A (ByteCode *) is returned pointing to the resulting ByteCode. - * The caller must manage its refCount and arrange for a call to - * TclCleanupByteCode() when the last reference disappears. * * Side effects: - * The Tcl_ObjType of objPtr is changed to the "bytecode" type, + * The Tcl_ObjType of objPtr is changed to the "exprcode" type, * and the ByteCode is kept in the internal rep (along with context * data for checking validity) for faster operations the next time * CompileExprObj is called on the same value. @@ -1499,7 +1459,7 @@ CompileExprObj( || (codePtr->nsPtr != namespacePtr) || (codePtr->nsEpoch != namespacePtr->resolverEpoch) || (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) { - FreeExprCodeInternalRep(objPtr); + TclFreeIntRep(objPtr); } } if (objPtr->typePtr != &exprCodeType) { @@ -1507,11 +1467,10 @@ CompileExprObj( * TIP #280: No invoker (yet) - Expression compilation. */ - int length; - const char *string = TclGetStringFromObj(objPtr, &length); + const char *string = TclGetString(objPtr); - TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0); - TclCompileExpr(interp, string, length, &compEnv, 0); + TclInitCompileEnv(interp, &compEnv, string, objPtr->length, NULL, 0); + TclCompileExpr(interp, string, objPtr->length, &compEnv, 0); /* * Successful compilation. If the expression yielded no instructions, @@ -1519,7 +1478,7 @@ CompileExprObj( */ if (compEnv.codeNext == compEnv.codeStart) { - TclEmitPush(TclRegisterNewLiteral(&compEnv, "0", 1), + TclEmitPush(TclRegisterLiteral(&compEnv, "0", 1, 0), &compEnv); } @@ -1530,10 +1489,8 @@ CompileExprObj( */ TclEmitOpcode(INST_DONE, &compEnv); - TclInitByteCodeObj(objPtr, &compEnv); - objPtr->typePtr = &exprCodeType; + codePtr = TclInitByteCodeObj(objPtr, &exprCodeType, &compEnv); TclFreeCompileEnv(&compEnv); - codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; @@ -1607,11 +1564,7 @@ FreeExprCodeInternalRep( { ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; - objPtr->typePtr = NULL; - codePtr->refCount--; - if (codePtr->refCount <= 0) { - TclCleanupByteCode(codePtr); - } + TclReleaseByteCode(codePtr); } /* @@ -1852,37 +1805,6 @@ TclIncrObj( return TCL_ERROR; } - if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { - long augend = *((const long *) ptr1); - long addend = *((const long *) ptr2); - long sum = augend + addend; - - /* - * Overflow when (augend and sum have different sign) and (augend and - * addend have the same sign). This is encapsulated in the Overflowing - * macro. - */ - - if (!Overflowing(augend, addend, sum)) { - TclSetLongObj(valuePtr, sum); - return TCL_OK; - } -#ifndef TCL_WIDE_INT_IS_LONG - { - Tcl_WideInt w1 = (Tcl_WideInt) augend; - Tcl_WideInt w2 = (Tcl_WideInt) addend; - - /* - * We know the sum value is outside the long range, so we use the - * macro form that doesn't range test again. - */ - - TclSetWideIntObj(valuePtr, w1 + w2); - return TCL_OK; - } -#endif - } - if ((type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) { /* * Produce error message (reparse?!) @@ -1900,7 +1822,6 @@ TclIncrObj( return TCL_ERROR; } -#ifndef TCL_WIDE_INT_IS_LONG if ((type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) { Tcl_WideInt w1, w2, sum; @@ -1913,11 +1834,10 @@ TclIncrObj( */ if (!Overflowing(w1, w2, sum)) { - Tcl_SetWideIntObj(valuePtr, sum); + TclSetIntObj(valuePtr, sum); return TCL_OK; } } -#endif Tcl_TakeBignumFromObj(interp, valuePtr, &value); Tcl_GetBignumFromObj(interp, incrPtr, &incr); @@ -1930,6 +1850,41 @@ TclIncrObj( /* *---------------------------------------------------------------------- * + * ArgumentBCEnter -- + * + * This is a helper for TclNRExecuteByteCode/TEBCresume that encapsulates + * a code sequence that is fairly common in the code but *not* commonly + * called. + * + * Results: + * None + * + * Side effects: + * May register information about the bytecode in the command frame. + * + *---------------------------------------------------------------------- + */ + +static void +ArgumentBCEnter( + Tcl_Interp *interp, + ByteCode *codePtr, + TEBCdata *tdPtr, + const unsigned char *pc, + int objc, + Tcl_Obj **objv) +{ + int cmd; + + if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) { + TclArgumentBCEnter(interp, objv, objc, codePtr, &tdPtr->cmdFrame, cmd, + pc - codePtr->codeStart); + } +} + +/* + *---------------------------------------------------------------------- + * * TclNRExecuteByteCode -- * * This procedure executes the instructions of a ByteCode structure. It @@ -1962,11 +1917,7 @@ TclNRExecuteByteCode( * sizeof(void *); int numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *); - if (iPtr->execEnvPtr->rewind) { - return TCL_ERROR; - } - - codePtr->refCount++; + TclPreserveByteCode(codePtr); /* * Reserve the stack, setup the TEBCdataPtr (TD) and CallFrame @@ -1984,11 +1935,8 @@ TclNRExecuteByteCode( esPtr->tosPtr = initTosPtr; TD->codePtr = codePtr; - TD->pc = codePtr->codeStart; TD->catchTop = initCatchTop; - TD->cleanup = 0; TD->auxObjList = NULL; - TD->checkInterp = 0; /* * TIP #280: Initialize the frame. Do not push it yet: it will be pushed @@ -1998,7 +1946,6 @@ TclNRExecuteByteCode( bcFramePtr->type = ((codePtr->flags & TCL_BYTECODE_PRECOMPILED) ? TCL_LOCATION_PREBC : TCL_LOCATION_BC); bcFramePtr->level = (iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level+1 : 1); - bcFramePtr->numLevels = iPtr->numLevels; bcFramePtr->framePtr = iPtr->framePtr; bcFramePtr->nextPtr = iPtr->cmdFramePtr; bcFramePtr->nline = 0; @@ -2006,6 +1953,7 @@ TclNRExecuteByteCode( bcFramePtr->litarg = NULL; bcFramePtr->data.tebc.codePtr = codePtr; bcFramePtr->data.tebc.pc = NULL; + bcFramePtr->cmdObj = NULL; bcFramePtr->cmd = NULL; bcFramePtr->len = 0; @@ -2014,11 +1962,18 @@ TclNRExecuteByteCode( #endif /* + * Test namespace-50.9 demonstrates the need for this call. + * Use a --enable-symbols=mem bug to see. + */ + + TclResetRewriteEnsemble(interp, 1); + + /* * Push the callback for bytecode execution */ - TclNRAddCallback(interp, TEBCresume, TD, /*resume*/ INT2PTR(0), - NULL, NULL); + TclNRAddCallback(interp, TEBCresume, TD, /* pc */ NULL, + /* cleanup */ INT2PTR(0), NULL); return TCL_OK; } @@ -2051,8 +2006,14 @@ TEBCresume( * sporadically: no special need for speed. */ - int instructionCount = 0; /* Counter that is used to work out when to - * call Tcl_AsyncReady() */ + unsigned interruptCounter = 1; + /* Counter that is used to work out when to + * call Tcl_AsyncReady(). This must be 1 + * initially so that we call the async-check + * stanza early, otherwise there are command + * sequences that can make the interpreter + * busy-loop without an opportunity to + * recognise an interrupt. */ const char *curInstName; #ifdef TCL_COMPILE_DEBUG int traceInstructions; /* Whether we are doing instruction-level @@ -2074,9 +2035,6 @@ TEBCresume( #define auxObjList (TD->auxObjList) #define catchTop (TD->catchTop) #define codePtr (TD->codePtr) -#define checkInterp (TD->checkInterp) - /* Indicates when a check of interp readyness is - * necessary. Set by CACHE_STACK_INFO() */ /* * Globals: variables that store state, must remain valid at all times. @@ -2084,16 +2042,19 @@ TEBCresume( Tcl_Obj **tosPtr; /* Cached pointer to top of evaluation * stack. */ - const unsigned char *pc; /* The current program counter. */ + const unsigned char *pc = data[1]; + /* The current program counter. */ unsigned char inst; /* The currently running instruction */ - + /* * Transfer variables - needed only between opcodes, but not while * executing an instruction. */ - int cleanup = 0; + int cleanup = PTR2INT(data[2]); Tcl_Obj *objResultPtr; + int checkInterp; /* Indicates when a check of interp readyness + * is necessary. Set by CACHE_STACK_INFO() */ /* * Locals - variables that are used within opcodes or bounded sections of @@ -2118,82 +2079,77 @@ TEBCresume( TEBC_DATA_DIG(); #ifdef TCL_COMPILE_DEBUG - if (!data[1] && (tclTraceExec >= 2)) { + if (!pc && (tclTraceExec >= 2)) { PrintByteCodeInfo(codePtr); fprintf(stdout, " Starting stack top=%d\n", (int) CURR_DEPTH); fflush(stdout); } #endif - if (data[1] /* resume from invocation */) { - if (iPtr->execEnvPtr->rewind) { - result = TCL_ERROR; - } + if (!pc) { + /* bytecode is starting from scratch */ + checkInterp = 0; + pc = codePtr->codeStart; + goto cleanup0; + } else { + /* resume from invocation */ + CACHE_STACK_INFO(); + NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr); + if (bcFramePtr->cmdObj) { + Tcl_DecrRefCount(bcFramePtr->cmdObj); + bcFramePtr->cmdObj = NULL; + bcFramePtr->cmd = NULL; + } iPtr->cmdFramePtr = bcFramePtr->nextPtr; if (iPtr->flags & INTERP_DEBUG_FRAME) { - TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr); + TclArgumentBCRelease(interp, bcFramePtr); + } + if (iPtr->execEnvPtr->rewind) { + result = TCL_ERROR; + goto abnormalReturn; } if (codePtr->flags & TCL_BYTECODE_RECOMPILE) { iPtr->flags |= ERR_ALREADY_LOGGED; codePtr->flags &= ~TCL_BYTECODE_RECOMPILE; } - CACHE_STACK_INFO(); - if (result == TCL_OK) { - /* - * Push the call's object result and continue execution with the - * next instruction. - */ - - TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=", - objc, cmdNameBuf), Tcl_GetObjResult(interp)); - - /* - * Reset the interp's result to avoid possible duplications of - * large objects [Bug 781585]. We do not call Tcl_ResetResult to - * avoid any side effects caused by the resetting of errorInfo and - * errorCode [Bug 804681], which are not needed here. We chose - * instead to manipulate the interp's object result directly. - * - * Note that the result object is now in objResultPtr, it keeps - * the refCount it had in its role of iPtr->objResultPtr. - */ - - objResultPtr = Tcl_GetObjResult(interp); - TclNewObj(objPtr); - Tcl_IncrRefCount(objPtr); - iPtr->objResultPtr = objPtr; -#ifndef TCL_COMPILE_DEBUG - if (*pc == INST_POP) { - TclDecrRefCount(objResultPtr); - NEXT_INST_V(1, cleanup, 0); - } -#endif - NEXT_INST_V(0, cleanup, -1); + if (result != TCL_OK) { + pc--; + goto processExceptionReturn; } /* - * Result not TCL_OK: fall through + * Push the call's object result and continue execution with the next + * instruction. */ - } - - if (iPtr->execEnvPtr->rewind) { - result = TCL_ERROR; - goto abnormalReturn; - } - if (result != TCL_OK) { - pc--; - goto processExceptionReturn; - } + TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=", + objc, cmdNameBuf), Tcl_GetObjResult(interp)); - /* - * Loop executing instructions until a "done" instruction, a TCL_RETURN, - * or some error. - */ + /* + * Reset the interp's result to avoid possible duplications of large + * objects [Bug 781585]. We do not call Tcl_ResetResult to avoid any + * side effects caused by the resetting of errorInfo and errorCode + * [Bug 804681], which are not needed here. We chose instead to + * manipulate the interp's object result directly. + * + * Note that the result object is now in objResultPtr, it keeps the + * refCount it had in its role of iPtr->objResultPtr. + */ - goto cleanup0; + objResultPtr = Tcl_GetObjResult(interp); + TclNewObj(objPtr); + Tcl_IncrRefCount(objPtr); + iPtr->objResultPtr = objPtr; +#ifndef TCL_COMPILE_DEBUG + if (*pc == INST_POP) { + TclDecrRefCount(objResultPtr); + NEXT_INST_V(1, cleanup, 0); + } +#endif + NEXT_INST_V(0, cleanup, -1); + } /* * Targets for standard instruction endings; unrolled for speed in the @@ -2255,10 +2211,11 @@ TEBCresume( /* * Check for asynchronous handlers [Bug 746722]; we do the check every - * ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-1). + * ASYNC_CHECK_COUNT instructions. */ - if ((instructionCount++ & ASYNC_CHECK_COUNT_MASK) == 0) { + if ((--interruptCounter) == 0) { + interruptCounter = ASYNC_CHECK_COUNT; DECACHE_STACK_INFO(); if (TclAsyncReady(iPtr)) { result = Tcl_AsyncInvoke(interp, result); @@ -2294,7 +2251,7 @@ TEBCresume( */ inst = *pc; - + peepholeStart: #ifdef TCL_COMPILE_STATS iPtr->stats.instructionCount[*pc]++; @@ -2314,7 +2271,7 @@ TEBCresume( #endif /* TCL_COMPILE_DEBUG */ TCL_DTRACE_INST_NEXT(); - + if (inst == INST_LOAD_SCALAR1) { goto instLoadScalar1; } else if (inst == INST_PUSH1) { @@ -2326,7 +2283,7 @@ TEBCresume( /* * Peephole: do not run INST_START_CMD, just skip it */ - + iPtr->cmdCount += TclGetUInt4AtPtr(pc+5); if (checkInterp) { checkInterp = 0; @@ -2347,7 +2304,7 @@ TEBCresume( } goto peepholeStart; } - + switch (inst) { case INST_SYNTAX: case INST_RETURN_IMM: { @@ -2404,48 +2361,109 @@ TEBCresume( TRACE_APPEND(("\n")); goto processExceptionReturn; - case INST_YIELD: { - CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; + { + CoroutineData *corPtr; + int yieldParameter; + case INST_YIELD: + corPtr = iPtr->execEnvPtr->corPtr; TRACE(("%.30s => ", O2S(OBJ_AT_TOS))); if (!corPtr) { TRACE_APPEND(("ERROR: yield outside coroutine\n")); Tcl_SetObjResult(interp, Tcl_NewStringObj( "yield can only be called in a coroutine", -1)); + DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL); + CACHE_STACK_INFO(); goto gotError; } #ifdef TCL_COMPILE_DEBUG - TRACE_WITH_OBJ(("yield, result="), iPtr->objResultPtr); - if (traceInstructions) { - fprintf(stdout, "\n"); + if (tclTraceExec >= 2) { + if (traceInstructions) { + TRACE_APPEND(("YIELD...\n")); + } else { + fprintf(stdout, "%d: (%u) yielding value \"%.30s\"\n", + iPtr->numLevels, (unsigned)(pc - codePtr->codeStart), + Tcl_GetString(OBJ_AT_TOS)); + } + fflush(stdout); + } +#endif + yieldParameter = 0; + Tcl_SetObjResult(interp, OBJ_AT_TOS); + goto doYield; + + case INST_YIELD_TO_INVOKE: + corPtr = iPtr->execEnvPtr->corPtr; + valuePtr = OBJ_AT_TOS; + if (!corPtr) { + TRACE(("[%.30s] => ERROR: yield outside coroutine\n", + O2S(valuePtr))); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "yieldto can only be called in a coroutine", -1)); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", + NULL); + CACHE_STACK_INFO(); + goto gotError; + } + if (((Namespace *)TclGetCurrentNamespace(interp))->flags & NS_DYING) { + TRACE(("[%.30s] => ERROR: yield in deleted\n", + O2S(valuePtr))); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "yieldto called in deleted namespace", -1)); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED", + NULL); + CACHE_STACK_INFO(); + goto gotError; + } + +#ifdef TCL_COMPILE_DEBUG + if (tclTraceExec >= 2) { + if (traceInstructions) { + TRACE(("[%.30s] => YIELD...\n", O2S(valuePtr))); + } else { + /* FIXME: What is the right thing to trace? */ + fprintf(stdout, "%d: (%u) yielding to [%.30s]\n", + iPtr->numLevels, (unsigned)(pc - codePtr->codeStart), + TclGetString(valuePtr)); + } + fflush(stdout); } #endif + + /* + * Install a tailcall record in the caller and continue with the + * yield. The yield is switched into multi-return mode (via the + * 'yieldParameter'). + */ + + Tcl_IncrRefCount(valuePtr); + iPtr->execEnvPtr = corPtr->callerEEPtr; + TclSetTailcall(interp, valuePtr); + iPtr->execEnvPtr = corPtr->eePtr; + yieldParameter = (PTR2INT(NULL)+1); /*==CORO_ACTIVATE_YIELDM*/ + + doYield: /* TIP #280: Record the last piece of info needed by * 'TclGetSrcInfoForPc', and push the frame. */ - + bcFramePtr->data.tebc.pc = (char *) pc; iPtr->cmdFramePtr = bcFramePtr; if (iPtr->flags & INTERP_DEBUG_FRAME) { - int cmd; - if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) { - TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, - codePtr, bcFramePtr, cmd, pc - codePtr->codeStart); - } + ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv); } pc++; cleanup = 1; TEBC_YIELD(); - - Tcl_SetObjResult(interp, OBJ_AT_TOS); TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, - INT2PTR(0), NULL, NULL); - + INT2PTR(yieldParameter), NULL, NULL); return TCL_OK; } @@ -2458,11 +2476,14 @@ TEBCresume( TRACE(("%d => ERROR: tailcall in non-proc context\n", opnd)); Tcl_SetObjResult(interp, Tcl_NewStringObj( "tailcall can only be called from a proc or lambda", -1)); + DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL); + CACHE_STACK_INFO(); goto gotError; } #ifdef TCL_COMPILE_DEBUG + /* FIXME: What is the right thing to trace? */ { register int i; @@ -2536,7 +2557,7 @@ TEBCresume( case INST_OVER: opnd = TclGetUInt4AtPtr(pc+1); objResultPtr = OBJ_AT_DEPTH(opnd); - TRACE_WITH_OBJ(("=> "), objResultPtr); + TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); NEXT_INST_F(5, 0, 1); case INST_REVERSE: { @@ -2551,157 +2572,33 @@ TEBCresume( *b = tmpPtr; a++; b--; } + TRACE(("%u => OK\n", opnd)); NEXT_INST_F(5, 0, 0); } - case INST_CONCAT1: { - int appendLen = 0; - char *bytes, *p; - Tcl_Obj **currPtr; - int onlyb = 1; + case INST_STR_CONCAT1: opnd = TclGetUInt1AtPtr(pc+1); - - /* - * Detect only-bytearray-or-null case. - */ - - for (currPtr=&OBJ_AT_DEPTH(opnd-1); currPtr<=&OBJ_AT_TOS; currPtr++) { - if (((*currPtr)->typePtr != &tclByteArrayType) - && ((*currPtr)->bytes != tclEmptyStringRep)) { - onlyb = 0; - break; - } else if (((*currPtr)->typePtr == &tclByteArrayType) && - ((*currPtr)->bytes != NULL)) { - onlyb = 0; - break; - } - } - - /* - * Compute the length to be appended. - */ - - if (onlyb) { - for (currPtr = &OBJ_AT_DEPTH(opnd-2); - appendLen >= 0 && currPtr <= &OBJ_AT_TOS; currPtr++) { - if ((*currPtr)->bytes != tclEmptyStringRep) { - Tcl_GetByteArrayFromObj(*currPtr, &length); - appendLen += length; - } - } - } else { - for (currPtr = &OBJ_AT_DEPTH(opnd-2); - appendLen >= 0 && currPtr <= &OBJ_AT_TOS; currPtr++) { - bytes = TclGetStringFromObj(*currPtr, &length); - if (bytes != NULL) { - appendLen += length; - } - } - } - - if (appendLen < 0) { - /* TODO: convert panic to error ? */ - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + objResultPtr = TclStringCat(interp, opnd, &OBJ_AT_DEPTH(opnd-1), + TCL_STRING_IN_PLACE); + if (objResultPtr == NULL) { + TRACE_ERROR(interp); + goto gotError; } - /* - * If nothing is to be appended, just return the first object by - * dropping all the others from the stack; this saves both the - * computation and copy of the string rep of the first object, - * enabling the fast '$x[set x {}]' idiom for 'K $x [set x {}]'. - */ - - if (appendLen == 0) { - TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); - NEXT_INST_V(2, (opnd-1), 0); - } + TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); + NEXT_INST_V(2, opnd, 1); + case INST_CONCAT_STK: /* - * If the first object is shared, we need a new obj for the result; - * otherwise, we can reuse the first object. In any case, make sure it - * has enough room to accomodate all the concatenated bytes. Note that - * if it is unshared its bytes are copied by ckrealloc, so that we set - * the loop parameters to avoid copying them again: p points to the - * end of the already copied bytes, currPtr to the second object. + * Pop the opnd (objc) top stack elements, run through Tcl_ConcatObj, + * and then decrement their ref counts. */ - objResultPtr = OBJ_AT_DEPTH(opnd-1); - if (!onlyb) { - bytes = TclGetStringFromObj(objResultPtr, &length); - if (length + appendLen < 0) { - /* TODO: convert panic to error ? */ - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", - INT_MAX); - } -#ifndef TCL_COMPILE_DEBUG - if (bytes != tclEmptyStringRep && !Tcl_IsShared(objResultPtr)) { - TclFreeIntRep(objResultPtr); - objResultPtr->bytes = ckrealloc(bytes, length+appendLen+1); - objResultPtr->length = length + appendLen; - p = TclGetString(objResultPtr) + length; - currPtr = &OBJ_AT_DEPTH(opnd - 2); - } else -#endif - { - p = ckalloc(length + appendLen + 1); - TclNewObj(objResultPtr); - objResultPtr->bytes = p; - objResultPtr->length = length + appendLen; - currPtr = &OBJ_AT_DEPTH(opnd - 1); - } - - /* - * Append the remaining characters. - */ - - for (; currPtr <= &OBJ_AT_TOS; currPtr++) { - bytes = TclGetStringFromObj(*currPtr, &length); - if (bytes != NULL) { - memcpy(p, bytes, (size_t) length); - p += length; - } - } - *p = '\0'; - } else { - bytes = (char *) Tcl_GetByteArrayFromObj(objResultPtr, &length); - if (length + appendLen < 0) { - /* TODO: convert panic to error ? */ - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", - INT_MAX); - } -#ifndef TCL_COMPILE_DEBUG - if (!Tcl_IsShared(objResultPtr)) { - bytes = (char *) Tcl_SetByteArrayLength(objResultPtr, - length + appendLen); - p = bytes + length; - currPtr = &OBJ_AT_DEPTH(opnd - 2); - } else -#endif - { - TclNewObj(objResultPtr); - bytes = (char *) Tcl_SetByteArrayLength(objResultPtr, - length + appendLen); - p = bytes; - currPtr = &OBJ_AT_DEPTH(opnd - 1); - } - - /* - * Append the remaining characters. - */ - - for (; currPtr <= &OBJ_AT_TOS; currPtr++) { - if ((*currPtr)->bytes != tclEmptyStringRep) { - bytes = (char *) Tcl_GetByteArrayFromObj(*currPtr,&length); - memcpy(p, bytes, (size_t) length); - p += length; - } - } - } - + opnd = TclGetUInt4AtPtr(pc+1); + objResultPtr = Tcl_ConcatObj(opnd, &OBJ_AT_DEPTH(opnd-1)); TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); - NEXT_INST_V(2, opnd, 1); - } + NEXT_INST_V(5, opnd, 1); case INST_EXPAND_START: /* @@ -2718,9 +2615,10 @@ TEBCresume( */ TclNewObj(objPtr); - objPtr->internalRep.ptrAndLongRep.value = CURR_DEPTH; + objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(CURR_DEPTH); objPtr->length = 0; PUSH_TAUX_OBJ(objPtr); + TRACE(("=> mark depth as %d\n", (int) CURR_DEPTH)); NEXT_INST_F(1, 0, 0); case INST_EXPAND_DROP: @@ -2731,12 +2629,13 @@ TEBCresume( */ CLANG_ASSERT(auxObjList); - objc = CURR_DEPTH - auxObjList->internalRep.ptrAndLongRep.value; + objc = CURR_DEPTH - PTR2INT(auxObjList->internalRep.twoPtrValue.ptr2); POP_TAUX_OBJ(); #ifdef TCL_COMPILE_DEBUG /* Ugly abuse! */ starting = 1; #endif + TRACE(("=> drop %d items\n", objc)); NEXT_INST_V(1, objc, 0); case INST_EXPAND_STKTOP: { @@ -2750,9 +2649,9 @@ TEBCresume( */ objPtr = OBJ_AT_TOS; + TRACE(("\"%.30s\" => ", O2S(objPtr))); if (TclListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) { - TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(objPtr)), - Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } (void) POP_OBJECT(); @@ -2779,7 +2678,6 @@ TEBCresume( * stack-allocated parameter, update the stack pointers. */ - esPtr = iPtr->execEnvPtr->execStackPtr; TD = (TEBCdata *) (((Tcl_Obj **)TD) + moved); catchTop += moved; @@ -2796,6 +2694,7 @@ TEBCresume( PUSH_OBJECT(objv[i]); } + TRACE_APPEND(("OK\n")); Tcl_DecrRefCount(objPtr); NEXT_INST_F(5, 0, 0); } @@ -2830,7 +2729,7 @@ TEBCresume( case INST_INVOKE_EXPANDED: CLANG_ASSERT(auxObjList); - objc = CURR_DEPTH - auxObjList->internalRep.ptrAndLongRep.value; + objc = CURR_DEPTH - PTR2INT(auxObjList->internalRep.twoPtrValue.ptr2); POP_TAUX_OBJ(); if (objc) { pcAdjustment = 1; @@ -2888,11 +2787,7 @@ TEBCresume( iPtr->cmdFramePtr = bcFramePtr; if (iPtr->flags & INTERP_DEBUG_FRAME) { - int cmd; - if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) { - TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, - codePtr, bcFramePtr, cmd, pc - codePtr->codeStart); - } + ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv); } DECACHE_STACK_INFO(); @@ -2900,7 +2795,7 @@ TEBCresume( pc += pcAdjustment; TEBC_YIELD(); return TclNREvalObjv(interp, objc, objv, - TCL_EVAL_NOERR, NULL); + TCL_EVAL_NOERR | TCL_EVAL_SOURCE_IN_FRAME, NULL); #if TCL_SUPPORT_84_BYTECODE case INST_CALL_BUILTIN_FUNC1: @@ -3020,39 +2915,34 @@ TEBCresume( fflush(stdout); } #endif /*TCL_COMPILE_DEBUG*/ - { - Tcl_Obj *copyPtr = Tcl_NewListObj(objc - opnd + 1, NULL); - register List *listRepPtr = copyPtr->internalRep.twoPtrValue.ptr1; - Tcl_Obj **copyObjv = &listRepPtr->elements; - int i; - listRepPtr->elemCount = objc - opnd + 1; - copyObjv[0] = objPtr; - memcpy(copyObjv+1, objv+opnd, sizeof(Tcl_Obj *) * (objc - opnd)); - for (i=1 ; i<objc-opnd+1 ; i++) { - Tcl_IncrRefCount(copyObjv[i]); - } - objPtr = copyPtr; - } bcFramePtr->data.tebc.pc = (char *) pc; iPtr->cmdFramePtr = bcFramePtr; if (iPtr->flags & INTERP_DEBUG_FRAME) { - int cmd; - if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) { - TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, - codePtr, bcFramePtr, cmd, pc - codePtr->codeStart); - } + ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv); } - iPtr->ensembleRewrite.sourceObjs = objv; - iPtr->ensembleRewrite.numRemovedObjs = opnd; - iPtr->ensembleRewrite.numInsertedObjs = 1; + + TclInitRewriteEnsemble(interp, opnd, 1, objv); + + { + Tcl_Obj *copyPtr = Tcl_NewListObj(objc - opnd + 1, NULL); + + Tcl_ListObjAppendElement(NULL, copyPtr, objPtr); + Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0, + objc - opnd, objv + opnd); + Tcl_DecrRefCount(objPtr); + objPtr = copyPtr; + } + DECACHE_STACK_INFO(); pc += 6; TEBC_YIELD(); - TclNRAddCallback(interp, TclClearRootEnsemble, NULL,NULL,NULL,NULL); - TclSkipTailcall(interp); - return TclNREvalObjEx(interp, objPtr, TCL_EVAL_INVOKE, NULL, INT_MIN); + TclMarkTailcall(interp); + TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); + Tcl_ListObjGetElements(NULL, objPtr, &objc, &objv); + TclNRAddCallback(interp, TclNRReleaseValues, objPtr, NULL, NULL, NULL); + return TclNREvalObjv(interp, objc, objv, TCL_EVAL_INVOKE, NULL); /* * ----------------------------------------------------------------- @@ -3140,7 +3030,7 @@ TEBCresume( varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr, opnd); if (varPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } cleanup = 1; @@ -3166,7 +3056,7 @@ TEBCresume( TCL_LEAVE_ERR_MSG, "read", /*createPart1*/0, /*createPart2*/1, &arrayPtr); if (!varPtr) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } @@ -3189,11 +3079,11 @@ TEBCresume( */ DECACHE_STACK_INFO(); - objResultPtr = TclPtrGetVar(interp, varPtr, arrayPtr, + objResultPtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, opnd); CACHE_STACK_INFO(); if (!objResultPtr) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); @@ -3210,7 +3100,7 @@ TEBCresume( */ { - int storeFlags; + int storeFlags, len; case INST_STORE_ARRAY4: opnd = TclGetUInt4AtPtr(pc+1); @@ -3342,7 +3232,7 @@ TEBCresume( varPtr = TclObjLookupVarEx(interp, objPtr,part2Ptr, TCL_LEAVE_ERR_MSG, "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); if (!varPtr) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } cleanup = ((part2Ptr == NULL)? 2 : 3); @@ -3392,7 +3282,7 @@ TEBCresume( varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr, opnd); if (!varPtr) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } goto doCallPtrSetVar; @@ -3436,11 +3326,11 @@ TEBCresume( doCallPtrSetVar: DECACHE_STACK_INFO(); - objResultPtr = TclPtrSetVar(interp, varPtr, arrayPtr, + objResultPtr = TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, valuePtr, storeFlags, opnd); CACHE_STACK_INFO(); if (!objResultPtr) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } #ifndef TCL_COMPILE_DEBUG @@ -3450,6 +3340,171 @@ TEBCresume( #endif TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_V(pcAdjustment, cleanup, 1); + + case INST_LAPPEND_LIST: + opnd = TclGetUInt4AtPtr(pc+1); + valuePtr = OBJ_AT_TOS; + varPtr = LOCAL(opnd); + cleanup = 1; + pcAdjustment = 5; + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr))); + if (TclListObjGetElements(interp, valuePtr, &objc, &objv) + != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; + } + if (TclIsVarDirectReadable(varPtr) + && TclIsVarDirectWritable(varPtr)) { + goto lappendListDirect; + } + arrayPtr = NULL; + part1Ptr = part2Ptr = NULL; + goto lappendListPtr; + + case INST_LAPPEND_LIST_ARRAY: + opnd = TclGetUInt4AtPtr(pc+1); + valuePtr = OBJ_AT_TOS; + part1Ptr = NULL; + part2Ptr = OBJ_UNDER_TOS; + arrayPtr = LOCAL(opnd); + cleanup = 2; + pcAdjustment = 5; + while (TclIsVarLink(arrayPtr)) { + arrayPtr = arrayPtr->value.linkPtr; + } + TRACE(("%u \"%.30s\" \"%.30s\" => ", + opnd, O2S(part2Ptr), O2S(valuePtr))); + if (TclListObjGetElements(interp, valuePtr, &objc, &objv) + != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; + } + if (TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr) + && !WriteTraced(arrayPtr)) { + varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); + if (varPtr && TclIsVarDirectReadable(varPtr) + && TclIsVarDirectWritable(varPtr)) { + goto lappendListDirect; + } + } + varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, + TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr, opnd); + if (varPtr == NULL) { + TRACE_ERROR(interp); + goto gotError; + } + goto lappendListPtr; + + case INST_LAPPEND_LIST_ARRAY_STK: + pcAdjustment = 1; + cleanup = 3; + valuePtr = OBJ_AT_TOS; + part2Ptr = OBJ_UNDER_TOS; /* element name */ + part1Ptr = OBJ_AT_DEPTH(2); /* array name */ + TRACE(("\"%.30s(%.30s)\" \"%.30s\" => ", + O2S(part1Ptr), O2S(part2Ptr), O2S(valuePtr))); + goto lappendList; + + case INST_LAPPEND_LIST_STK: + pcAdjustment = 1; + cleanup = 2; + valuePtr = OBJ_AT_TOS; + part2Ptr = NULL; + part1Ptr = OBJ_UNDER_TOS; /* variable name */ + TRACE(("\"%.30s\" \"%.30s\" => ", O2S(part1Ptr), O2S(valuePtr))); + goto lappendList; + + lappendListDirect: + objResultPtr = varPtr->value.objPtr; + if (TclListObjLength(interp, objResultPtr, &len) != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; + } + if (Tcl_IsShared(objResultPtr)) { + Tcl_Obj *newValue = Tcl_DuplicateObj(objResultPtr); + + TclDecrRefCount(objResultPtr); + varPtr->value.objPtr = objResultPtr = newValue; + Tcl_IncrRefCount(newValue); + } + if (Tcl_ListObjReplace(interp, objResultPtr, len, 0, objc, objv) + != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(pcAdjustment, cleanup, 1); + + lappendList: + opnd = -1; + if (TclListObjGetElements(interp, valuePtr, &objc, &objv) + != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; + } + DECACHE_STACK_INFO(); + varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, + TCL_LEAVE_ERR_MSG, "set", 1, 1, &arrayPtr); + CACHE_STACK_INFO(); + if (!varPtr) { + TRACE_ERROR(interp); + goto gotError; + } + + lappendListPtr: + if (TclIsVarInHash(varPtr)) { + VarHashRefCount(varPtr)++; + } + if (arrayPtr && TclIsVarInHash(arrayPtr)) { + VarHashRefCount(arrayPtr)++; + } + DECACHE_STACK_INFO(); + objResultPtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, + part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, opnd); + CACHE_STACK_INFO(); + if (TclIsVarInHash(varPtr)) { + VarHashRefCount(varPtr)--; + } + if (arrayPtr && TclIsVarInHash(arrayPtr)) { + VarHashRefCount(arrayPtr)--; + } + + { + int createdNewObj = 0; + + if (!objResultPtr) { + objResultPtr = valuePtr; + } else if (TclListObjLength(interp, objResultPtr, &len)!=TCL_OK) { + TRACE_ERROR(interp); + goto gotError; + } else { + if (Tcl_IsShared(objResultPtr)) { + objResultPtr = Tcl_DuplicateObj(objResultPtr); + createdNewObj = 1; + } + if (Tcl_ListObjReplace(interp, objResultPtr, len,0, objc,objv) + != TCL_OK) { + goto errorInLappendListPtr; + } + } + DECACHE_STACK_INFO(); + objResultPtr = TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr, + part2Ptr, objResultPtr, TCL_LEAVE_ERR_MSG, opnd); + CACHE_STACK_INFO(); + if (!objResultPtr) { + errorInLappendListPtr: + if (createdNewObj) { + TclDecrRefCount(objResultPtr); + } + TRACE_ERROR(interp); + goto gotError; + } + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(pcAdjustment, cleanup, 1); } /* @@ -3466,9 +3521,7 @@ TEBCresume( { Tcl_Obj *incrPtr; -#ifndef TCL_WIDE_INT_IS_LONG Tcl_WideInt w; -#endif long increment; case INST_INCR_SCALAR1: @@ -3515,9 +3568,11 @@ TEBCresume( varPtr = TclObjLookupVarEx(interp, objPtr, part2Ptr, TCL_LEAVE_ERR_MSG, "read", 1, 1, &arrayPtr); if (!varPtr) { + DECACHE_STACK_INFO(); Tcl_AddErrorInfo(interp, "\n (reading value of variable to increment)"); - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + CACHE_STACK_INFO(); + TRACE_ERROR(interp); Tcl_DecrRefCount(incrPtr); goto gotError; } @@ -3543,7 +3598,7 @@ TEBCresume( varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, "read", 1, 1, arrayPtr, opnd); if (!varPtr) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); Tcl_DecrRefCount(incrPtr); goto gotError; } @@ -3565,9 +3620,9 @@ TEBCresume( objPtr = varPtr->value.objPtr; if (GetNumberFromObj(NULL, objPtr, &ptr, &type) == TCL_OK) { - if (type == TCL_NUMBER_LONG) { - long augend = *((const long *)ptr); - long sum = augend + increment; + if (type == TCL_NUMBER_WIDE) { + Tcl_WideInt augend = *((const Tcl_WideInt *)ptr); + Tcl_WideInt sum = augend + increment; /* * Overflow when (augend and sum have different sign) and @@ -3579,16 +3634,15 @@ TEBCresume( TRACE(("%u %ld => ", opnd, increment)); if (Tcl_IsShared(objPtr)) { objPtr->refCount--; /* We know it's shared. */ - TclNewLongObj(objResultPtr, sum); + TclNewIntObj(objResultPtr, sum); Tcl_IncrRefCount(objResultPtr); varPtr->value.objPtr = objResultPtr; } else { objResultPtr = objPtr; - TclSetLongObj(objPtr, sum); + TclSetIntObj(objPtr, sum); } goto doneIncr; } -#ifndef TCL_WIDE_INT_IS_LONG w = (Tcl_WideInt)augend; TRACE(("%u %ld => ", opnd, increment)); @@ -3605,44 +3659,10 @@ TEBCresume( * use macro form that doesn't range test again. */ - TclSetWideIntObj(objPtr, w+increment); + TclSetIntObj(objPtr, w+increment); } goto doneIncr; -#endif - } /* end if (type == TCL_NUMBER_LONG) */ -#ifndef TCL_WIDE_INT_IS_LONG - if (type == TCL_NUMBER_WIDE) { - Tcl_WideInt sum; - - w = *((const Tcl_WideInt *) ptr); - sum = w + increment; - - /* - * Check for overflow. - */ - - if (!Overflowing(w, increment, sum)) { - TRACE(("%u %ld => ", opnd, increment)); - if (Tcl_IsShared(objPtr)) { - objPtr->refCount--; /* We know it's shared. */ - objResultPtr = Tcl_NewWideIntObj(sum); - Tcl_IncrRefCount(objResultPtr); - varPtr->value.objPtr = objResultPtr; - } else { - objResultPtr = objPtr; - - /* - * We *do not* know the sum value is outside the - * long range (wide + long can yield long); use - * the function call that checks range. - */ - - Tcl_SetWideIntObj(objPtr, sum); - } - goto doneIncr; - } - } -#endif + } /* end if (type == TCL_NUMBER_WIDE) */ } if (Tcl_IsShared(objPtr)) { objPtr->refCount--; /* We know it's shared */ @@ -3652,11 +3672,10 @@ TEBCresume( } else { objResultPtr = objPtr; } - TclNewLongObj(incrPtr, increment); + TclNewIntObj(incrPtr, increment); if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) { Tcl_DecrRefCount(incrPtr); - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } Tcl_DecrRefCount(incrPtr); @@ -3667,7 +3686,7 @@ TEBCresume( * All other cases, flow through to generic handling. */ - TclNewLongObj(incrPtr, increment); + TclNewIntObj(incrPtr, increment); Tcl_IncrRefCount(incrPtr); doIncrScalar: @@ -3693,20 +3712,18 @@ TEBCresume( } if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) { Tcl_DecrRefCount(incrPtr); - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } Tcl_DecrRefCount(incrPtr); } else { DECACHE_STACK_INFO(); - objResultPtr = TclPtrIncrObjVar(interp, varPtr, arrayPtr, + objResultPtr = TclPtrIncrObjVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, incrPtr, TCL_LEAVE_ERR_MSG, opnd); CACHE_STACK_INFO(); Tcl_DecrRefCount(incrPtr); if (objResultPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } } @@ -3727,6 +3744,8 @@ TEBCresume( */ case INST_EXIST_SCALAR: + cleanup = 0; + pcAdjustment = 5; opnd = TclGetUInt4AtPtr(pc+1); varPtr = LOCAL(opnd); while (TclIsVarLink(varPtr)) { @@ -3743,16 +3762,11 @@ TEBCresume( varPtr = NULL; } } - - /* - * Tricky! Arrays always exist. - */ - - objResultPtr = TCONST(!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1); - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(5, 0, 1); + goto afterExistsPeephole; case INST_EXIST_ARRAY: + cleanup = 1; + pcAdjustment = 5; opnd = TclGetUInt4AtPtr(pc+1); part2Ptr = OBJ_AT_TOS; arrayPtr = LOCAL(opnd); @@ -3763,7 +3777,7 @@ TEBCresume( if (TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr)) { varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); if (!varPtr || !ReadTraced(varPtr)) { - goto doneExistArray; + goto afterExistsPeephole; } } varPtr = TclLookupArrayElement(interp, NULL, part2Ptr, 0, "access", @@ -3780,13 +3794,11 @@ TEBCresume( varPtr = NULL; } } - doneExistArray: - objResultPtr = TCONST(!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1); - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_F(5, 1, 1); + goto afterExistsPeephole; case INST_EXIST_ARRAY_STK: cleanup = 2; + pcAdjustment = 1; part2Ptr = OBJ_AT_TOS; /* element name */ part1Ptr = OBJ_UNDER_TOS; /* array name */ TRACE(("\"%.30s(%.30s)\" => ", O2S(part1Ptr), O2S(part2Ptr))); @@ -3794,6 +3806,7 @@ TEBCresume( case INST_EXIST_STK: cleanup = 1; + pcAdjustment = 1; part2Ptr = NULL; part1Ptr = OBJ_AT_TOS; /* variable name */ TRACE(("\"%.30s\" => ", O2S(part1Ptr))); @@ -3813,9 +3826,17 @@ TEBCresume( varPtr = NULL; } } - objResultPtr = TCONST(!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1); - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(1, cleanup, 1); + + /* + * Peep-hole optimisation: if you're about to jump, do jump from here. + */ + + afterExistsPeephole: { + int found = (varPtr && !TclIsVarUndefined(varPtr)); + + TRACE_APPEND(("%d\n", found ? 1 : 0)); + JUMP_PEEPHOLE_V(found, pcAdjustment, cleanup); + } /* * End of INST_EXIST instructions. @@ -3833,7 +3854,7 @@ TEBCresume( while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } - TRACE(("%s %u\n", (flags?"normal":"noerr"), opnd)); + TRACE(("%s %u => ", (flags ? "normal" : "noerr"), opnd)); if (TclIsVarDirectUnsettable(varPtr) && !TclIsVarInHash(varPtr)) { /* * No errors, no traces, no searches: just make the variable cease @@ -3846,12 +3867,13 @@ TEBCresume( goto slowUnsetScalar; } varPtr->value.objPtr = NULL; + TRACE_APPEND(("OK\n")); NEXT_INST_F(6, 0, 0); } slowUnsetScalar: DECACHE_STACK_INFO(); - if (TclPtrUnsetVar(interp, varPtr, NULL, NULL, NULL, flags, + if (TclPtrUnsetVarIdx(interp, varPtr, NULL, NULL, NULL, flags, opnd) != TCL_OK && flags) { goto errorInUnset; } @@ -3866,9 +3888,10 @@ TEBCresume( while (TclIsVarLink(arrayPtr)) { arrayPtr = arrayPtr->value.linkPtr; } - TRACE(("%s %u \"%.30s\"\n", + TRACE(("%s %u \"%.30s\" => ", (flags ? "normal" : "noerr"), opnd, O2S(part2Ptr))); - if (TclIsVarArray(arrayPtr) && !UnsetTraced(arrayPtr)) { + if (TclIsVarArray(arrayPtr) && !UnsetTraced(arrayPtr) + && !(arrayPtr->flags & VAR_SEARCH_ACTIVE)) { varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); if (varPtr && TclIsVarDirectUnsettable(varPtr)) { /* @@ -3878,16 +3901,20 @@ TEBCresume( if (!TclIsVarUndefined(varPtr)) { TclDecrRefCount(varPtr->value.objPtr); + TclSetVarUndefined(varPtr); + TclClearVarNamespaceVar(varPtr); + TclCleanupVar(varPtr, arrayPtr); } else if (flags & TCL_LEAVE_ERR_MSG) { goto slowUnsetArray; } - varPtr->value.objPtr = NULL; + TRACE_APPEND(("OK\n")); NEXT_INST_F(6, 1, 0); } else if (!varPtr && !(flags & TCL_LEAVE_ERR_MSG)) { /* * Don't need to do anything here. */ + TRACE_APPEND(("OK\n")); NEXT_INST_F(6, 1, 0); } } @@ -3899,7 +3926,7 @@ TEBCresume( if (flags & TCL_LEAVE_ERR_MSG) { goto errorInUnset; } - } else if (TclPtrUnsetVar(interp, varPtr, arrayPtr, NULL, part2Ptr, + } else if (TclPtrUnsetVarIdx(interp, varPtr, arrayPtr, NULL, part2Ptr, flags, opnd) != TCL_OK && (flags & TCL_LEAVE_ERR_MSG)) { goto errorInUnset; } @@ -3911,7 +3938,7 @@ TEBCresume( cleanup = 2; part2Ptr = OBJ_AT_TOS; /* element name */ part1Ptr = OBJ_UNDER_TOS; /* array name */ - TRACE(("%s \"%.30s(%.30s)\"\n", (flags?"normal":"noerr"), + TRACE(("%s \"%.30s(%.30s)\" => ", (flags ? "normal" : "noerr"), O2S(part1Ptr), O2S(part2Ptr))); goto doUnsetStk; @@ -3920,7 +3947,8 @@ TEBCresume( cleanup = 1; part2Ptr = NULL; part1Ptr = OBJ_AT_TOS; /* variable name */ - TRACE(("%s \"%.30s\"\n", (flags?"normal":"noerr"), O2S(part1Ptr))); + TRACE(("%s \"%.30s\" => ", (flags ? "normal" : "noerr"), + O2S(part1Ptr))); doUnsetStk: DECACHE_STACK_INFO(); @@ -3929,11 +3957,12 @@ TEBCresume( goto errorInUnset; } CACHE_STACK_INFO(); + TRACE_APPEND(("OK\n")); NEXT_INST_V(2, cleanup, 0); errorInUnset: CACHE_STACK_INFO(); - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; /* @@ -3942,7 +3971,7 @@ TEBCresume( case INST_DICT_DONE: opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u\n", opnd)); + TRACE(("%u => OK\n", opnd)); varPtr = LOCAL(opnd); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; @@ -3954,7 +3983,7 @@ TEBCresume( varPtr->value.objPtr = NULL; } else { DECACHE_STACK_INFO(); - TclPtrUnsetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd); + TclPtrUnsetVarIdx(interp, varPtr, NULL, NULL, NULL, 0, opnd); CACHE_STACK_INFO(); } NEXT_INST_F(5, 0, 0); @@ -3987,18 +4016,12 @@ TEBCresume( varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, 0, NULL, /*createPart1*/0, /*createPart2*/0, &arrayPtr); doArrayExists: - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - DECACHE_STACK_INFO(); - result = TclObjCallVarTraces(iPtr, arrayPtr, varPtr, part1Ptr, - NULL, (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY| - TCL_GLOBAL_ONLY|TCL_TRACE_ARRAY), 1, opnd); - CACHE_STACK_INFO(); - if (result == TCL_ERROR) { - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); - goto gotError; - } + DECACHE_STACK_INFO(); + result = TclCheckArrayTraces(interp, varPtr, arrayPtr, part1Ptr, opnd); + CACHE_STACK_INFO(); + if (result == TCL_ERROR) { + TRACE_ERROR(interp); + goto gotError; } if (varPtr && TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { objResultPtr = TCONST(1); @@ -4029,7 +4052,7 @@ TEBCresume( varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, TCL_LEAVE_ERR_MSG, "set", /*createPart1*/1, /*createPart2*/0, &arrayPtr); if (varPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } doArrayMake: @@ -4041,9 +4064,10 @@ TEBCresume( TclObjVarErrMsg(interp, part1Ptr, NULL, "array set", "variable isn't array", opnd); + DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); - TRACE_APPEND(("ERROR: bad array ref: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); + CACHE_STACK_INFO(); + TRACE_ERROR(interp); goto gotError; } TclSetVarArray(varPtr); @@ -4071,9 +4095,11 @@ TEBCresume( Namespace *savedNsPtr; case INST_UPVAR: - TRACE_WITH_OBJ(("upvar "), OBJ_UNDER_TOS); + TRACE(("%d %.30s %.30s => ", TclGetInt4AtPtr(pc+1), + O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS))); if (TclObjGetFrame(interp, OBJ_UNDER_TOS, &framePtr) == -1) { + TRACE_ERROR(interp); goto gotError; } @@ -4088,13 +4114,16 @@ TEBCresume( /*createPart2*/ 1, &varPtr); iPtr->varFramePtr = savedFramePtr; if (!otherPtr) { + TRACE_ERROR(interp); goto gotError; } goto doLinkVars; case INST_NSUPVAR: - TRACE_WITH_OBJ(("nsupvar "), OBJ_UNDER_TOS); + TRACE(("%d %.30s %.30s => ", TclGetInt4AtPtr(pc+1), + O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS))); if (TclGetNamespaceFromObj(interp, OBJ_UNDER_TOS, &nsPtr) != TCL_OK) { + TRACE_ERROR(interp); goto gotError; } @@ -4105,20 +4134,22 @@ TEBCresume( savedNsPtr = iPtr->varFramePtr->nsPtr; iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr; otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL, - (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access", - /*createPart1*/ 1, /*createPart2*/ 1, &varPtr); + (TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG|TCL_AVOID_RESOLVERS), + "access", /*createPart1*/ 1, /*createPart2*/ 1, &varPtr); iPtr->varFramePtr->nsPtr = savedNsPtr; if (!otherPtr) { + TRACE_ERROR(interp); goto gotError; } goto doLinkVars; case INST_VARIABLE: - TRACE(("variable ")); + TRACE(("%d, %.30s => ", TclGetInt4AtPtr(pc+1), O2S(OBJ_AT_TOS))); otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL, (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access", /*createPart1*/ 1, /*createPart2*/ 1, &varPtr); if (!otherPtr) { + TRACE_ERROR(interp); goto gotError; } @@ -4136,7 +4167,7 @@ TEBCresume( * if there are no errors; otherwise, let it handle the case. */ - opnd = TclGetInt4AtPtr(pc+1);; + opnd = TclGetInt4AtPtr(pc+1); varPtr = LOCAL(opnd); if ((varPtr != otherPtr) && !TclIsVarTraced(varPtr) && (TclIsVarUndefined(varPtr) || TclIsVarLink(varPtr))) { @@ -4148,6 +4179,7 @@ TEBCresume( Var *linkPtr = varPtr->value.linkPtr; if (linkPtr == otherPtr) { + TRACE_APPEND(("already linked\n")); NEXT_INST_F(5, 1, 0); } if (TclIsVarInHash(linkPtr)) { @@ -4162,8 +4194,9 @@ TEBCresume( if (TclIsVarInHash(otherPtr)) { VarHashRefCount(otherPtr)++; } - } else if (TclPtrObjMakeUpvar(interp, otherPtr, NULL, 0, + } else if (TclPtrObjMakeUpvarIdx(interp, otherPtr, NULL, 0, opnd) != TCL_OK) { + TRACE_ERROR(interp); goto gotError; } @@ -4172,6 +4205,7 @@ TEBCresume( * variables - and [variable] did not push it at all. */ + TRACE_APPEND(("link made\n")); NEXT_INST_F(5, 1, 0); } @@ -4218,31 +4252,29 @@ TEBCresume( doCondJump: valuePtr = OBJ_AT_TOS; + TRACE(("%d => ", jmpOffset[ + (*pc==INST_JUMP_FALSE1 || *pc==INST_JUMP_FALSE4) ? 0 : 1])); /* TODO - check claim that taking address of b harms performance */ /* TODO - consider optimization search for constants */ if (TclGetBooleanFromObj(interp, valuePtr, &b) != TCL_OK) { - TRACE_WITH_OBJ(("%d => ERROR: ", jmpOffset[ - ((*pc == INST_JUMP_FALSE1) || (*pc == INST_JUMP_FALSE4)) - ? 0 : 1]), Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } #ifdef TCL_COMPILE_DEBUG if (b) { if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) { - TRACE(("%d => %.20s true, new pc %u\n", jmpOffset[1], - O2S(valuePtr), + TRACE_APPEND(("%.20s true, new pc %u\n", O2S(valuePtr), (unsigned)(pc + jmpOffset[1] - codePtr->codeStart))); } else { - TRACE(("%d => %.20s true\n", jmpOffset[0], O2S(valuePtr))); + TRACE_APPEND(("%.20s true\n", O2S(valuePtr))); } } else { if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) { - TRACE(("%d => %.20s false\n", jmpOffset[0], O2S(valuePtr))); + TRACE_APPEND(("%.20s false\n", O2S(valuePtr))); } else { - TRACE(("%d => %.20s false, new pc %u\n", jmpOffset[0], - O2S(valuePtr), + TRACE_APPEND(("%.20s false, new pc %u\n", O2S(valuePtr), (unsigned)(pc + jmpOffset[0] - codePtr->codeStart))); } } @@ -4261,7 +4293,7 @@ TEBCresume( opnd = TclGetInt4AtPtr(pc+1); jtPtr = (JumptableInfo *) codePtr->auxDataArrayPtr[opnd].clientData; - TRACE(("%d => %.20s ", opnd, O2S(OBJ_AT_TOS))); + TRACE(("%d \"%.20s\" => ", opnd, O2S(OBJ_AT_TOS))); hPtr = Tcl_FindHashEntry(&jtPtr->hashTable, TclGetString(OBJ_AT_TOS)); if (hPtr != NULL) { int jumpOffset = PTR2INT(Tcl_GetHashValue(hPtr)); @@ -4356,13 +4388,11 @@ TEBCresume( register CallFrame *framePtr = iPtr->varFramePtr; register CallFrame *rootFramePtr = iPtr->rootFramePtr; - valuePtr = OBJ_AT_TOS; - if (TclGetIntFromObj(interp, valuePtr, &level) != TCL_OK) { - TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)), - Tcl_GetObjResult(interp)); + TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS))); + if (TclGetIntFromObj(interp, OBJ_AT_TOS, &level) != TCL_OK) { + TRACE_ERROR(interp); goto gotError; } - TRACE(("%d => ", level)); if (level <= 0) { level += framePtr->level; } @@ -4371,38 +4401,76 @@ TEBCresume( /* Empty loop body */ } if (framePtr == rootFramePtr) { - Tcl_AppendResult(interp, "bad level \"", TclGetString(valuePtr), - "\"", NULL); - TRACE_APPEND(("ERROR: bad level\n")); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad level \"%s\"", TclGetString(OBJ_AT_TOS))); + TRACE_ERROR(interp); + DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_LEVEL", - TclGetString(valuePtr), NULL); + TclGetString(OBJ_AT_TOS), NULL); + CACHE_STACK_INFO(); goto gotError; } objResultPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv); TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } - case INST_RESOLVE_COMMAND: { - Tcl_Command cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS); + { + Tcl_Command cmd, origCmd; + case INST_RESOLVE_COMMAND: + cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS); TclNewObj(objResultPtr); if (cmd != NULL) { Tcl_GetCommandFullName(interp, cmd, objResultPtr); } TRACE_WITH_OBJ(("\"%.20s\" => ", O2S(OBJ_AT_TOS)), objResultPtr); NEXT_INST_F(1, 1, 1); + + case INST_ORIGIN_COMMAND: + TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS))); + cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS); + if (cmd == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid command name \"%s\"", TclGetString(OBJ_AT_TOS))); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", + TclGetString(OBJ_AT_TOS), NULL); + CACHE_STACK_INFO(); + TRACE_APPEND(("ERROR: not command\n")); + goto gotError; + } + origCmd = TclGetOriginalCommand(cmd); + if (origCmd == NULL) { + origCmd = cmd; + } + TclNewObj(objResultPtr); + Tcl_GetCommandFullName(interp, origCmd, objResultPtr); + TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_TOS))); + NEXT_INST_F(1, 1, 1); } - case INST_TCLOO_SELF: { - CallFrame *framePtr = iPtr->varFramePtr; + + /* + * ----------------------------------------------------------------- + * Start of TclOO support instructions. + */ + + { + Object *oPtr; + CallFrame *framePtr; CallContext *contextPtr; + int skip, newDepth; + case INST_TCLOO_SELF: + framePtr = iPtr->varFramePtr; if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { TRACE(("=> ERROR: no TclOO call context\n")); Tcl_SetObjResult(interp, Tcl_NewStringObj( "self may only be called from inside a method", -1)); + DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); + CACHE_STACK_INFO(); goto gotError; } contextPtr = framePtr->clientData; @@ -4414,9 +4482,213 @@ TEBCresume( objResultPtr = TclOOObjectName(interp, contextPtr->oPtr); TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); - } - { - Object *oPtr; + + case INST_TCLOO_NEXT_CLASS: + opnd = TclGetUInt1AtPtr(pc+1); + framePtr = iPtr->varFramePtr; + valuePtr = OBJ_AT_DEPTH(opnd - 2); + objv = &OBJ_AT_DEPTH(opnd - 1); + skip = 2; + TRACE(("%d => ", opnd)); + if (framePtr == NULL || + !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { + TRACE_APPEND(("ERROR: no TclOO call context\n")); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "nextto may only be called from inside a method", + -1)); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); + CACHE_STACK_INFO(); + goto gotError; + } + contextPtr = framePtr->clientData; + + oPtr = (Object *) Tcl_GetObjectFromObj(interp, valuePtr); + if (oPtr == NULL) { + TRACE_APPEND(("ERROR: \"%.30s\" not object\n", O2S(valuePtr))); + goto gotError; + } else { + Class *classPtr = oPtr->classPtr; + struct MInvoke *miPtr; + int i; + const char *methodType; + + if (classPtr == NULL) { + TRACE_APPEND(("ERROR: \"%.30s\" not class\n", O2S(valuePtr))); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" is not a class", TclGetString(valuePtr))); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", NULL); + CACHE_STACK_INFO(); + goto gotError; + } + + for (i=contextPtr->index+1 ; i<contextPtr->callPtr->numChain ; i++) { + miPtr = contextPtr->callPtr->chain + i; + if (!miPtr->isFilter && + miPtr->mPtr->declaringClassPtr == classPtr) { + newDepth = i; +#ifdef TCL_COMPILE_DEBUG + if (tclTraceExec >= 2) { + if (traceInstructions) { + strncpy(cmdNameBuf, TclGetString(objv[0]), 20); + } else { + fprintf(stdout, "%d: (%u) invoking ", + iPtr->numLevels, + (unsigned)(pc - codePtr->codeStart)); + } + for (i = 0; i < opnd; i++) { + TclPrintObject(stdout, objv[i], 15); + fprintf(stdout, " "); + } + fprintf(stdout, "\n"); + fflush(stdout); + } +#endif /*TCL_COMPILE_DEBUG*/ + goto doInvokeNext; + } + } + + if (contextPtr->callPtr->flags & CONSTRUCTOR) { + methodType = "constructor"; + } else if (contextPtr->callPtr->flags & DESTRUCTOR) { + methodType = "destructor"; + } else { + methodType = "method"; + } + + TRACE_APPEND(("ERROR: \"%.30s\" not on reachable chain\n", + O2S(valuePtr))); + for (i=contextPtr->index ; i>=0 ; i--) { + miPtr = contextPtr->callPtr->chain + i; + if (miPtr->isFilter + || miPtr->mPtr->declaringClassPtr != classPtr) { + continue; + } + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s implementation by \"%s\" not reachable from here", + methodType, TclGetString(valuePtr))); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_REACHABLE", + NULL); + CACHE_STACK_INFO(); + goto gotError; + } + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s has no non-filter implementation by \"%s\"", + methodType, TclGetString(valuePtr))); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_THERE", NULL); + CACHE_STACK_INFO(); + goto gotError; + } + + case INST_TCLOO_NEXT: + opnd = TclGetUInt1AtPtr(pc+1); + objv = &OBJ_AT_DEPTH(opnd - 1); + framePtr = iPtr->varFramePtr; + skip = 1; + TRACE(("%d => ", opnd)); + if (framePtr == NULL || + !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { + TRACE_APPEND(("ERROR: no TclOO call context\n")); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "next may only be called from inside a method", + -1)); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); + CACHE_STACK_INFO(); + goto gotError; + } + contextPtr = framePtr->clientData; + + newDepth = contextPtr->index + 1; + if (newDepth >= contextPtr->callPtr->numChain) { + /* + * We're at the end of the chain; generate an error message unless + * the interpreter is being torn down, in which case we might be + * getting here because of methods/destructors doing a [next] (or + * equivalent) unexpectedly. + */ + + const char *methodType; + + if (contextPtr->callPtr->flags & CONSTRUCTOR) { + methodType = "constructor"; + } else if (contextPtr->callPtr->flags & DESTRUCTOR) { + methodType = "destructor"; + } else { + methodType = "method"; + } + + TRACE_APPEND(("ERROR: no TclOO next impl\n")); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "no next %s implementation", methodType)); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL); + CACHE_STACK_INFO(); + goto gotError; +#ifdef TCL_COMPILE_DEBUG + } else if (tclTraceExec >= 2) { + int i; + + if (traceInstructions) { + strncpy(cmdNameBuf, TclGetString(objv[0]), 20); + } else { + fprintf(stdout, "%d: (%u) invoking ", + iPtr->numLevels, (unsigned)(pc - codePtr->codeStart)); + } + for (i = 0; i < opnd; i++) { + TclPrintObject(stdout, objv[i], 15); + fprintf(stdout, " "); + } + fprintf(stdout, "\n"); + fflush(stdout); +#endif /*TCL_COMPILE_DEBUG*/ + } + + doInvokeNext: + bcFramePtr->data.tebc.pc = (char *) pc; + iPtr->cmdFramePtr = bcFramePtr; + + if (iPtr->flags & INTERP_DEBUG_FRAME) { + ArgumentBCEnter(interp, codePtr, TD, pc, opnd, objv); + } + + pcAdjustment = 2; + cleanup = opnd; + DECACHE_STACK_INFO(); + iPtr->varFramePtr = framePtr->callerVarPtr; + pc += pcAdjustment; + TEBC_YIELD(); + + TclPushTailcallPoint(interp); + oPtr = contextPtr->oPtr; + if (oPtr->flags & FILTER_HANDLING) { + TclNRAddCallback(interp, FinalizeOONextFilter, + framePtr, contextPtr, INT2PTR(contextPtr->index), + INT2PTR(contextPtr->skip)); + } else { + TclNRAddCallback(interp, FinalizeOONext, + framePtr, contextPtr, INT2PTR(contextPtr->index), + INT2PTR(contextPtr->skip)); + } + contextPtr->skip = skip; + contextPtr->index = newDepth; + if (contextPtr->callPtr->chain[newDepth].isFilter + || contextPtr->callPtr->flags & FILTER_HANDLING) { + oPtr->flags |= FILTER_HANDLING; + } else { + oPtr->flags &= ~FILTER_HANDLING; + } + + { + register Method *const mPtr = + contextPtr->callPtr->chain[newDepth].mPtr; + + return mPtr->typePtr->callProc(mPtr->clientData, interp, + (Tcl_ObjectContext) contextPtr, opnd, objv); + } case INST_TCLOO_IS_OBJECT: oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS); @@ -4450,6 +4722,7 @@ TEBCresume( } /* + * End of TclOO support instructions. * ----------------------------------------------------------------- * Start of INST_LIST and related instructions. */ @@ -4471,19 +4744,19 @@ TEBCresume( NEXT_INST_V(5, opnd, 1); case INST_LIST_LENGTH: - valuePtr = OBJ_AT_TOS; - if (TclListObjLength(interp, valuePtr, &length) != TCL_OK) { - TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)), - Tcl_GetObjResult(interp)); + TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS))); + if (TclListObjLength(interp, OBJ_AT_TOS, &length) != TCL_OK) { + TRACE_ERROR(interp); goto gotError; } TclNewIntObj(objResultPtr, length); - TRACE(("%.20s => %d\n", O2S(valuePtr), length)); + TRACE_APPEND(("%d\n", length)); NEXT_INST_F(1, 1, 1); case INST_LIST_INDEX: /* lindex with objc == 3 */ value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; + TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); /* * Extract the desired list element. @@ -4501,8 +4774,7 @@ TEBCresume( objResultPtr = TclLindexList(interp, valuePtr, value2Ptr); if (!objResultPtr) { - TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", O2S(valuePtr), - O2S(value2Ptr)), Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } @@ -4510,8 +4782,7 @@ TEBCresume( * Stash the list element on the stack. */ - TRACE(("%.20s %.20s => %s\n", - O2S(valuePtr), O2S(value2Ptr), O2S(objResultPtr))); + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, -1); /* Already has the correct refCount */ case INST_LIST_INDEX_IMM: /* lindex with objc==3 and index in bytecode @@ -4523,6 +4794,7 @@ TEBCresume( valuePtr = OBJ_AT_TOS; opnd = TclGetInt4AtPtr(pc+1); + TRACE(("\"%.30s\" %d => ", O2S(valuePtr), opnd)); /* * Get the contents of the list, making sure that it really is a list @@ -4530,21 +4802,13 @@ TEBCresume( */ if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { - TRACE_WITH_OBJ(("\"%.30s\" %d => ERROR: ", O2S(valuePtr), opnd), - Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } - /* - * Select the list item based on the index. Negative operand means - * end-based indexing. - */ + /* Decode end-offset index values. */ - if (opnd < -1) { - index = opnd+1 + objc; - } else { - index = opnd; - } + index = TclIndexDecode(opnd, objc - 1); pcAdjustment = 5; lindexFastPath: @@ -4554,8 +4818,7 @@ TEBCresume( TclNewObj(objResultPtr); } - TRACE_WITH_OBJ(("\"%.30s\" %d => ", O2S(valuePtr), opnd), - objResultPtr); + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_F(pcAdjustment, 1, 1); case INST_LIST_INDEX_MULTI: /* 'lindex' with multiple index args */ @@ -4570,10 +4833,11 @@ TEBCresume( * Do the 'lindex' operation. */ + TRACE(("%d => ", opnd)); objResultPtr = TclLindexFlat(interp, OBJ_AT_DEPTH(numIndices), numIndices, &OBJ_AT_DEPTH(numIndices - 1)); if (!objResultPtr) { - TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } @@ -4581,7 +4845,7 @@ TEBCresume( * Set result. */ - TRACE(("%d => %s\n", opnd, O2S(objResultPtr))); + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_V(5, opnd, -1); case INST_LSET_FLAT: @@ -4591,6 +4855,7 @@ TEBCresume( opnd = TclGetUInt4AtPtr(pc + 1); numIndices = opnd - 2; + TRACE(("%d => ", opnd)); /* * Get the old value of variable, and remove the stack ref. This is @@ -4609,7 +4874,7 @@ TEBCresume( objResultPtr = TclLsetFlat(interp, valuePtr, numIndices, &OBJ_AT_DEPTH(numIndices), OBJ_AT_TOS); if (!objResultPtr) { - TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } @@ -4617,7 +4882,7 @@ TEBCresume( * Set result. */ - TRACE(("%d => %s\n", opnd, O2S(objResultPtr))); + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_V(5, numIndices+1, -1); case INST_LSET_LIST: /* 'lset' with 4 args */ @@ -4637,6 +4902,8 @@ TEBCresume( valuePtr = OBJ_AT_TOS; value2Ptr = OBJ_UNDER_TOS; + TRACE(("\"%.30s\" \"%.30s\" \"%.30s\" => ", + O2S(value2Ptr), O2S(valuePtr), O2S(objPtr))); /* * Compute the new variable value. @@ -4644,8 +4911,7 @@ TEBCresume( objResultPtr = TclLsetList(interp, objPtr, value2Ptr, valuePtr); if (!objResultPtr) { - TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(value2Ptr)), - Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } @@ -4653,7 +4919,7 @@ TEBCresume( * Set result. */ - TRACE(("=> %s\n", O2S(objResultPtr))); + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, -1); case INST_LIST_RANGE_IMM: /* lrange with objc==4 and both indices in @@ -4666,15 +4932,16 @@ TEBCresume( valuePtr = OBJ_AT_TOS; fromIdx = TclGetInt4AtPtr(pc+1); toIdx = TclGetInt4AtPtr(pc+5); + TRACE(("\"%.30s\" %d %d => ", O2S(valuePtr), TclGetInt4AtPtr(pc+1), + TclGetInt4AtPtr(pc+5))); /* - * Get the contents of the list, making sure that it really is a list + * Get the length of the list, making sure that it really is a list * in the process. */ - if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { - TRACE_WITH_OBJ(("\"%.30s\" %d %d => ERROR: ", O2S(valuePtr), - fromIdx, toIdx), Tcl_GetObjResult(interp)); + if (TclListObjLength(interp, valuePtr, &objc) != TCL_OK) { + TRACE_ERROR(interp); goto gotError; } @@ -4689,67 +4956,51 @@ TEBCresume( } #endif + /* Every range of an empty list is an empty list */ + if (objc == 0) { + TRACE_APPEND(("\n")); + NEXT_INST_F(9, 0, 0); + } + + /* Decode index value operands. */ + /* - * Adjust the indices for end-based handling. + assert ( toIdx != TCL_INDEX_AFTER); + * + * Extra safety for legacy bytecodes: */ + if (toIdx == TCL_INDEX_AFTER) { + toIdx = TCL_INDEX_END; + } - if (fromIdx < -1) { - fromIdx += 1+objc; - if (fromIdx < -1) { - fromIdx = -1; - } - } else if (fromIdx > objc) { - fromIdx = objc; + if ((toIdx == TCL_INDEX_BEFORE) || (fromIdx == TCL_INDEX_AFTER)) { + emptyList: + objResultPtr = Tcl_NewObj(); + TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr))); + NEXT_INST_F(9, 1, 1); } - if (toIdx < -1) { - toIdx += 1 + objc; - if (toIdx < -1) { - toIdx = -1; - } - } else if (toIdx > objc) { - toIdx = objc; + toIdx = TclIndexDecode(toIdx, objc - 1); + if (toIdx < 0) { + goto emptyList; + } else if (toIdx >= objc) { + toIdx = objc - 1; } + assert ( toIdx >= 0 && toIdx < objc); /* - * Check if we are referring to a valid, non-empty list range, and if - * so, build the list of elements in that range. + assert ( fromIdx != TCL_INDEX_BEFORE ); + * + * Extra safety for legacy bytecodes: */ + if (fromIdx == TCL_INDEX_BEFORE) { + fromIdx = TCL_INDEX_START; + } - if (fromIdx<=toIdx && fromIdx<objc && toIdx>=0) { - if (fromIdx < 0) { - fromIdx = 0; - } - if (toIdx >= objc) { - toIdx = objc-1; - } - if (fromIdx == 0 && toIdx != objc-1 && !Tcl_IsShared(valuePtr)) { - /* - * BEWARE! This is looking inside the implementation of the - * list type. - */ + fromIdx = TclIndexDecode(fromIdx, objc - 1); - List *listPtr = valuePtr->internalRep.twoPtrValue.ptr1; + objResultPtr = TclListObjRange(valuePtr, fromIdx, toIdx); - if (listPtr->refCount == 1) { - TRACE(("\"%.30s\" %d %d => ", O2S(valuePtr), - TclGetInt4AtPtr(pc+1), TclGetInt4AtPtr(pc+5))); - for (index=toIdx+1 ; index<objc-1 ; index++) { - TclDecrRefCount(objv[index]); - } - listPtr->elemCount = toIdx+1; - listPtr->canonicalFlag = 1; - TclInvalidateStringRep(valuePtr); - TRACE_APPEND(("%.30s\n", O2S(valuePtr))); - NEXT_INST_F(9, 0, 0); - } - } - objResultPtr = Tcl_NewListObj(toIdx-fromIdx+1, objv+fromIdx); - } else { - TclNewObj(objResultPtr); - } - - TRACE_WITH_OBJ(("\"%.30s\" %d %d => ", O2S(valuePtr), - TclGetInt4AtPtr(pc+1), TclGetInt4AtPtr(pc+5)), objResultPtr); + TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr))); NEXT_INST_F(9, 1, 1); case INST_LIST_IN: @@ -4758,9 +5009,9 @@ TEBCresume( valuePtr = OBJ_UNDER_TOS; s1 = TclGetStringFromObj(valuePtr, &s1len); + TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); if (TclListObjLength(interp, value2Ptr, &length) != TCL_OK) { - TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ERROR: ", O2S(valuePtr), - O2S(value2Ptr)), Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } match = 0; @@ -4791,7 +5042,7 @@ TEBCresume( match = !match; } - TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match)); + TRACE_APPEND(("%d\n", match)); /* * Peep-hole optimisation: if you're about to jump, do jump from here. @@ -4799,21 +5050,7 @@ TEBCresume( * for branching. */ - pc++; -#ifndef TCL_COMPILE_DEBUG - switch (*pc) { - case INST_JUMP_FALSE1: - NEXT_INST_F((match ? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE1: - NEXT_INST_F((match ? TclGetInt1AtPtr(pc+1) : 2), 2, 0); - case INST_JUMP_FALSE4: - NEXT_INST_F((match ? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE4: - NEXT_INST_F((match ? TclGetInt4AtPtr(pc+1) : 5), 2, 0); - } -#endif - objResultPtr = TCONST(match); - NEXT_INST_F(0, 2, 1); + JUMP_PEEPHOLE_F(match, 1, 2); case INST_LIST_CONCAT: value2Ptr = OBJ_AT_TOS; @@ -4823,7 +5060,7 @@ TEBCresume( objResultPtr = Tcl_DuplicateObj(valuePtr); if (Tcl_ListObjAppendList(interp, objResultPtr, value2Ptr) != TCL_OK) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); TclDecrRefCount(objResultPtr); goto gotError; } @@ -4831,7 +5068,7 @@ TEBCresume( NEXT_INST_F(1, 2, 1); } else { if (Tcl_ListObjAppendList(interp, valuePtr, value2Ptr) != TCL_OK){ - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); @@ -4851,86 +5088,10 @@ TEBCresume( value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; - if (valuePtr == value2Ptr) { - match = 0; - } else { - /* - * We only need to check (in)equality when we have equal length - * strings. We can use memcmp in all (n)eq cases because we - * don't need to worry about lexical LE/BE variance. - */ - - typedef int (*memCmpFn_t)(const void*, const void*, size_t); - memCmpFn_t memCmpFn; + { int checkEq = ((*pc == INST_EQ) || (*pc == INST_NEQ) || (*pc == INST_STR_EQ) || (*pc == INST_STR_NEQ)); - - if (TclIsPureByteArray(valuePtr) - && TclIsPureByteArray(value2Ptr)) { - s1 = (char *) Tcl_GetByteArrayFromObj(valuePtr, &s1len); - s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len); - memCmpFn = memcmp; - } else if (((valuePtr->typePtr == &tclStringType) - && (value2Ptr->typePtr == &tclStringType))) { - /* - * Do a unicode-specific comparison if both of the args are of - * String type. If the char length == byte length, we can do a - * memcmp. In benchmark testing this proved the most efficient - * check between the unicode and string comparison operations. - */ - - s1len = Tcl_GetCharLength(valuePtr); - s2len = Tcl_GetCharLength(value2Ptr); - if ((s1len == valuePtr->length) - && (s2len == value2Ptr->length)) { - s1 = valuePtr->bytes; - s2 = value2Ptr->bytes; - memCmpFn = memcmp; - } else { - s1 = (char *) Tcl_GetUnicode(valuePtr); - s2 = (char *) Tcl_GetUnicode(value2Ptr); - if ( -#ifdef WORDS_BIGENDIAN - 1 -#else - checkEq -#endif - ) { - memCmpFn = memcmp; - s1len *= sizeof(Tcl_UniChar); - s2len *= sizeof(Tcl_UniChar); - } else { - memCmpFn = (memCmpFn_t) Tcl_UniCharNcmp; - } - } - } else { - /* - * strcmp can't do a simple memcmp in order to handle the - * special Tcl \xC0\x80 null encoding for utf-8. - */ - - s1 = TclGetStringFromObj(valuePtr, &s1len); - s2 = TclGetStringFromObj(value2Ptr, &s2len); - if (checkEq) { - memCmpFn = memcmp; - } else { - memCmpFn = (memCmpFn_t) TclpUtfNcmp2; - } - } - - if (checkEq && (s1len != s2len)) { - match = 1; - } else { - /* - * The comparison function should compare up to the minimum - * byte length only. - */ - match = memCmpFn(s1, s2, - (size_t) ((s1len < s2len) ? s1len : s2len)); - if (match == 0) { - match = s1len - s2len; - } - } + match = TclStringCmp(valuePtr, value2Ptr, checkEq, 0, -1); } /* @@ -4966,25 +5127,74 @@ TEBCresume( break; } } - if (match < 0) { - TclNewIntObj(objResultPtr, -1); - } else { - objResultPtr = TCONST(match > 0); - } - TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr), - O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); + + TRACE(("\"%.20s\" \"%.20s\" => %d\n", O2S(valuePtr), O2S(value2Ptr), + (match < 0 ? -1 : match > 0 ? 1 : 0))); + JUMP_PEEPHOLE_F(match, 1, 2); case INST_STR_LEN: valuePtr = OBJ_AT_TOS; length = Tcl_GetCharLength(valuePtr); TclNewIntObj(objResultPtr, length); - TRACE(("%.20s => %d\n", O2S(valuePtr), length)); + TRACE(("\"%.20s\" => %d\n", O2S(valuePtr), length)); NEXT_INST_F(1, 1, 1); + case INST_STR_UPPER: + valuePtr = OBJ_AT_TOS; + TRACE(("\"%.20s\" => ", O2S(valuePtr))); + if (Tcl_IsShared(valuePtr)) { + s1 = TclGetStringFromObj(valuePtr, &length); + TclNewStringObj(objResultPtr, s1, length); + length = Tcl_UtfToUpper(TclGetString(objResultPtr)); + Tcl_SetObjLength(objResultPtr, length); + TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr))); + NEXT_INST_F(1, 1, 1); + } else { + length = Tcl_UtfToUpper(TclGetString(valuePtr)); + Tcl_SetObjLength(valuePtr, length); + TclFreeIntRep(valuePtr); + TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr))); + NEXT_INST_F(1, 0, 0); + } + case INST_STR_LOWER: + valuePtr = OBJ_AT_TOS; + TRACE(("\"%.20s\" => ", O2S(valuePtr))); + if (Tcl_IsShared(valuePtr)) { + s1 = TclGetStringFromObj(valuePtr, &length); + TclNewStringObj(objResultPtr, s1, length); + length = Tcl_UtfToLower(TclGetString(objResultPtr)); + Tcl_SetObjLength(objResultPtr, length); + TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr))); + NEXT_INST_F(1, 1, 1); + } else { + length = Tcl_UtfToLower(TclGetString(valuePtr)); + Tcl_SetObjLength(valuePtr, length); + TclFreeIntRep(valuePtr); + TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr))); + NEXT_INST_F(1, 0, 0); + } + case INST_STR_TITLE: + valuePtr = OBJ_AT_TOS; + TRACE(("\"%.20s\" => ", O2S(valuePtr))); + if (Tcl_IsShared(valuePtr)) { + s1 = TclGetStringFromObj(valuePtr, &length); + TclNewStringObj(objResultPtr, s1, length); + length = Tcl_UtfToTitle(TclGetString(objResultPtr)); + Tcl_SetObjLength(objResultPtr, length); + TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr))); + NEXT_INST_F(1, 1, 1); + } else { + length = Tcl_UtfToTitle(TclGetString(valuePtr)); + Tcl_SetObjLength(valuePtr, length); + TclFreeIntRep(valuePtr); + TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr))); + NEXT_INST_F(1, 0, 0); + } + case INST_STR_INDEX: value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; + TRACE(("\"%.20s\" %.20s => ", O2S(valuePtr), O2S(value2Ptr))); /* * Get char length to calulate what 'end' means. @@ -4992,6 +5202,7 @@ TEBCresume( length = Tcl_GetCharLength(valuePtr); if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) { + TRACE_ERROR(interp); goto gotError; } @@ -4999,36 +5210,42 @@ TEBCresume( TclNewObj(objResultPtr); } else if (TclIsPureByteArray(valuePtr)) { objResultPtr = Tcl_NewByteArrayObj( - Tcl_GetByteArrayFromObj(valuePtr, &length)+index, 1); + Tcl_GetByteArrayFromObj(valuePtr, NULL)+index, 1); } else if (valuePtr->bytes && length == valuePtr->length) { objResultPtr = Tcl_NewStringObj((const char *) valuePtr->bytes+index, 1); } else { - char buf[TCL_UTF_MAX]; - Tcl_UniChar ch = Tcl_GetUniChar(valuePtr, index); + char buf[4]; + int ch = Tcl_GetUniChar(valuePtr, index); /* * This could be: Tcl_NewUnicodeObj((const Tcl_UniChar *)&ch, 1) * but creating the object as a string seems to be faster in * practical use. */ - - length = Tcl_UniCharToUtf(ch, buf); - objResultPtr = Tcl_NewStringObj(buf, length); + if (ch == -1) { + objResultPtr = Tcl_NewObj(); + } else { + length = Tcl_UniCharToUtf(ch, buf); + if (!length) { + length = Tcl_UniCharToUtf(-1, buf); + } + objResultPtr = Tcl_NewStringObj(buf, length); + } } - TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr), - O2S(objResultPtr))); + TRACE_APPEND(("\"%s\"\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); case INST_STR_RANGE: - TRACE(("\"%.20s\" %s %s =>", + TRACE(("\"%.20s\" %.20s %.20s =>", O2S(OBJ_AT_DEPTH(2)), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS))); length = Tcl_GetCharLength(OBJ_AT_DEPTH(2)) - 1; if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length, &fromIdx) != TCL_OK || TclGetIntForIndexM(interp, OBJ_AT_TOS, length, &toIdx) != TCL_OK) { + TRACE_ERROR(interp); goto gotError; } @@ -5053,31 +5270,58 @@ TEBCresume( length = Tcl_GetCharLength(valuePtr); TRACE(("\"%.20s\" %d %d => ", O2S(valuePtr), fromIdx, toIdx)); + /* Every range of an empty value is an empty value */ + if (length == 0) { + TRACE_APPEND(("\n")); + NEXT_INST_F(9, 0, 0); + } + + /* Decode index operands. */ + /* - * Adjust indices for end-based indexing. + assert ( toIdx != TCL_INDEX_BEFORE ); + assert ( toIdx != TCL_INDEX_AFTER); + * + * Extra safety for legacy bytecodes: */ - - if (fromIdx < -1) { - fromIdx += 1 + length; - if (fromIdx < 0) { - fromIdx = 0; - } - } else if (fromIdx >= length) { - fromIdx = length; + if (toIdx == TCL_INDEX_BEFORE) { + goto emptyRange; + } + if (toIdx == TCL_INDEX_AFTER) { + toIdx = TCL_INDEX_END; } - if (toIdx < -1) { - toIdx += 1 + length; + + toIdx = TclIndexDecode(toIdx, length - 1); + if (toIdx < 0) { + goto emptyRange; } else if (toIdx >= length) { toIdx = length - 1; } + assert ( toIdx >= 0 && toIdx < length ); + /* - * Check if we can do a sane substring. + assert ( fromIdx != TCL_INDEX_BEFORE ); + assert ( fromIdx != TCL_INDEX_AFTER); + * + * Extra safety for legacy bytecodes: */ + if (fromIdx == TCL_INDEX_BEFORE) { + fromIdx = TCL_INDEX_START; + } + if (fromIdx == TCL_INDEX_AFTER) { + goto emptyRange; + } + + fromIdx = TclIndexDecode(fromIdx, length - 1); + if (fromIdx < 0) { + fromIdx = 0; + } if (fromIdx <= toIdx) { objResultPtr = Tcl_GetRange(valuePtr, fromIdx, toIdx); } else { + emptyRange: TclNewObj(objResultPtr); } TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); @@ -5085,36 +5329,92 @@ TEBCresume( { Tcl_UniChar *ustring1, *ustring2, *ustring3, *end, *p; - int length3; + int length3, endIdx; Tcl_Obj *value3Ptr; + case INST_STR_REPLACE: + value3Ptr = POP_OBJECT(); + valuePtr = OBJ_AT_DEPTH(2); + endIdx = Tcl_GetCharLength(valuePtr) - 1; + TRACE(("\"%.20s\" %s %s \"%.20s\" => ", O2S(valuePtr), + O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(value3Ptr))); + if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, endIdx, + &fromIdx) != TCL_OK + || TclGetIntForIndexM(interp, OBJ_AT_TOS, endIdx, + &toIdx) != TCL_OK) { + TclDecrRefCount(value3Ptr); + TRACE_ERROR(interp); + goto gotError; + } + TclDecrRefCount(OBJ_AT_TOS); + (void) POP_OBJECT(); + TclDecrRefCount(OBJ_AT_TOS); + (void) POP_OBJECT(); + + if ((toIdx < 0) || + (fromIdx > endIdx) || + (toIdx < fromIdx)) { + TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); + TclDecrRefCount(value3Ptr); + NEXT_INST_F(1, 0, 0); + } + + if (fromIdx < 0) { + fromIdx = 0; + } + + if (toIdx > endIdx) { + toIdx = endIdx; + } + + if (fromIdx == 0 && toIdx == endIdx) { + TclDecrRefCount(OBJ_AT_TOS); + OBJ_AT_TOS = value3Ptr; + TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr))); + NEXT_INST_F(1, 0, 0); + } + + objResultPtr = TclStringReplace(interp, valuePtr, fromIdx, + toIdx - fromIdx + 1, value3Ptr, TCL_STRING_IN_PLACE); + + if (objResultPtr == value3Ptr) { + /* See [Bug 82e7f67325] */ + TclDecrRefCount(OBJ_AT_TOS); + OBJ_AT_TOS = value3Ptr; + TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr))); + NEXT_INST_F(1, 0, 0); + } + TclDecrRefCount(value3Ptr); + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); + NEXT_INST_F(1, 1, 1); + case INST_STR_MAP: valuePtr = OBJ_AT_TOS; /* "Main" string. */ value3Ptr = OBJ_UNDER_TOS; /* "Target" string. */ value2Ptr = OBJ_AT_DEPTH(2); /* "Source" string. */ if (value3Ptr == value2Ptr) { objResultPtr = valuePtr; - NEXT_INST_V(1, 3, 1); + goto doneStringMap; } else if (valuePtr == value2Ptr) { objResultPtr = value3Ptr; - NEXT_INST_V(1, 3, 1); + goto doneStringMap; } ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length); if (length == 0) { objResultPtr = valuePtr; - NEXT_INST_V(1, 3, 1); + goto doneStringMap; } ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2); if (length2 > length || length2 == 0) { objResultPtr = valuePtr; - NEXT_INST_V(1, 3, 1); + goto doneStringMap; } else if (length2 == length) { if (memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length)) { objResultPtr = valuePtr; } else { objResultPtr = value3Ptr; } - NEXT_INST_V(1, 3, 1); + goto doneStringMap; } ustring3 = Tcl_GetUnicodeFromObj(value3Ptr, &length3); @@ -5143,52 +5443,45 @@ TEBCresume( Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1 - p); } + doneStringMap: TRACE_WITH_OBJ(("%.20s %.20s %.20s => ", O2S(value2Ptr), O2S(value3Ptr), O2S(valuePtr)), objResultPtr); NEXT_INST_V(1, 3, 1); case INST_STR_FIND: - ustring1 = Tcl_GetUnicodeFromObj(OBJ_AT_TOS, &length); /* Haystack */ - ustring2 = Tcl_GetUnicodeFromObj(OBJ_UNDER_TOS, &length2);/* Needle */ - - match = -1; - if (length2 > 0 && length2 <= length) { - end = ustring1 + length - length2 + 1; - for (p=ustring1 ; p<end ; p++) { - if ((*p == *ustring2) && - memcmp(ustring2,p,sizeof(Tcl_UniChar)*length2) == 0) { - match = p - ustring1; - break; - } - } - } + match = TclStringFirst(OBJ_UNDER_TOS, OBJ_AT_TOS, 0); TRACE(("%.20s %.20s => %d\n", O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match)); - TclNewIntObj(objResultPtr, match); NEXT_INST_F(1, 2, 1); case INST_STR_FIND_LAST: - ustring1 = Tcl_GetUnicodeFromObj(OBJ_AT_TOS, &length); /* Haystack */ - ustring2 = Tcl_GetUnicodeFromObj(OBJ_UNDER_TOS, &length2);/* Needle */ - - match = -1; - if (length2 > 0 && length2 <= length) { - for (p=ustring1+length-length2 ; p>=ustring1 ; p--) { - if ((*p == *ustring2) && - memcmp(ustring2,p,sizeof(Tcl_UniChar)*length2) == 0) { - match = p - ustring1; - break; - } - } - } + match = TclStringLast(OBJ_UNDER_TOS, OBJ_AT_TOS, INT_MAX - 1); TRACE(("%.20s %.20s => %d\n", O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match)); - TclNewIntObj(objResultPtr, match); NEXT_INST_F(1, 2, 1); + + case INST_STR_CLASS: + opnd = TclGetInt1AtPtr(pc+1); + valuePtr = OBJ_AT_TOS; + TRACE(("%s \"%.30s\" => ", tclStringClassTable[opnd].name, + O2S(valuePtr))); + ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length); + match = 1; + if (length > 0) { + end = ustring1 + length; + for (p=ustring1 ; p<end ; p++) { + if (!tclStringClassTable[opnd].comparator(*p)) { + match = 0; + break; + } + } + } + TRACE_APPEND(("%d\n", match)); + JUMP_PEEPHOLE_F(match, 2, 1); } case INST_STR_MATCH: @@ -5231,26 +5524,72 @@ TEBCresume( * Peep-hole optimisation: if you're about to jump, do jump from here. */ - pc += 2; -#ifndef TCL_COMPILE_DEBUG - switch (*pc) { - case INST_JUMP_FALSE1: - NEXT_INST_F((match? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE1: - NEXT_INST_F((match? TclGetInt1AtPtr(pc+1) : 2), 2, 0); - case INST_JUMP_FALSE4: - NEXT_INST_F((match? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE4: - NEXT_INST_F((match? TclGetInt4AtPtr(pc+1) : 5), 2, 0); + JUMP_PEEPHOLE_F(match, 2, 2); + + { + const char *string1, *string2; + int trim1, trim2; + + case INST_STR_TRIM_LEFT: + valuePtr = OBJ_UNDER_TOS; /* String */ + value2Ptr = OBJ_AT_TOS; /* TrimSet */ + string2 = TclGetStringFromObj(value2Ptr, &length2); + string1 = TclGetStringFromObj(valuePtr, &length); + trim1 = TclTrimLeft(string1, length, string2, length2); + trim2 = 0; + goto createTrimmedString; + case INST_STR_TRIM_RIGHT: + valuePtr = OBJ_UNDER_TOS; /* String */ + value2Ptr = OBJ_AT_TOS; /* TrimSet */ + string2 = TclGetStringFromObj(value2Ptr, &length2); + string1 = TclGetStringFromObj(valuePtr, &length); + trim2 = TclTrimRight(string1, length, string2, length2); + trim1 = 0; + goto createTrimmedString; + case INST_STR_TRIM: + valuePtr = OBJ_UNDER_TOS; /* String */ + value2Ptr = OBJ_AT_TOS; /* TrimSet */ + string2 = TclGetStringFromObj(value2Ptr, &length2); + string1 = TclGetStringFromObj(valuePtr, &length); + trim1 = TclTrim(string1, length, string2, length2, &trim2); + createTrimmedString: + /* + * Careful here; trim set often contains non-ASCII characters so we + * take care when printing. [Bug 971cb4f1db] + */ + +#ifdef TCL_COMPILE_DEBUG + if (traceInstructions) { + TRACE(("\"%.30s\" ", O2S(valuePtr))); + TclPrintObject(stdout, value2Ptr, 30); + printf(" => "); } #endif - objResultPtr = TCONST(match); - NEXT_INST_F(0, 2, 1); + if (trim1 == 0 && trim2 == 0) { +#ifdef TCL_COMPILE_DEBUG + if (traceInstructions) { + TclPrintObject(stdout, valuePtr, 30); + printf("\n"); + } +#endif + NEXT_INST_F(1, 1, 0); + } else { + objResultPtr = Tcl_NewStringObj(string1+trim1, length-trim1-trim2); +#ifdef TCL_COMPILE_DEBUG + if (traceInstructions) { + TclPrintObject(stdout, objResultPtr, 30); + printf("\n"); + } +#endif + NEXT_INST_F(1, 2, 1); + } + } case INST_REGEXP: cflags = TclGetInt1AtPtr(pc+1); /* RE compile flages like NOCASE */ valuePtr = OBJ_AT_TOS; /* String */ value2Ptr = OBJ_UNDER_TOS; /* Pattern */ + TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); /* * Compile and match the regular expression. @@ -5261,44 +5600,24 @@ TEBCresume( Tcl_GetRegExpFromObj(interp, value2Ptr, cflags); if (regExpr == NULL) { - goto regexpFailure; + TRACE_ERROR(interp); + goto gotError; } - match = Tcl_RegExpExecObj(interp, regExpr, valuePtr, 0, 0, 0); - if (match < 0) { - regexpFailure: -#ifdef TCL_COMPILE_DEBUG - objResultPtr = Tcl_GetObjResult(interp); - TRACE_WITH_OBJ(("%.20s %.20s => ERROR: ", - O2S(valuePtr), O2S(value2Ptr)), objResultPtr); -#endif + TRACE_ERROR(interp); goto gotError; } } - TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match)); + TRACE_APPEND(("%d\n", match)); /* * Peep-hole optimisation: if you're about to jump, do jump from here. * Adjustment is 2 due to the nocase byte. */ - pc += 2; -#ifndef TCL_COMPILE_DEBUG - switch (*pc) { - case INST_JUMP_FALSE1: - NEXT_INST_F((match? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE1: - NEXT_INST_F((match? TclGetInt1AtPtr(pc+1) : 2), 2, 0); - case INST_JUMP_FALSE4: - NEXT_INST_F((match? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); - case INST_JUMP_TRUE4: - NEXT_INST_F((match? TclGetInt4AtPtr(pc+1) : 5), 2, 0); - } -#endif - objResultPtr = TCONST(match); - NEXT_INST_F(0, 2, 1); + JUMP_PEEPHOLE_F(match, 2, 2); } /* @@ -5310,7 +5629,32 @@ TEBCresume( { ClientData ptr1, ptr2; int type1, type2; - long l1, l2, lResult; + Tcl_WideInt w1, w2, wResult; + + case INST_NUM_TYPE: + if (GetNumberFromObj(NULL, OBJ_AT_TOS, &ptr1, &type1) != TCL_OK) { + type1 = 0; + } else if (type1 == TCL_NUMBER_WIDE) { + /* value is between LLONG_MIN and LLONG_MAX */ + /* [string is integer] is -UINT_MAX to UINT_MAX range */ + /* [string is wideinteger] is -ULLONG_MAX to ULLONG_MAX range */ + int i; + + if (Tcl_GetIntFromObj(NULL, OBJ_AT_TOS, &i) == TCL_OK) { + type1 = TCL_NUMBER_LONG; + } + } else if (type1 == TCL_NUMBER_BIG) { + /* value is an integer outside the LLONG_MIN to LLONG_MAX range */ + /* [string is wideinteger] is -ULLONG_MAX to ULLONG_MAX range */ + Tcl_WideInt w; + + if (Tcl_GetWideIntFromObj(NULL, OBJ_AT_TOS, &w) == TCL_OK) { + type1 = TCL_NUMBER_WIDE; + } + } + TclNewIntObj(objResultPtr, type1); + TRACE(("\"%.20s\" => %d\n", O2S(OBJ_AT_TOS), type1)); + NEXT_INST_F(1, 1, 1); case INST_EQ: case INST_NEQ: @@ -5323,16 +5667,25 @@ TEBCresume( value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; - if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) { + /* + Try to determine, without triggering generation of a string + representation, whether one value is not a number. + */ + if (TclCheckEmptyString(valuePtr) > 0 || TclCheckEmptyString(value2Ptr) > 0) { + goto stringCompare; + } + + if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK + || GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) { /* * At least one non-numeric argument - compare as strings. */ goto stringCompare; } - if (type1 == TCL_NUMBER_NAN) { + if (type1 == TCL_NUMBER_NAN || type2 == TCL_NUMBER_NAN) { /* - * NaN first arg: NaN != to everything, other compares are false. + * NaN arg: NaN != to everything, other compares are false. */ iResult = (*pc == INST_NEQ); @@ -5342,25 +5695,10 @@ TEBCresume( compare = MP_EQ; goto convertComparison; } - if (GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) { - /* - * At least one non-numeric argument - compare as strings. - */ - - goto stringCompare; - } - if (type2 == TCL_NUMBER_NAN) { - /* - * NaN 2nd arg: NaN != to everything, other compares are false. - */ - - iResult = (*pc == INST_NEQ); - goto foundResult; - } - if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { - l1 = *((const long *)ptr1); - l2 = *((const long *)ptr2); - compare = (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ); + if ((type1 == TCL_NUMBER_WIDE) && (type2 == TCL_NUMBER_WIDE)) { + w1 = *((const Tcl_WideInt *)ptr1); + w2 = *((const Tcl_WideInt *)ptr2); + compare = (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ); } else { compare = TclCompareTwoNumbers(valuePtr, value2Ptr); } @@ -5396,21 +5734,9 @@ TEBCresume( */ foundResult: - 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 = TCONST(iResult); - NEXT_INST_F(0, 2, 1); + TRACE(("\"%.20s\" \"%.20s\" => %d\n", O2S(valuePtr), O2S(value2Ptr), + iResult)); + JUMP_PEEPHOLE_F(iResult, 1, 2); } case INST_MOD: @@ -5448,17 +5774,17 @@ TEBCresume( * Check for common, simple case. */ - if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { - l1 = *((const long *)ptr1); - l2 = *((const long *)ptr2); + if ((type1 == TCL_NUMBER_WIDE) && (type2 == TCL_NUMBER_WIDE)) { + w1 = *((const Tcl_WideInt *)ptr1); + w2 = *((const Tcl_WideInt *)ptr2); switch (*pc) { case INST_MOD: - if (l2 == 0) { + if (w2 == 0) { TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr), O2S(value2Ptr))); goto divideByZero; - } else if ((l2 == 1) || (l2 == -1)) { + } else if ((w2 == 1) || (w2 == -1)) { /* * Div. by |1| always yields remainder of 0. */ @@ -5467,7 +5793,7 @@ TEBCresume( objResultPtr = TCONST(0); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); - } else if (l1 == 0) { + } else if (w1 == 0) { /* * 0 % (non-zero) always yields remainder of 0. */ @@ -5477,35 +5803,35 @@ TEBCresume( TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } else { - lResult = l1 / l2; + wResult = w1 / w2; /* * Force Tcl's integer division rules. * TODO: examine for logic simplification */ - if ((lResult < 0 || (lResult == 0 && - ((l1 < 0 && l2 > 0) || (l1 > 0 && l2 < 0)))) && - (lResult * l2 != l1)) { - lResult -= 1; + if ((wResult < 0 || (wResult == 0 && + ((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) && + (wResult * w2 != w1)) { + wResult -= 1; } - lResult = l1 - l2*lResult; - goto longResultOfArithmetic; + wResult = w1 - w2*wResult; + goto wideResultOfArithmetic; } case INST_RSHIFT: - if (l2 < 0) { + if (w2 < 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "negative shift argument", -1)); -#if 0 +#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "domain error: argument not in valid range", NULL); CACHE_STACK_INFO(); -#endif +#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ goto gotError; - } else if (l1 == 0) { + } else if (w1 == 0) { TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); objResultPtr = TCONST(0); TRACE(("%s\n", O2S(objResultPtr))); @@ -5515,7 +5841,7 @@ TEBCresume( * Quickly force large right shifts to 0 or -1. */ - if (l2 >= (long)(CHAR_BIT*sizeof(long))) { + if (w2 >= (Tcl_WideInt)(CHAR_BIT*sizeof(long))) { /* * We assume that INT_MAX is much larger than the * number of bits in a long. This is a pretty safe @@ -5524,7 +5850,7 @@ TEBCresume( */ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - if (l1 > 0L) { + if (w1 > 0L) { objResultPtr = TCONST(0); } else { TclNewIntObj(objResultPtr, -1); @@ -5537,28 +5863,28 @@ TEBCresume( * Handle shifts within the native long range. */ - lResult = l1 >> ((int) l2); - goto longResultOfArithmetic; + wResult = w1 >> ((int) w2); + goto wideResultOfArithmetic; } case INST_LSHIFT: - if (l2 < 0) { + if (w2 < 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "negative shift argument", -1)); -#if 0 +#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "domain error: argument not in valid range", NULL); CACHE_STACK_INFO(); -#endif +#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ goto gotError; - } else if (l1 == 0) { + } else if (w1 == 0) { TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); objResultPtr = TCONST(0); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); - } else if (l2 > (long) INT_MAX) { + } else if (w2 > INT_MAX) { /* * Technically, we could hold the value (1 << (INT_MAX+1)) * in an mp_int, but since we're using mp_mul_2d() to do @@ -5568,25 +5894,25 @@ TEBCresume( Tcl_SetObjResult(interp, Tcl_NewStringObj( "integer value too large to represent", -1)); -#if 0 +#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", "integer value too large to represent", NULL); CACHE_STACK_INFO(); -#endif +#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ goto gotError; } else { - int shift = (int) l2; + int shift = (int) w2; /* * Handle shifts within the native long range. */ - if ((size_t) shift < CHAR_BIT*sizeof(long) && (l1 != 0) - && !((l1>0 ? l1 : ~l1) & + if ((size_t) shift < CHAR_BIT*sizeof(long) && (w1 != 0) + && !((w1>0 ? w1 : ~w1) & -(1L<<(CHAR_BIT*sizeof(long) - 1 - shift)))) { - lResult = l1 << shift; - goto longResultOfArithmetic; + wResult = w1 << shift; + goto wideResultOfArithmetic; } } @@ -5598,23 +5924,14 @@ TEBCresume( break; case INST_BITAND: - lResult = l1 & l2; - goto longResultOfArithmetic; + wResult = w1 & w2; + goto wideResultOfArithmetic; case INST_BITOR: - lResult = l1 | l2; - goto longResultOfArithmetic; + wResult = w1 | w2; + goto wideResultOfArithmetic; case INST_BITXOR: - lResult = l1 ^ l2; - longResultOfArithmetic: - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - if (Tcl_IsShared(valuePtr)) { - TclNewLongObj(objResultPtr, lResult); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } - TclSetLongObj(valuePtr, lResult); - TRACE(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 0); + wResult = w1 ^ w2; + goto wideResultOfArithmetic; } } @@ -5631,8 +5948,7 @@ TEBCresume( TRACE_APPEND(("DIVIDE BY ZERO\n")); goto divideByZero; } else if (objResultPtr == GENERAL_ARITHMETIC_ERROR) { - TRACE_APPEND(("ERROR: %s\n", - TclGetString(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } else if (objResultPtr == NULL) { TRACE_APPEND(("%s\n", O2S(valuePtr))); @@ -5698,18 +6014,13 @@ TEBCresume( * an external function. */ - if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { - Tcl_WideInt w1, w2, wResult; - - l1 = *((const long *)ptr1); - l2 = *((const long *)ptr2); + if ((type1 == TCL_NUMBER_WIDE) && (type2 == TCL_NUMBER_WIDE)) { + w1 = *((const Tcl_WideInt *)ptr1); + w2 = *((const Tcl_WideInt *)ptr2); switch (*pc) { case INST_ADD: - w1 = (Tcl_WideInt) l1; - w2 = (Tcl_WideInt) l2; wResult = w1 + w2; -#ifdef TCL_WIDE_INT_IS_LONG /* * Check for overflow. */ @@ -5717,14 +6028,10 @@ TEBCresume( if (Overflowing(w1, w2, wResult)) { goto overflow; } -#endif goto wideResultOfArithmetic; case INST_SUB: - w1 = (Tcl_WideInt) l1; - w2 = (Tcl_WideInt) l2; wResult = w1 - w2; -#ifdef TCL_WIDE_INT_IS_LONG /* * Must check for overflow. The macro tests for overflows in * sums by looking at the sign bits. As we have a subtraction @@ -5738,7 +6045,6 @@ TEBCresume( if (Overflowing(w1, ~w2, wResult)) { goto overflow; } -#endif wideResultOfArithmetic: TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); if (Tcl_IsShared(valuePtr)) { @@ -5746,45 +6052,45 @@ TEBCresume( TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } - Tcl_SetWideIntObj(valuePtr, wResult); + TclSetIntObj(valuePtr, wResult); TRACE(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 0); case INST_DIV: - if (l2 == 0) { + if (w2 == 0) { TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr), O2S(value2Ptr))); goto divideByZero; - } else if ((l1 == LONG_MIN) && (l2 == -1)) { + } else if ((w1 == LLONG_MIN) && (w2 == -1)) { /* - * Can't represent (-LONG_MIN) as a long. + * Can't represent (-LLONG_MIN) as a Tcl_WideInt. */ goto overflow; } - lResult = l1 / l2; + wResult = w1 / w2; /* * Force Tcl's integer division rules. * TODO: examine for logic simplification */ - if (((lResult < 0) || ((lResult == 0) && - ((l1 < 0 && l2 > 0) || (l1 > 0 && l2 < 0)))) && - ((lResult * l2) != l1)) { - lResult -= 1; + if (((wResult < 0) || ((wResult == 0) && + ((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) && + ((wResult * w2) != w1)) { + wResult -= 1; } - goto longResultOfArithmetic; + goto wideResultOfArithmetic; case INST_MULT: - if (((sizeof(long) >= 2*sizeof(int)) - && (l1 <= INT_MAX) && (l1 >= INT_MIN) - && (l2 <= INT_MAX) && (l2 >= INT_MIN)) - || ((sizeof(long) >= 2*sizeof(short)) - && (l1 <= SHRT_MAX) && (l1 >= SHRT_MIN) - && (l2 <= SHRT_MAX) && (l2 >= SHRT_MIN))) { - lResult = l1 * l2; - goto longResultOfArithmetic; + if (((sizeof(Tcl_WideInt) >= 2*sizeof(int)) + && (w1 <= INT_MAX) && (w1 >= INT_MIN) + && (w2 <= INT_MAX) && (w2 >= INT_MIN)) + || ((sizeof(Tcl_WideInt) >= 2*sizeof(short)) + && (w1 <= SHRT_MAX) && (w1 >= SHRT_MIN) + && (w2 <= SHRT_MAX) && (w2 >= SHRT_MIN))) { + wResult = w1 * w2; + goto wideResultOfArithmetic; } } @@ -5804,8 +6110,7 @@ TEBCresume( TRACE_APPEND(("EXPONENT OF ZERO\n")); goto exponOfZero; } else if (objResultPtr == GENERAL_ARITHMETIC_ERROR) { - TRACE_APPEND(("ERROR: %s\n", - TclGetString(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } else if (objResultPtr == NULL) { TRACE_APPEND(("%s\n", O2S(valuePtr))); @@ -5823,7 +6128,7 @@ TEBCresume( /* TODO - check claim that taking address of b harms performance */ /* TODO - consider optimization search for constants */ if (TclGetBooleanFromObj(NULL, valuePtr, &b) != TCL_OK) { - TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", O2S(valuePtr), + TRACE(("\"%.20s\" => ERROR: illegal type %s\n", O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); @@ -5832,45 +6137,52 @@ TEBCresume( } /* TODO: Consider peephole opt. */ objResultPtr = TCONST(!b); + TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), objResultPtr); NEXT_INST_F(1, 1, 1); } case INST_BITNOT: valuePtr = OBJ_AT_TOS; + TRACE(("\"%.20s\" => ", O2S(valuePtr))); if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) || (type1==TCL_NUMBER_NAN) || (type1==TCL_NUMBER_DOUBLE)) { /* * ... ~$NonInteger => raise an error. */ - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), + TRACE_APPEND(("ERROR: illegal type %s\n", (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); CACHE_STACK_INFO(); goto gotError; } - if (type1 == TCL_NUMBER_LONG) { - l1 = *((const long *) ptr1); + if (type1 == TCL_NUMBER_WIDE) { + w1 = *((const Tcl_WideInt *) ptr1); if (Tcl_IsShared(valuePtr)) { - TclNewLongObj(objResultPtr, ~l1); + TclNewIntObj(objResultPtr, ~w1); + TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } - TclSetLongObj(valuePtr, ~l1); + TclSetIntObj(valuePtr, ~w1); + TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } objResultPtr = ExecuteExtendedUnaryMathOp(*pc, valuePtr); if (objResultPtr != NULL) { + TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } else { + TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } case INST_UMINUS: valuePtr = OBJ_AT_TOS; + TRACE(("\"%.20s\" => ", O2S(valuePtr))); if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) || IsErroringNaNType(type1)) { - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), + TRACE_APPEND(("ERROR: illegal type %s \n", (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); @@ -5880,23 +6192,28 @@ TEBCresume( switch (type1) { case TCL_NUMBER_NAN: /* -NaN => NaN */ + TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); - case TCL_NUMBER_LONG: - l1 = *((const long *) ptr1); - if (l1 != LONG_MIN) { + case TCL_NUMBER_WIDE: + w1 = *((const Tcl_WideInt *) ptr1); + if (w1 != LLONG_MIN) { if (Tcl_IsShared(valuePtr)) { - TclNewLongObj(objResultPtr, -l1); + TclNewIntObj(objResultPtr, -w1); + TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } - TclSetLongObj(valuePtr, -l1); + TclSetIntObj(valuePtr, -w1); + TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } /* FALLTHROUGH */ } objResultPtr = ExecuteExtendedUnaryMathOp(*pc, valuePtr); if (objResultPtr != NULL) { + TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } else { + TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } @@ -5909,6 +6226,7 @@ TEBCresume( */ valuePtr = OBJ_AT_TOS; + TRACE(("\"%.20s\" => ", O2S(valuePtr))); if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) { if (*pc == INST_UPLUS) { @@ -5916,7 +6234,7 @@ TEBCresume( * ... +$NonNumeric => raise an error. */ - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), + TRACE_APPEND(("ERROR: illegal type %s\n", (valuePtr->typePtr? valuePtr->typePtr->name:"null"))); DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); @@ -5925,7 +6243,7 @@ TEBCresume( } /* ... TryConvertToNumeric($NonNumeric) is acceptable */ - TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr))); + TRACE_APPEND(("not numeric\n")); NEXT_INST_F(1, 0, 0); } if (IsErroringNaNType(type1)) { @@ -5934,7 +6252,7 @@ TEBCresume( * ... +$NonNumeric => raise an error. */ - TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), + TRACE_APPEND(("ERROR: illegal type %s\n", (valuePtr->typePtr? valuePtr->typePtr->name:"null"))); DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); @@ -5944,8 +6262,7 @@ TEBCresume( * Numeric conversion of NaN -> error. */ - TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n", - O2S(objResultPtr))); + TRACE_APPEND(("ERROR: IEEE floating pt error\n")); DECACHE_STACK_INFO(); TclExprFloatError(interp, *((const double *) ptr1)); CACHE_STACK_INFO(); @@ -5963,7 +6280,7 @@ TEBCresume( */ if (valuePtr->bytes == NULL) { - TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr))); + TRACE_APPEND(("numeric, same Tcl_Obj\n")); NEXT_INST_F(1, 0, 0); } if (Tcl_IsShared(valuePtr)) { @@ -5978,11 +6295,11 @@ TEBCresume( valuePtr->bytes = NULL; objResultPtr = Tcl_DuplicateObj(valuePtr); valuePtr->bytes = savedString; - TRACE(("\"%.20s\" => numeric, new Tcl_Obj\n", O2S(valuePtr))); + TRACE_APPEND(("numeric, new Tcl_Obj\n")); NEXT_INST_F(1, 1, 1); } TclInvalidateStringRep(valuePtr); - TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr))); + TRACE_APPEND(("numeric, same Tcl_Obj\n")); NEXT_INST_F(1, 0, 0); } @@ -5991,6 +6308,17 @@ TEBCresume( * ----------------------------------------------------------------- */ + case INST_TRY_CVT_TO_BOOLEAN: + valuePtr = OBJ_AT_TOS; + if (valuePtr->typePtr == &tclBooleanType) { + objResultPtr = TCONST(1); + } else { + int result = (TclSetBooleanFromAny(NULL, valuePtr) == TCL_OK); + objResultPtr = TCONST(result); + } + TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(valuePtr)), objResultPtr); + NEXT_INST_F(1, 0, 1); + case INST_BREAK: /* DECACHE_STACK_INFO(); @@ -5999,6 +6327,7 @@ TEBCresume( */ result = TCL_BREAK; cleanup = 0; + TRACE(("=> BREAK!\n")); goto processExceptionReturn; case INST_CONTINUE: @@ -6009,6 +6338,7 @@ TEBCresume( */ result = TCL_CONTINUE; cleanup = 0; + TRACE(("=> CONTINUE!\n")); goto processExceptionReturn; { @@ -6016,11 +6346,12 @@ TEBCresume( Var *iterVarPtr, *listVarPtr; Tcl_Obj *oldValuePtr, *listPtr, **elements; ForeachVarList *varListPtr; - int numLists, iterNum, listTmpIndex, listLen, numVars; + int numLists, listTmpIndex, listLen, numVars; + size_t iterNum; int varIndex, valIndex, continueLoop, j, iterTmpIndex; long i; - case INST_FOREACH_START4: + case INST_FOREACH_START4: /* DEPRECATED */ /* * Initialize the temporary local var that holds the count of the * number of iterations of the loop body to -1. @@ -6033,10 +6364,10 @@ TEBCresume( oldValuePtr = iterVarPtr->value.objPtr; if (oldValuePtr == NULL) { - TclNewLongObj(iterVarPtr->value.objPtr, -1); + TclNewIntObj(iterVarPtr->value.objPtr, -1); Tcl_IncrRefCount(iterVarPtr->value.objPtr); } else { - TclSetLongObj(oldValuePtr, -1); + TclSetIntObj(oldValuePtr, -1); } TRACE(("%u => loop iter count temp %d\n", opnd, iterTmpIndex)); @@ -6053,13 +6384,14 @@ TEBCresume( NEXT_INST_F(5, 0, 0); #endif - case INST_FOREACH_STEP4: + case INST_FOREACH_STEP4: /* DEPRECATED */ /* * "Step" a foreach loop (i.e., begin its next iteration) by assigning * the next value list element to each loop var. */ opnd = TclGetUInt4AtPtr(pc+1); + TRACE(("%u => ", opnd)); infoPtr = codePtr->auxDataArrayPtr[opnd].clientData; numLists = infoPtr->numLists; @@ -6069,8 +6401,8 @@ TEBCresume( iterVarPtr = LOCAL(infoPtr->loopCtTemp); valuePtr = iterVarPtr->value.objPtr; - iterNum = valuePtr->internalRep.longValue + 1; - TclSetLongObj(valuePtr, iterNum); + iterNum = (size_t)valuePtr->internalRep.wideValue + 1; + TclSetIntObj(valuePtr, iterNum); /* * Check whether all value lists are exhausted and we should stop the @@ -6086,11 +6418,11 @@ TEBCresume( listVarPtr = LOCAL(listTmpIndex); listPtr = listVarPtr->value.objPtr; if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) { - TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ", - opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp)); + TRACE_APPEND(("ERROR converting list %ld, \"%.30s\": %s\n", + i, O2S(listPtr), O2S(Tcl_GetObjResult(interp)))); goto gotError; } - if (listLen > iterNum * numVars) { + if ((size_t)listLen > iterNum * numVars) { continueLoop = 1; } listTmpIndex++; @@ -6139,12 +6471,12 @@ TEBCresume( } } else { DECACHE_STACK_INFO(); - if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, + if (TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL, valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){ CACHE_STACK_INFO(); - TRACE_WITH_OBJ(( - "%u => ERROR init. index temp %d: ", - opnd,varIndex), Tcl_GetObjResult(interp)); + TRACE_APPEND(( + "ERROR init. index temp %d: %s\n", + varIndex, O2S(Tcl_GetObjResult(interp)))); TclDecrRefCount(listPtr); goto gotError; } @@ -6156,8 +6488,8 @@ TEBCresume( listTmpIndex++; } } - TRACE(("%u => %d lists, iter %d, %s loop\n", opnd, numLists, - iterNum, (continueLoop? "continue" : "exit"))); + TRACE_APPEND(("%d lists, iter %" TCL_Z_MODIFIER "d, %s loop\n", + numLists, iterNum, (continueLoop? "continue" : "exit"))); /* * Run-time peep-hole optimisation: the compiler ALWAYS follows @@ -6171,6 +6503,201 @@ TEBCresume( } else { NEXT_INST_F((continueLoop? 5 : TclGetInt4AtPtr(pc+1)), 0, 0); } + + } + { + ForeachInfo *infoPtr; + Tcl_Obj *listPtr, **elements, *tmpPtr; + ForeachVarList *varListPtr; + int numLists, listLen, numVars; + int listTmpDepth; + size_t iterNum, iterMax, iterTmp; + int varIndex, valIndex, j; + long i; + + case INST_FOREACH_START: + /* + * Initialize the data for the looping construct, pushing the + * corresponding Tcl_Objs to the stack. + */ + + opnd = TclGetUInt4AtPtr(pc+1); + infoPtr = codePtr->auxDataArrayPtr[opnd].clientData; + numLists = infoPtr->numLists; + TRACE(("%u => ", opnd)); + + /* + * Compute the number of iterations that will be run: iterMax + */ + + iterMax = 0; + listTmpDepth = numLists-1; + for (i = 0; i < numLists; i++) { + varListPtr = infoPtr->varLists[i]; + numVars = varListPtr->numVars; + listPtr = OBJ_AT_DEPTH(listTmpDepth); + if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) { + TRACE_APPEND(("ERROR converting list %ld, \"%s\": %s", + i, O2S(listPtr), O2S(Tcl_GetObjResult(interp)))); + goto gotError; + } + if (Tcl_IsShared(listPtr)) { + objPtr = TclListObjCopy(NULL, listPtr); + Tcl_IncrRefCount(objPtr); + Tcl_DecrRefCount(listPtr); + OBJ_AT_DEPTH(listTmpDepth) = objPtr; + } + iterTmp = (listLen + (numVars - 1))/numVars; + if (iterTmp > iterMax) { + iterMax = iterTmp; + } + listTmpDepth--; + } + + /* + * Store the iterNum and iterMax in a single Tcl_Obj; we keep a + * nul-string obj with the pointer stored in the ptrValue so that the + * thing is properly garbage collected. THIS OBJ MAKES NO SENSE, but + * it will never leave this scope and is read-only. + */ + + TclNewObj(tmpPtr); + tmpPtr->internalRep.twoPtrValue.ptr1 = NULL; + tmpPtr->internalRep.twoPtrValue.ptr2 = (void *)iterMax; + PUSH_OBJECT(tmpPtr); /* iterCounts object */ + + /* + * Store a pointer to the ForeachInfo struct; same dirty trick + * as above + */ + + TclNewObj(tmpPtr); + tmpPtr->internalRep.twoPtrValue.ptr1 = infoPtr; + PUSH_OBJECT(tmpPtr); /* infoPtr object */ + TRACE_APPEND(("jump to loop step\n")); + + /* + * Jump directly to the INST_FOREACH_STEP instruction; the C code just + * falls through. + */ + + pc += 5 - infoPtr->loopCtTemp; + + case INST_FOREACH_STEP: + /* + * "Step" a foreach loop (i.e., begin its next iteration) by assigning + * the next value list element to each loop var. + */ + + tmpPtr = OBJ_AT_TOS; + infoPtr = tmpPtr->internalRep.twoPtrValue.ptr1; + numLists = infoPtr->numLists; + TRACE(("=> ")); + + tmpPtr = OBJ_AT_DEPTH(1); + iterNum = (size_t)tmpPtr->internalRep.twoPtrValue.ptr1; + iterMax = (size_t)tmpPtr->internalRep.twoPtrValue.ptr2; + + /* + * If some list still has a remaining list element iterate one more + * time. Assign to var the next element from its value list. + */ + + if (iterNum < iterMax) { + /* + * Set the variables and jump back to run the body + */ + + tmpPtr->internalRep.twoPtrValue.ptr1 =(void *)(iterNum + 1); + + listTmpDepth = numLists + 1; + + for (i = 0; i < numLists; i++) { + varListPtr = infoPtr->varLists[i]; + numVars = varListPtr->numVars; + + listPtr = OBJ_AT_DEPTH(listTmpDepth); + TclListObjGetElements(interp, listPtr, &listLen, &elements); + + valIndex = (iterNum * numVars); + for (j = 0; j < numVars; j++) { + if (valIndex >= listLen) { + TclNewObj(valuePtr); + } else { + valuePtr = elements[valIndex]; + } + + varIndex = varListPtr->varIndexes[j]; + varPtr = LOCAL(varIndex); + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + if (TclIsVarDirectWritable(varPtr)) { + value2Ptr = varPtr->value.objPtr; + if (valuePtr != value2Ptr) { + if (value2Ptr != NULL) { + TclDecrRefCount(value2Ptr); + } + varPtr->value.objPtr = valuePtr; + Tcl_IncrRefCount(valuePtr); + } + } else { + DECACHE_STACK_INFO(); + if (TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL, + valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){ + CACHE_STACK_INFO(); + TRACE_APPEND(("ERROR init. index temp %d: %.30s", + varIndex, O2S(Tcl_GetObjResult(interp)))); + goto gotError; + } + CACHE_STACK_INFO(); + } + valIndex++; + } + listTmpDepth--; + } + TRACE_APPEND(("jump to loop start\n")); + /* loopCtTemp being 'misused' for storing the jump size */ + NEXT_INST_F(infoPtr->loopCtTemp, 0, 0); + } + + TRACE_APPEND(("loop has no more iterations\n")); +#ifdef TCL_COMPILE_DEBUG + NEXT_INST_F(1, 0, 0); +#else + /* + * FALL THROUGH + */ + pc++; +#endif + + case INST_FOREACH_END: + /* THIS INSTRUCTION IS ONLY CALLED AS A BREAK TARGET */ + tmpPtr = OBJ_AT_TOS; + infoPtr = tmpPtr->internalRep.twoPtrValue.ptr1; + numLists = infoPtr->numLists; + TRACE(("=> loop terminated\n")); + NEXT_INST_V(1, numLists+2, 0); + + case INST_LMAP_COLLECT: + /* + * This instruction is only issued by lmap. The stack is: + * - result + * - infoPtr + * - loop counters + * - valLists + * - collecting obj (unshared) + * The instruction lappends the result to the collecting obj. + */ + + tmpPtr = OBJ_AT_DEPTH(1); + infoPtr = tmpPtr->internalRep.twoPtrValue.ptr1; + numLists = infoPtr->numLists; + TRACE_APPEND(("=> appending to list at depth %d\n", 3 + numLists)); + + objPtr = OBJ_AT_DEPTH(3 + numLists); + Tcl_ListObjAppendElement(NULL, objPtr, OBJ_AT_TOS); + NEXT_INST_F(1, 1, 0); } case INST_BEGIN_CATCH4: @@ -6232,7 +6759,8 @@ TEBCresume( if (code < TCL_ERROR || code > TCL_CONTINUE) { code = TCL_CONTINUE + 1; } - NEXT_INST_F(2*code -1, 1, 0); + TRACE(("\"%s\" => jump offset %d\n", O2S(OBJ_AT_TOS), 2*code-1)); + NEXT_INST_F(2*code-1, 1, 0); } /* @@ -6249,10 +6777,10 @@ TEBCresume( case INST_DICT_VERIFY: dictPtr = OBJ_AT_TOS; - TRACE(("=> ")); + TRACE(("\"%.30s\" => ", O2S(dictPtr))); if (Tcl_DictObjSize(interp, dictPtr, &done) != TCL_OK) { - TRACE_APPEND(("ERROR verifying dictionary nature of \"%s\": %s\n", - O2S(OBJ_AT_DEPTH(opnd)), O2S(Tcl_GetObjResult(interp)))); + TRACE_APPEND(("ERROR verifying dictionary nature of \"%.30s\": %s\n", + O2S(dictPtr), O2S(Tcl_GetObjResult(interp)))); goto gotError; } TRACE_APPEND(("OK\n")); @@ -6261,6 +6789,7 @@ TEBCresume( case INST_DICT_GET: case INST_DICT_EXISTS: { register Tcl_Interp *interp2 = interp; + register int found; opnd = TclGetUInt4AtPtr(pc+1); TRACE(("%u => ", opnd)); @@ -6273,10 +6802,11 @@ TEBCresume( &OBJ_AT_DEPTH(opnd-1), DICT_PATH_READ); if (dictPtr == NULL) { if (*pc == INST_DICT_EXISTS) { - goto dictNotExists; + found = 0; + goto afterDictExists; } TRACE_WITH_OBJ(( - "ERROR tracing dictionary path into \"%s\": ", + "ERROR tracing dictionary path into \"%.30s\": ", O2S(OBJ_AT_DEPTH(opnd))), Tcl_GetObjResult(interp)); goto gotError; @@ -6285,34 +6815,40 @@ TEBCresume( if (Tcl_DictObjGet(interp2, dictPtr, OBJ_AT_TOS, &objResultPtr) == TCL_OK) { if (*pc == INST_DICT_EXISTS) { - objResultPtr = TCONST(objResultPtr ? 1 : 0); - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd+1, 1); + found = (objResultPtr ? 1 : 0); + goto afterDictExists; } - if (objResultPtr) { - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd+1, 1); + if (!objResultPtr) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "key \"%s\" not known in dictionary", + TclGetString(OBJ_AT_TOS))); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", + TclGetString(OBJ_AT_TOS), NULL); + CACHE_STACK_INFO(); + TRACE_ERROR(interp); + goto gotError; } - DECACHE_STACK_INFO(); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "key \"%s\" not known in dictionary", - TclGetString(OBJ_AT_TOS))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", - TclGetString(OBJ_AT_TOS), NULL); - CACHE_STACK_INFO(); - TRACE_WITH_OBJ(("%u => ERROR ", opnd), Tcl_GetObjResult(interp)); + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(5, opnd+1, 1); + } else if (*pc != INST_DICT_EXISTS) { + TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s", + O2S(dictPtr), O2S(Tcl_GetObjResult(interp)))); + goto gotError; } else { - if (*pc == INST_DICT_EXISTS) { - dictNotExists: - objResultPtr = TCONST(0); - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd+1, 1); - } - TRACE_WITH_OBJ(( - "%u => ERROR reading leaf dictionary key \"%s\": ", - opnd, O2S(dictPtr)), Tcl_GetObjResult(interp)); + found = 0; } - goto gotError; + afterDictExists: + TRACE_APPEND(("%d\n", found)); + + /* + * The INST_DICT_EXISTS instruction is usually followed by a + * conditional jump, so we can take advantage of this to do some + * peephole optimization (note that we're careful to not close out + * someone doing something else). + */ + + JUMP_PEEPHOLE_V(found, 5, opnd+1); } case INST_DICT_SET: @@ -6330,7 +6866,8 @@ TEBCresume( dictPtr = varPtr->value.objPtr; } else { DECACHE_STACK_INFO(); - dictPtr = TclPtrGetVar(interp, varPtr, NULL,NULL,NULL, 0, opnd2); + dictPtr = TclPtrGetVarIdx(interp, varPtr, NULL, NULL, NULL, 0, + opnd2); CACHE_STACK_INFO(); } if (dictPtr == NULL) { @@ -6386,8 +6923,8 @@ TEBCresume( if (allocateDict) { TclDecrRefCount(dictPtr); } - TRACE_WITH_OBJ(("%u %u => ERROR updating dictionary: ", - opnd, opnd2), Tcl_GetObjResult(interp)); + TRACE_APPEND(("ERROR updating dictionary: %s\n", + O2S(Tcl_GetObjResult(interp)))); goto checkForCatch; } @@ -6404,13 +6941,12 @@ TEBCresume( } else { Tcl_IncrRefCount(dictPtr); DECACHE_STACK_INFO(); - objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, + objResultPtr = TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL, dictPtr, TCL_LEAVE_ERR_MSG, opnd2); CACHE_STACK_INFO(); TclDecrRefCount(dictPtr); if (objResultPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } } @@ -6419,7 +6955,7 @@ TEBCresume( NEXT_INST_V(10, cleanup, 0); } #endif - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_V(9, cleanup, 1); case INST_DICT_APPEND: @@ -6434,7 +6970,8 @@ TEBCresume( dictPtr = varPtr->value.objPtr; } else { DECACHE_STACK_INFO(); - dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd); + dictPtr = TclPtrGetVarIdx(interp, varPtr, NULL, NULL, NULL, 0, + opnd); CACHE_STACK_INFO(); } if (dictPtr == NULL) { @@ -6452,6 +6989,7 @@ TEBCresume( if (allocateDict) { TclDecrRefCount(dictPtr); } + TRACE_ERROR(interp); goto gotError; } @@ -6500,6 +7038,7 @@ TEBCresume( if (allocateDict) { TclDecrRefCount(dictPtr); } + TRACE_ERROR(interp); goto gotError; } Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, valuePtr); @@ -6509,6 +7048,7 @@ TEBCresume( if (allocateDict) { TclDecrRefCount(dictPtr); } + TRACE_ERROR(interp); goto gotError; } @@ -6540,13 +7080,12 @@ TEBCresume( } else { Tcl_IncrRefCount(dictPtr); DECACHE_STACK_INFO(); - objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, + objResultPtr = TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL, dictPtr, TCL_LEAVE_ERR_MSG, opnd); CACHE_STACK_INFO(); TclDecrRefCount(dictPtr); if (objResultPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } } @@ -6565,7 +7104,16 @@ TEBCresume( searchPtr = ckalloc(sizeof(Tcl_DictSearch)); if (Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr, &valuePtr, &done) != TCL_OK) { + + /* + * dictPtr is no longer on the stack, and we're not + * moving it into the intrep of an iterator. We need + * to drop the refcount [Tcl Bug 9b352768e6]. + */ + + Tcl_DecrRefCount(dictPtr); ckfree(searchPtr); + TRACE_ERROR(interp); goto gotError; } TclNewObj(statePtr); @@ -6601,8 +7149,9 @@ TEBCresume( PUSH_OBJECT(valuePtr); PUSH_OBJECT(keyPtr); } + TRACE_APPEND(("\"%.30s\" \"%.30s\" %d\n", + O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), done)); -#ifndef TCL_COMPILE_DEBUG /* * The INST_DICT_FIRST and INST_DICT_NEXT instructsions are always * followed by a conditional jump, so we can take advantage of this to @@ -6610,50 +7159,33 @@ TEBCresume( * out someone doing something else). */ - pc += 5; - switch (*pc) { - case INST_JUMP_FALSE1: - NEXT_INST_F((done ? 2 : TclGetInt1AtPtr(pc+1)), 0, 0); - case INST_JUMP_FALSE4: - NEXT_INST_F((done ? 5 : TclGetInt4AtPtr(pc+1)), 0, 0); - case INST_JUMP_TRUE1: - NEXT_INST_F((done ? TclGetInt1AtPtr(pc+1) : 2), 0, 0); - case INST_JUMP_TRUE4: - NEXT_INST_F((done ? TclGetInt4AtPtr(pc+1) : 5), 0, 0); - default: - pc -= 5; - /* fall through to non-debug handling */ - } -#endif - - TRACE_APPEND(("\"%.30s\" \"%.30s\" %d\n", - O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), done)); - objResultPtr = TCONST(done); - /* TODO: consider opt like INST_FOREACH_STEP4 */ - NEXT_INST_F(5, 0, 1); + JUMP_PEEPHOLE_F(done, 5, 0); case INST_DICT_UPDATE_START: opnd = TclGetUInt4AtPtr(pc+1); opnd2 = TclGetUInt4AtPtr(pc+5); + TRACE(("%u => ", opnd)); varPtr = LOCAL(opnd); duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData; while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } - TRACE(("%u => \n", opnd)); if (TclIsVarDirectReadable(varPtr)) { dictPtr = varPtr->value.objPtr; } else { DECACHE_STACK_INFO(); - dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, + dictPtr = TclPtrGetVarIdx(interp, varPtr, NULL, NULL, NULL, TCL_LEAVE_ERR_MSG, opnd); CACHE_STACK_INFO(); if (dictPtr == NULL) { + TRACE_ERROR(interp); goto gotError; } } + Tcl_IncrRefCount(dictPtr); if (TclListObjGetElements(interp, OBJ_AT_TOS, &length, &keyPtrPtr) != TCL_OK) { + TRACE_ERROR(interp); goto gotError; } if (length != duiPtr->length) { @@ -6662,6 +7194,8 @@ TEBCresume( for (i=0 ; i<length ; i++) { if (Tcl_DictObjGet(interp, dictPtr, keyPtrPtr[i], &valuePtr) != TCL_OK) { + TRACE_ERROR(interp); + Tcl_DecrRefCount(dictPtr); goto gotError; } varPtr = LOCAL(duiPtr->varIndices[i]); @@ -6673,38 +7207,45 @@ TEBCresume( TclObjUnsetVar2(interp, localName(iPtr->varFramePtr, duiPtr->varIndices[i]), NULL, 0); - } else if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, + } else if (TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL, valuePtr, TCL_LEAVE_ERR_MSG, duiPtr->varIndices[i]) == NULL) { CACHE_STACK_INFO(); + TRACE_ERROR(interp); + Tcl_DecrRefCount(dictPtr); goto gotError; } CACHE_STACK_INFO(); } + TclDecrRefCount(dictPtr); + TRACE_APPEND(("OK\n")); NEXT_INST_F(9, 0, 0); case INST_DICT_UPDATE_END: opnd = TclGetUInt4AtPtr(pc+1); opnd2 = TclGetUInt4AtPtr(pc+5); + TRACE(("%u => ", opnd)); varPtr = LOCAL(opnd); duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData; while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } - TRACE(("%u => ", opnd)); if (TclIsVarDirectReadable(varPtr)) { dictPtr = varPtr->value.objPtr; } else { DECACHE_STACK_INFO(); - dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd); + dictPtr = TclPtrGetVarIdx(interp, varPtr, NULL, NULL, NULL, 0, + opnd); CACHE_STACK_INFO(); } if (dictPtr == NULL) { + TRACE_APPEND(("storage was unset\n")); NEXT_INST_F(9, 1, 0); } if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK || TclListObjGetElements(interp, OBJ_AT_TOS, &length, &keyPtrPtr) != TCL_OK) { + TRACE_ERROR(interp); goto gotError; } allocdict = Tcl_IsShared(dictPtr); @@ -6724,8 +7265,8 @@ TEBCresume( valuePtr = var2Ptr->value.objPtr; } else { DECACHE_STACK_INFO(); - valuePtr = TclPtrGetVar(interp, var2Ptr, NULL, NULL, NULL, 0, - duiPtr->varIndices[i]); + valuePtr = TclPtrGetVarIdx(interp, var2Ptr, NULL, NULL, NULL, + 0, duiPtr->varIndices[i]); CACHE_STACK_INFO(); } if (valuePtr == NULL) { @@ -6743,34 +7284,34 @@ TEBCresume( varPtr->value.objPtr = dictPtr; } else { DECACHE_STACK_INFO(); - objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, + objResultPtr = TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL, dictPtr, TCL_LEAVE_ERR_MSG, opnd); CACHE_STACK_INFO(); if (objResultPtr == NULL) { if (allocdict) { TclDecrRefCount(dictPtr); } + TRACE_ERROR(interp); goto gotError; } } + TRACE_APPEND(("written back\n")); NEXT_INST_F(9, 1, 0); case INST_DICT_EXPAND: dictPtr = OBJ_UNDER_TOS; listPtr = OBJ_AT_TOS; + TRACE(("\"%.30s\" \"%.30s\" =>", O2S(dictPtr), O2S(listPtr))); if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { - TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", - O2S(dictPtr), O2S(listPtr)), Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } objResultPtr = TclDictWithInit(interp, dictPtr, objc, objv); if (objResultPtr == NULL) { - TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", - O2S(dictPtr), O2S(listPtr)), Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } - TRACE((" => ")); - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); case INST_DICT_RECOMBINE_STK: @@ -6780,14 +7321,14 @@ TEBCresume( TRACE(("\"%.30s\" \"%.30s\" \"%.30s\" => ", O2S(varNamePtr), O2S(valuePtr), O2S(keysPtr))); if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); TclDecrRefCount(keysPtr); goto gotError; } varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL, TCL_LEAVE_ERR_MSG, "set", 1, 1, &arrayPtr); if (varPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); TclDecrRefCount(keysPtr); goto gotError; } @@ -6797,7 +7338,7 @@ TEBCresume( CACHE_STACK_INFO(); TclDecrRefCount(keysPtr); if (result != TCL_OK) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } TRACE_APPEND(("OK\n")); @@ -6811,7 +7352,7 @@ TEBCresume( TRACE(("%u <- \"%.30s\" \"%.30s\" => ", opnd, O2S(valuePtr), O2S(keysPtr))); if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } while (TclIsVarLink(varPtr)) { @@ -6822,7 +7363,7 @@ TEBCresume( objc, objv, keysPtr); CACHE_STACK_INFO(); if (result != TCL_OK) { - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } TRACE_APPEND(("OK\n")); @@ -6834,6 +7375,38 @@ TEBCresume( * ----------------------------------------------------------------- */ + case INST_CLOCK_READ: + { /* Read the wall clock */ + Tcl_WideInt wval; + Tcl_Time now; + switch(TclGetUInt1AtPtr(pc+1)) { + case 0: /* clicks */ +#ifdef TCL_WIDE_CLICKS + wval = TclpGetWideClicks(); +#else + wval = (Tcl_WideInt) TclpGetClicks(); +#endif + break; + case 1: /* microseconds */ + Tcl_GetTime(&now); + wval = (Tcl_WideInt) now.sec * 1000000 + now.usec; + break; + case 2: /* milliseconds */ + Tcl_GetTime(&now); + wval = (Tcl_WideInt) now.sec * 1000 + now.usec / 1000; + break; + case 3: /* seconds */ + Tcl_GetTime(&now); + wval = (Tcl_WideInt) now.sec; + break; + default: + Tcl_Panic("clockRead instruction with unknown clock#"); + } + objResultPtr = Tcl_NewWideIntObj(wval); + TRACE_WITH_OBJ(("=> "), objResultPtr); + NEXT_INST_F(2, 0, 1); + } + default: Tcl_Panic("TclNRExecuteByteCode: unrecognized opCode %u", *pc); } /* end of switch on opCode */ @@ -6880,7 +7453,7 @@ TEBCresume( } #endif if ((result == TCL_CONTINUE) || (result == TCL_BREAK)) { - rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr); + rangePtr = GetExceptRangeForPc(pc, result, codePtr); if (rangePtr == NULL) { TRACE_APPEND(("no encl. loop or catch, returning %s\n", StringForResultCode(result))); @@ -6918,10 +7491,10 @@ TEBCresume( if (traceInstructions) { objPtr = Tcl_GetObjResult(interp); if ((result != TCL_ERROR) && (result != TCL_RETURN)) { - TRACE_APPEND(("OTHER RETURN CODE %d, result= \"%s\"\n ", + TRACE_APPEND(("OTHER RETURN CODE %d, result=\"%.30s\"\n ", result, O2S(objPtr))); } else { - TRACE_APPEND(("%s, result= \"%s\"\n", + TRACE_APPEND(("%s, result=\"%.30s\"\n", StringForResultCode(result), O2S(objPtr))); } } @@ -6934,8 +7507,8 @@ TEBCresume( */ divideByZero: - DECACHE_STACK_INFO(); Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1)); + DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL); CACHE_STACK_INFO(); goto gotError; @@ -6946,9 +7519,9 @@ TEBCresume( */ exponOfZero: - DECACHE_STACK_INFO(); Tcl_SetObjResult(interp, Tcl_NewStringObj( "exponentiation of zero by negative power", -1)); + DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "exponentiation of zero by negative power", NULL); CACHE_STACK_INFO(); @@ -6992,7 +7565,7 @@ TEBCresume( while (auxObjList) { if ((catchTop != initCatchTop) && (*catchTop > (ptrdiff_t) - auxObjList->internalRep.ptrAndLongRep.value)) { + auxObjList->internalRep.twoPtrValue.ptr2)) { break; } POP_TAUX_OBJ(); @@ -7041,7 +7614,7 @@ TEBCresume( #endif goto abnormalReturn; } - rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 1, codePtr); + rangePtr = GetExceptRangeForPc(pc, TCL_ERROR, codePtr); if (rangePtr == NULL) { /* * This is only possible when compiling a [catch] that sends its @@ -7122,9 +7695,7 @@ TEBCresume( } iPtr->cmdFramePtr = bcFramePtr->nextPtr; - if (--codePtr->refCount <= 0) { - TclCleanupByteCode(codePtr); - } + TclReleaseByteCode(codePtr); TclStackFree(interp, TD); /* free my stack */ return result; @@ -7161,6 +7732,7 @@ TEBCresume( bytes = GetSrcInfoForPc(pc, codePtr, &length, NULL, NULL); opnd = TclGetUInt4AtPtr(pc+1); pc += (opnd-1); + assert(bytes); PUSH_OBJECT(Tcl_NewStringObj(bytes, length)); goto instEvalStk; } @@ -7174,6 +7746,59 @@ TEBCresume( #undef auxObjList #undef catchTop #undef TCONST +#undef esPtr + +static int +FinalizeOONext( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + CallContext *contextPtr = data[1]; + + /* + * Reset the variable lookup frame. + */ + + iPtr->varFramePtr = data[0]; + + /* + * Restore the call chain context index as we've finished the inner invoke + * and want to operate in the outer context again. + */ + + contextPtr->index = PTR2INT(data[2]); + contextPtr->skip = PTR2INT(data[3]); + contextPtr->oPtr->flags &= ~FILTER_HANDLING; + return result; +} + +static int +FinalizeOONextFilter( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + CallContext *contextPtr = data[1]; + + /* + * Reset the variable lookup frame. + */ + + iPtr->varFramePtr = data[0]; + + /* + * Restore the call chain context index as we've finished the inner invoke + * and want to operate in the outer context again. + */ + + contextPtr->index = PTR2INT(data[2]); + contextPtr->skip = PTR2INT(data[3]); + contextPtr->oPtr->flags |= FILTER_HANDLING; + return result; +} /* *---------------------------------------------------------------------- @@ -7208,19 +7833,11 @@ ExecuteExtendedBinaryMathOp( Tcl_Obj *valuePtr, /* The first operand on the stack. */ Tcl_Obj *value2Ptr) /* The second operand on the stack. */ { -#define LONG_RESULT(l) \ - if (Tcl_IsShared(valuePtr)) { \ - TclNewLongObj(objResultPtr, l); \ - return objResultPtr; \ - } else { \ - Tcl_SetLongObj(valuePtr, l); \ - return NULL; \ - } #define WIDE_RESULT(w) \ if (Tcl_IsShared(valuePtr)) { \ return Tcl_NewWideIntObj(w); \ } else { \ - Tcl_SetWideIntObj(valuePtr, w); \ + TclSetIntObj(valuePtr, w); \ return NULL; \ } #define BIG_RESULT(b) \ @@ -7242,7 +7859,6 @@ ExecuteExtendedBinaryMathOp( int type1, type2; ClientData ptr1, ptr2; double d1, d2, dResult; - long l1, l2, lResult; Tcl_WideInt w1, w2, wResult; mp_int big1, big2, bigResult, bigRemainder; Tcl_Obj *objResultPtr; @@ -7256,13 +7872,13 @@ ExecuteExtendedBinaryMathOp( case INST_MOD: /* TODO: Attempts to re-use unshared operands on stack */ - l2 = 0; /* silence gcc warning */ - if (type2 == TCL_NUMBER_LONG) { - l2 = *((const long *)ptr2); - if (l2 == 0) { + w2 = 0; /* silence gcc warning */ + if (type2 == TCL_NUMBER_WIDE) { + w2 = *((const Tcl_WideInt *)ptr2); + if (w2 == 0) { return DIVIDED_BY_ZERO; } - if ((l2 == 1) || (l2 == -1)) { + if ((w2 == 1) || (w2 == -1)) { /* * Div. by |1| always yields remainder of 0. */ @@ -7270,9 +7886,16 @@ ExecuteExtendedBinaryMathOp( return constants[0]; } } -#ifndef TCL_WIDE_INT_IS_LONG if (type1 == TCL_NUMBER_WIDE) { w1 = *((const Tcl_WideInt *)ptr1); + + if (w1 == 0) { + /* + * 0 % (non-zero) always yields remainder of 0. + */ + + return constants[0]; + } if (type2 != TCL_NUMBER_BIG) { Tcl_WideInt wQuotient, wRemainder; Tcl_GetWideIntFromObj(NULL, value2Ptr, &w2); @@ -7302,7 +7925,7 @@ ExecuteExtendedBinaryMathOp( * Arguments are opposite sign; remainder is sum. */ - TclBNInitBignumFromWideInt(&big1, w1); + TclInitBignumFromWideInt(&big1, w1); mp_add(&big2, &big1, &big2); mp_clear(&big1); BIG_RESULT(&big2); @@ -7315,7 +7938,6 @@ ExecuteExtendedBinaryMathOp( mp_clear(&big2); return NULL; } -#endif Tcl_GetBignumFromObj(NULL, valuePtr, &big1); Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); mp_init(&bigResult); @@ -7342,17 +7964,12 @@ ExecuteExtendedBinaryMathOp( */ switch (type2) { - case TCL_NUMBER_LONG: - invalid = (*((const long *)ptr2) < 0L); - break; -#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: invalid = (*((const Tcl_WideInt *)ptr2) < (Tcl_WideInt)0); break; -#endif case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - invalid = (mp_cmp_d(&big2, 0) == MP_LT); + invalid = mp_isneg(&big2); mp_clear(&big2); break; default: @@ -7369,7 +7986,7 @@ ExecuteExtendedBinaryMathOp( * Zero shifted any number of bits is still zero. */ - if ((type1==TCL_NUMBER_LONG) && (*((const long *)ptr1) == (long)0)) { + if ((type1==TCL_NUMBER_WIDE) && (*((const Tcl_WideInt *)ptr1) == (Tcl_WideInt)0)) { return constants[0]; } @@ -7382,8 +7999,8 @@ ExecuteExtendedBinaryMathOp( * counterparts, leading to incorrect results. */ - if ((type2 != TCL_NUMBER_LONG) - || (*((const long *)ptr2) > (long) INT_MAX)) { + if ((type2 != TCL_NUMBER_WIDE) + || (*((const Tcl_WideInt *)ptr2) > INT_MAX)) { /* * Technically, we could hold the value (1 << (INT_MAX+1)) in * an mp_int, but since we're using mp_mul_2d() to do the @@ -7395,7 +8012,7 @@ ExecuteExtendedBinaryMathOp( "integer value too large to represent", -1)); return GENERAL_ARITHMETIC_ERROR; } - shift = (int)(*((const long *)ptr2)); + shift = (int)(*((const Tcl_WideInt *)ptr2)); /* * Handle shifts within the native wide range. @@ -7415,8 +8032,8 @@ ExecuteExtendedBinaryMathOp( * Quickly force large right shifts to 0 or -1. */ - if ((type2 != TCL_NUMBER_LONG) - || (*(const long *)ptr2 > INT_MAX)) { + if ((type2 != TCL_NUMBER_WIDE) + || (*(const Tcl_WideInt *)ptr2 > INT_MAX)) { /* * Again, technically, the value to be shifted could be an * mp_int so huge that a right shift by (INT_MAX+1) bits could @@ -7426,17 +8043,12 @@ ExecuteExtendedBinaryMathOp( */ switch (type1) { - case TCL_NUMBER_LONG: - zero = (*(const long *)ptr1 > 0L); - break; -#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: zero = (*(const Tcl_WideInt *)ptr1 > (Tcl_WideInt)0); break; -#endif case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); - zero = (mp_cmp_d(&big1, 0) == MP_GT); + zero = (!mp_isneg(&big1)); mp_clear(&big1); break; default: @@ -7446,11 +8058,10 @@ ExecuteExtendedBinaryMathOp( if (zero) { return constants[0]; } - LONG_RESULT(-1); + WIDE_RESULT(-1); } - shift = (int)(*(const long *)ptr2); + shift = (int)(*(const Tcl_WideInt *)ptr2); -#ifndef TCL_WIDE_INT_IS_LONG /* * Handle shifts within the native wide range. */ @@ -7461,11 +8072,10 @@ ExecuteExtendedBinaryMathOp( if (w1 >= (Tcl_WideInt)0) { return constants[0]; } - LONG_RESULT(-1); + WIDE_RESULT(-1); } WIDE_RESULT(w1 >> shift); } -#endif } Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); @@ -7476,7 +8086,7 @@ ExecuteExtendedBinaryMathOp( } else { mp_init(&bigRemainder); mp_div_2d(&big1, shift, &bigResult, &bigRemainder); - if (mp_cmp_d(&bigRemainder, 0) == MP_LT) { + if (mp_isneg(&bigRemainder)) { /* * Convert to Tcl's integer division rules. */ @@ -7503,14 +8113,14 @@ ExecuteExtendedBinaryMathOp( * arguments is negative, store it in 'Second'. */ - if (mp_cmp_d(&big1, 0) != MP_LT) { - numPos = 1 + (mp_cmp_d(&big2, 0) != MP_LT); + if (!mp_isneg(&big1)) { + numPos = 1 + !mp_isneg(&big2); First = &big1; Second = &big2; } else { First = &big2; Second = &big1; - numPos = (mp_cmp_d(First, 0) != MP_LT); + numPos = (!mp_isneg(First)); } mp_init(&bigResult); @@ -7633,7 +8243,6 @@ ExecuteExtendedBinaryMathOp( BIG_RESULT(&bigResult); } -#ifndef TCL_WIDE_INT_IS_LONG if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) { TclGetWideIntFromObj(NULL, valuePtr, &w1); TclGetWideIntFromObj(NULL, value2Ptr, &w2); @@ -7654,25 +8263,24 @@ ExecuteExtendedBinaryMathOp( } WIDE_RESULT(wResult); } -#endif - l1 = *((const long *)ptr1); - l2 = *((const long *)ptr2); + w1 = *((const Tcl_WideInt *)ptr1); + w2 = *((const Tcl_WideInt *)ptr2); switch (opcode) { case INST_BITAND: - lResult = l1 & l2; + wResult = w1 & w2; break; case INST_BITOR: - lResult = l1 | l2; + wResult = w1 | w2; break; case INST_BITXOR: - lResult = l1 ^ l2; + wResult = w1 ^ w2; break; default: /* Unused, here to silence compiler warning. */ - lResult = 0; + wResult = 0; } - LONG_RESULT(lResult); + WIDE_RESULT(wResult); case INST_EXPON: { int oddExponent = 0, negativeExponent = 0; @@ -7688,16 +8296,16 @@ ExecuteExtendedBinaryMathOp( dResult = pow(d1, d2); goto doubleResult; } - l1 = l2 = 0; - if (type2 == TCL_NUMBER_LONG) { - l2 = *((const long *) ptr2); - if (l2 == 0) { + w2 = 0; + if (type2 == TCL_NUMBER_WIDE) { + w2 = *((const Tcl_WideInt *) ptr2); + if (w2 == 0) { /* * Anything to the zero power is 1. */ return constants[1]; - } else if (l2 == 1) { + } else if (w2 == 1) { /* * Anything to the first power is itself */ @@ -7707,32 +8315,26 @@ ExecuteExtendedBinaryMathOp( } switch (type2) { - case TCL_NUMBER_LONG: - negativeExponent = (l2 < 0); - oddExponent = (int) (l2 & 1); - break; -#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: w2 = *((const Tcl_WideInt *)ptr2); negativeExponent = (w2 < 0); oddExponent = (int) (w2 & (Tcl_WideInt)1); break; -#endif case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - negativeExponent = (mp_cmp_d(&big2, 0) == MP_LT); + negativeExponent = mp_isneg(&big2); mp_mod_2d(&big2, 1, &big2); oddExponent = !mp_iszero(&big2); mp_clear(&big2); break; } - if (type1 == TCL_NUMBER_LONG) { - l1 = *((const long *)ptr1); + if (type1 == TCL_NUMBER_WIDE) { + w1 = *((const Tcl_WideInt *)ptr1); } if (negativeExponent) { - if (type1 == TCL_NUMBER_LONG) { - switch (l1) { + if (type1 == TCL_NUMBER_WIDE) { + switch (w1) { case 0: /* * Zero to a negative power is div by zero error. @@ -7741,7 +8343,7 @@ ExecuteExtendedBinaryMathOp( return EXPONENT_OF_ZERO; case -1: if (oddExponent) { - LONG_RESULT(-1); + WIDE_RESULT(-1); } /* fallthrough */ case 1: @@ -7761,8 +8363,8 @@ ExecuteExtendedBinaryMathOp( return constants[0]; } - if (type1 == TCL_NUMBER_LONG) { - switch (l1) { + if (type1 == TCL_NUMBER_WIDE) { + switch (w1) { case 0: /* * Zero to a positive power is zero. @@ -7779,7 +8381,7 @@ ExecuteExtendedBinaryMathOp( if (!oddExponent) { return constants[1]; } - LONG_RESULT(-1); + WIDE_RESULT(-1); } } @@ -7788,141 +8390,58 @@ ExecuteExtendedBinaryMathOp( * which means the max exponent value is 2**28-1 = 0x0fffffff = * 268435455, which fits into a signed 32 bit int which is within the * range of the long int type. This means any numeric Tcl_Obj value - * not using TCL_NUMBER_LONG type must hold a value larger than we + * not using TCL_NUMBER_WIDE type must hold a value larger than we * accept. */ - if (type2 != TCL_NUMBER_LONG) { + if (type2 != TCL_NUMBER_WIDE) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "exponent too large", -1)); return GENERAL_ARITHMETIC_ERROR; } - if (type1 == TCL_NUMBER_LONG) { - if (l1 == 2) { + if (type1 == TCL_NUMBER_WIDE) { + if (w1 == 2) { /* * Reduce small powers of 2 to shifts. */ - if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) { - LONG_RESULT(1L << l2); - } -#if !defined(TCL_WIDE_INT_IS_LONG) - if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1) { - WIDE_RESULT(((Tcl_WideInt) 1) << l2); + if ((Tcl_WideUInt) w2 < (Tcl_WideUInt) CHAR_BIT*sizeof(Tcl_WideInt) - 1) { + WIDE_RESULT(((Tcl_WideInt) 1) << (int)w2); } -#endif goto overflowExpon; } - if (l1 == -2) { + if (w1 == -2) { int signum = oddExponent ? -1 : 1; /* * Reduce small powers of 2 to shifts. */ - if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) { - LONG_RESULT(signum * (1L << l2)); - } -#if !defined(TCL_WIDE_INT_IS_LONG) - if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){ - WIDE_RESULT(signum * (((Tcl_WideInt) 1) << l2)); + if ((Tcl_WideUInt)w2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){ + WIDE_RESULT(signum * (((Tcl_WideInt) 1) << (int) w2)); } -#endif goto overflowExpon; } -#if (LONG_MAX == 0x7fffffff) - if (l2 - 2 < (long)MaxBase32Size - && l1 <= MaxBase32[l2 - 2] - && l1 >= -MaxBase32[l2 - 2]) { - /* - * Small powers of 32-bit integers. - */ - - lResult = l1 * l1; /* b**2 */ - switch (l2) { - case 2: - break; - case 3: - lResult *= l1; /* b**3 */ - break; - case 4: - lResult *= lResult; /* b**4 */ - break; - case 5: - lResult *= lResult; /* b**4 */ - lResult *= l1; /* b**5 */ - break; - case 6: - lResult *= l1; /* b**3 */ - lResult *= lResult; /* b**6 */ - break; - case 7: - lResult *= l1; /* b**3 */ - lResult *= lResult; /* b**6 */ - lResult *= l1; /* b**7 */ - break; - case 8: - lResult *= lResult; /* b**4 */ - lResult *= lResult; /* b**8 */ - break; - } - LONG_RESULT(lResult); - } - - if (l1 - 3 >= 0 && l1 -2 < (long)Exp32IndexSize - && l2 - 2 < (long)(Exp32ValueSize + MaxBase32Size)) { - base = Exp32Index[l1 - 3] - + (unsigned short) (l2 - 2 - MaxBase32Size); - if (base < Exp32Index[l1 - 2]) { - /* - * 32-bit number raised to intermediate power, done by - * table lookup. - */ - - LONG_RESULT(Exp32Value[base]); - } - } - if (-l1 - 3 >= 0 && -l1 - 2 < (long)Exp32IndexSize - && l2 - 2 < (long)(Exp32ValueSize + MaxBase32Size)) { - base = Exp32Index[-l1 - 3] - + (unsigned short) (l2 - 2 - MaxBase32Size); - if (base < Exp32Index[-l1 - 2]) { - /* - * 32-bit number raised to intermediate power, done by - * table lookup. - */ - - lResult = (oddExponent) ? - -Exp32Value[base] : Exp32Value[base]; - LONG_RESULT(lResult); - } - } -#endif } -#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) - if (type1 == TCL_NUMBER_LONG) { - w1 = l1; -#ifndef TCL_WIDE_INT_IS_LONG - } else if (type1 == TCL_NUMBER_WIDE) { + if (type1 == TCL_NUMBER_WIDE) { w1 = *((const Tcl_WideInt *) ptr1); -#endif } else { goto overflowExpon; } - if (l2 - 2 < (long)MaxBase64Size - && w1 <= MaxBase64[l2 - 2] - && w1 >= -MaxBase64[l2 - 2]) { + if (w2 - 2 < (long)MaxBase64Size + && w1 <= MaxBase64[w2 - 2] + && w1 >= -MaxBase64[w2 - 2]) { /* * Small powers of integers whose result is wide. */ wResult = w1 * w1; /* b**2 */ - switch (l2) { + switch (w2) { case 2: break; case 3: - wResult *= l1; /* b**3 */ + wResult *= w1; /* b**3 */ break; case 4: wResult *= wResult; /* b**4 */ @@ -7999,9 +8518,9 @@ ExecuteExtendedBinaryMathOp( */ if (w1 - 3 >= 0 && w1 - 2 < (long)Exp64IndexSize - && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { + && w2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { base = Exp64Index[w1 - 3] - + (unsigned short) (l2 - 2 - MaxBase64Size); + + (unsigned short) (w2 - 2 - MaxBase64Size); if (base < Exp64Index[w1 - 2]) { /* * 64-bit number raised to intermediate power, done by @@ -8013,9 +8532,9 @@ ExecuteExtendedBinaryMathOp( } if (-w1 - 3 >= 0 && -w1 - 2 < (long)Exp64IndexSize - && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { + && w2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { base = Exp64Index[-w1 - 3] - + (unsigned short) (l2 - 2 - MaxBase64Size); + + (unsigned short) (w2 - 2 - MaxBase64Size); if (base < Exp64Index[-w1 - 2]) { /* * 64-bit number raised to intermediate power, done by @@ -8026,7 +8545,6 @@ ExecuteExtendedBinaryMathOp( WIDE_RESULT(wResult); } } -#endif overflowExpon: Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); @@ -8038,7 +8556,7 @@ ExecuteExtendedBinaryMathOp( } Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); mp_init(&bigResult); - mp_expt_d(&big1, big2.dp[0], &bigResult); + mp_expt_d_ex(&big1, big2.dp[0], &bigResult, 1); mp_clear(&big1); mp_clear(&big2); BIG_RESULT(&bigResult); @@ -8106,9 +8624,7 @@ ExecuteExtendedBinaryMathOp( switch (opcode) { case INST_ADD: wResult = w1 + w2; -#ifndef TCL_WIDE_INT_IS_LONG if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) -#endif { /* * Check for overflow. @@ -8122,9 +8638,7 @@ ExecuteExtendedBinaryMathOp( case INST_SUB: wResult = w1 - w2; -#ifndef TCL_WIDE_INT_IS_LONG if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) -#endif { /* * Must check for overflow. The macro tests for overflows @@ -8144,8 +8658,7 @@ ExecuteExtendedBinaryMathOp( break; case INST_MULT: - if ((type1 != TCL_NUMBER_LONG) || (type2 != TCL_NUMBER_LONG) - || (sizeof(Tcl_WideInt) < 2*sizeof(long))) { + if ((w1 < INT_MIN) || (w1 > INT_MAX) || (w2 < INT_MIN) || (w2 > INT_MAX)) { goto overflowBasic; } wResult = w1 * w2; @@ -8248,12 +8761,10 @@ ExecuteExtendedUnaryMathOp( switch (opcode) { case INST_BITNOT: -#ifndef TCL_WIDE_INT_IS_LONG if (type == TCL_NUMBER_WIDE) { w = *((const Tcl_WideInt *) ptr); WIDE_RESULT(~w); } -#endif Tcl_TakeBignumFromObj(NULL, valuePtr, &big); /* ~a = - a - 1 */ mp_neg(&big, &big); @@ -8263,22 +8774,13 @@ ExecuteExtendedUnaryMathOp( switch (type) { case TCL_NUMBER_DOUBLE: DOUBLE_RESULT(-(*((const double *) ptr))); - case TCL_NUMBER_LONG: - w = (Tcl_WideInt) (*((const long *) ptr)); - if (w != LLONG_MIN) { - WIDE_RESULT(-w); - } - TclBNInitBignumFromLong(&big, *(const long *) ptr); - break; -#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: w = *((const Tcl_WideInt *) ptr); if (w != LLONG_MIN) { WIDE_RESULT(-w); } - TclBNInitBignumFromWideInt(&big, w); + TclInitBignumFromWideInt(&big, w); break; -#endif default: Tcl_TakeBignumFromObj(NULL, valuePtr, &big); } @@ -8289,7 +8791,6 @@ ExecuteExtendedUnaryMathOp( Tcl_Panic("unexpected opcode"); return NULL; } -#undef LONG_RESULT #undef WIDE_RESULT #undef BIG_RESULT #undef DOUBLE_RESULT @@ -8317,35 +8818,26 @@ TclCompareTwoNumbers( Tcl_Obj *valuePtr, Tcl_Obj *value2Ptr) { - int type1, type2, compare; + int type1 = TCL_NUMBER_NAN, type2 = TCL_NUMBER_NAN, compare; ClientData ptr1, ptr2; mp_int big1, big2; double d1, d2, tmp; - long l1, l2; -#ifndef TCL_WIDE_INT_IS_LONG Tcl_WideInt w1, w2; -#endif (void) GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); (void) GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); switch (type1) { - case TCL_NUMBER_LONG: - l1 = *((const long *)ptr1); + case TCL_NUMBER_WIDE: + w1 = *((const Tcl_WideInt *)ptr1); switch (type2) { - case TCL_NUMBER_LONG: - l2 = *((const long *)ptr2); - longCompare: - return (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ); -#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: w2 = *((const Tcl_WideInt *)ptr2); - w1 = (Tcl_WideInt)l1; - goto wideCompare; -#endif + wideCompare: + return (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ); case TCL_NUMBER_DOUBLE: d2 = *((const double *)ptr2); - d1 = (double) l1; + d1 = (double) w1; /* * If the double has a fractional part, or if the long can be @@ -8353,7 +8845,7 @@ TclCompareTwoNumbers( * doubles. */ - if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) || l1 == (long) d1 + if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) || w1 == (Tcl_WideInt) d1 || modf(d2, &tmp) != 0.0) { goto doubleCompare; } @@ -8370,44 +8862,6 @@ TclCompareTwoNumbers( * integer comparison can tell the difference. */ - if (d2 < (double)LONG_MIN) { - return MP_GT; - } - if (d2 > (double)LONG_MAX) { - return MP_LT; - } - l2 = (long) d2; - goto longCompare; - case TCL_NUMBER_BIG: - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - if (mp_cmp_d(&big2, 0) == MP_LT) { - compare = MP_GT; - } else { - compare = MP_LT; - } - mp_clear(&big2); - return compare; - } - -#ifndef TCL_WIDE_INT_IS_LONG - case TCL_NUMBER_WIDE: - w1 = *((const Tcl_WideInt *)ptr1); - switch (type2) { - case TCL_NUMBER_WIDE: - w2 = *((const Tcl_WideInt *)ptr2); - wideCompare: - return (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ); - case TCL_NUMBER_LONG: - l2 = *((const long *)ptr2); - w2 = (Tcl_WideInt)l2; - goto wideCompare; - case TCL_NUMBER_DOUBLE: - d2 = *((const double *)ptr2); - d1 = (double) w1; - if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) - || w1 == (Tcl_WideInt) d1 || modf(d2, &tmp) != 0.0) { - goto doubleCompare; - } if (d2 < (double)LLONG_MIN) { return MP_GT; } @@ -8418,7 +8872,7 @@ TclCompareTwoNumbers( goto wideCompare; case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - if (mp_cmp_d(&big2, 0) == MP_LT) { + if (mp_isneg(&big2)) { compare = MP_GT; } else { compare = MP_LT; @@ -8426,7 +8880,6 @@ TclCompareTwoNumbers( mp_clear(&big2); return compare; } -#endif case TCL_NUMBER_DOUBLE: d1 = *((const double *)ptr1); @@ -8435,22 +8888,6 @@ TclCompareTwoNumbers( d2 = *((const double *)ptr2); doubleCompare: return (d1 < d2) ? MP_LT : ((d1 > d2) ? MP_GT : MP_EQ); - case TCL_NUMBER_LONG: - l2 = *((const long *)ptr2); - d2 = (double) l2; - if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) || l2 == (long) d2 - || modf(d1, &tmp) != 0.0) { - goto doubleCompare; - } - if (d1 < (double)LONG_MIN) { - return MP_LT; - } - if (d1 > (double)LONG_MAX) { - return MP_GT; - } - l1 = (long) d1; - goto longCompare; -#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: w2 = *((const Tcl_WideInt *)ptr2); d2 = (double) w2; @@ -8466,14 +8903,13 @@ TclCompareTwoNumbers( } w1 = (Tcl_WideInt) d1; goto wideCompare; -#endif case TCL_NUMBER_BIG: if (TclIsInfinite(d1)) { return (d1 > 0.0) ? MP_GT : MP_LT; } Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - if ((d1 < (double)LONG_MAX) && (d1 > (double)LONG_MIN)) { - if (mp_cmp_d(&big2, 0) == MP_LT) { + if ((d1 < (double)LLONG_MAX) && (d1 > (double)LLONG_MIN)) { + if (mp_isneg(&big2)) { compare = MP_GT; } else { compare = MP_LT; @@ -8494,10 +8930,7 @@ TclCompareTwoNumbers( case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); switch (type2) { -#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: -#endif - case TCL_NUMBER_LONG: compare = mp_cmp_d(&big1, 0); mp_clear(&big1); return compare; @@ -8508,7 +8941,7 @@ TclCompareTwoNumbers( mp_clear(&big1); return compare; } - if ((d2 < (double)LONG_MAX) && (d2 > (double)LONG_MIN)) { + if ((d2 < (double)LLONG_MAX) && (d2 > (double)LLONG_MIN)) { compare = mp_cmp_d(&big1, 0); mp_clear(&big1); return compare; @@ -8562,8 +8995,8 @@ PrintByteCodeInfo( Proc *procPtr = codePtr->procPtr; Interp *iPtr = (Interp *) *codePtr->interpHandle; - fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %u, epoch %u, interp 0x%p (epoch %u)\n", - codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr, + fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %" TCL_Z_MODIFIER "u, epoch %u, interp 0x%p (epoch %u)\n", + codePtr, (size_t)codePtr->refCount, codePtr->compileEpoch, iPtr, iPtr->compileEpoch); fprintf(stdout, " Source: "); @@ -8648,7 +9081,7 @@ ValidatePcAndStackTop( (unsigned) opCode, relativePc); Tcl_Panic("TclNRExecuteByteCode execution failure: bad opcode"); } - if (checkStack && + if (checkStack && ((stackTop < 0) || (stackTop > stackUpperBound))) { int numChars; const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL, NULL); @@ -8661,7 +9094,7 @@ ValidatePcAndStackTop( TclNewLiteralStringObj(message, "\n executing "); Tcl_IncrRefCount(message); Tcl_AppendLimitedToObj(message, cmd, numChars, 100, NULL); - fprintf(stderr,"%s\n", Tcl_GetString(message)); + fprintf(stderr,"%s\n", TclGetString(message)); Tcl_DecrRefCount(message); } else { fprintf(stderr, "\n"); @@ -8701,15 +9134,17 @@ IllegalExprOperandType( ClientData ptr; int type; const unsigned char opcode = *pc; - const char *description, *operator = operatorStrings[opcode - INST_LOR]; + const char *description, *operator = "unknown"; if (opcode == INST_EXPON) { operator = "**"; + } else if (opcode <= INST_LNOT) { + operator = operatorStrings[opcode - INST_LOR]; } if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) { int numBytes; - const char *bytes = Tcl_GetStringFromObj(opndPtr, &numBytes); + const char *bytes = TclGetStringFromObj(opndPtr, &numBytes); if (numBytes == 0) { description = "empty string"; @@ -8735,7 +9170,7 @@ IllegalExprOperandType( /* *---------------------------------------------------------------------- * - * TclGetSrcInfoForPc, GetSrcInfoForPc, TclGetSrcInfoForCmd -- + * TclGetSrcInfoForPc, GetSrcInfoForPc, TclGetSourceFromFrame -- * * Given a program counter value, finds the closest command in the * bytecode code unit's CmdLocation array and returns information about @@ -8756,16 +9191,30 @@ IllegalExprOperandType( *---------------------------------------------------------------------- */ -const char * -TclGetSrcInfoForCmd( - Interp *iPtr, - int *lenPtr) +Tcl_Obj * +TclGetSourceFromFrame( + CmdFrame *cfPtr, + int objc, + Tcl_Obj *const objv[]) { - CmdFrame *cfPtr = iPtr->cmdFramePtr; - ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr; - - return GetSrcInfoForPc((unsigned char *) cfPtr->data.tebc.pc, - codePtr, lenPtr, NULL, NULL); + if (cfPtr == NULL) { + return Tcl_NewListObj(objc, objv); + } + if (cfPtr->cmdObj == NULL) { + if (cfPtr->cmd == NULL) { + ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr; + + cfPtr->cmd = GetSrcInfoForPc((unsigned char *) + cfPtr->data.tebc.pc, codePtr, &cfPtr->len, NULL, NULL); + } + if (cfPtr->cmd) { + cfPtr->cmdObj = Tcl_NewStringObj(cfPtr->cmd, cfPtr->len); + } else { + cfPtr->cmdObj = Tcl_NewListObj(objc, objv); + } + Tcl_IncrRefCount(cfPtr->cmdObj); + } + return cfPtr->cmdObj; } void @@ -8775,14 +9224,15 @@ TclGetSrcInfoForPc( ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr; assert(cfPtr->type == TCL_LOCATION_BC); - assert(cfPtr->cmd == NULL); + + if (cfPtr->cmd == NULL) { cfPtr->cmd = GetSrcInfoForPc( (unsigned char *) cfPtr->data.tebc.pc, codePtr, &cfPtr->len, NULL, NULL); + } - assert(cfPtr->cmd != NULL); - { + if (cfPtr->cmd != NULL) { /* * We now have the command. We can get the srcOffset back and from * there find the list of word locations for this command. @@ -8843,7 +9293,7 @@ GetSrcInfoForPc( * where the current instruction starts. * If NULL; no pointer is stored. */ int *cmdIdxPtr) /* If non-NULL, the location where the index - * of the command containing the pc should + * of the command containing the pc should * be stored. */ { register int pcOffset = (pc - codePtr->codeStart); @@ -8856,10 +9306,8 @@ GetSrcInfoForPc( int bestSrcLength = -1; /* Initialized to avoid compiler warning. */ int bestCmdIdx = -1; - if ((pcOffset < 0) || (pcOffset >= codePtr->numCodeBytes)) { - if (pcBeg != NULL) *pcBeg = NULL; - return NULL; - } + /* The pc must point within the bytecode */ + assert ((pcOffset >= 0) && (pcOffset < codePtr->numCodeBytes)); /* * Decode the code and source offset and length for each command. The @@ -8968,13 +9416,14 @@ GetSrcInfoForPc( * ExceptionRange. * * Results: - * In the normal case, catchOnly is 0 (false) and this procedure returns - * a pointer to the most closely enclosing ExceptionRange structure - * regardless of whether it is a loop or catch exception range. This is - * appropriate when processing a TCL_BREAK or TCL_CONTINUE, which will be - * "handled" either by a loop exception range or a closer catch range. If - * catchOnly is nonzero, this procedure ignores loop exception ranges and - * returns a pointer to the closest catch range. If no matching + * If the searchMode is TCL_ERROR, this procedure ignores loop exception + * ranges and returns a pointer to the closest catch range. If the + * searchMode is TCL_BREAK, this procedure returns a pointer to the most + * closely enclosing ExceptionRange regardless of whether it is a loop or + * catch exception range. If the searchMode is TCL_CONTINUE, this + * procedure returns a pointer to the most closely enclosing + * ExceptionRange (of any type) skipping only loop exception ranges if + * they don't have a sensible continueOffset defined. If no matching * ExceptionRange is found that encloses pc, a NULL is returned. * * Side effects: @@ -8985,14 +9434,16 @@ GetSrcInfoForPc( static ExceptionRange * GetExceptRangeForPc( - const unsigned char *pc, /* The program counter value for which to + const unsigned char *pc, /* The program counter value for which to * search for a closest enclosing exception * range. This points to a bytecode * instruction in codePtr's code. */ - int catchOnly, /* If 0, consider either loop or catch - * ExceptionRanges in search. If nonzero + int searchMode, /* If TCL_BREAK, consider either loop or catch + * ExceptionRanges in search. If TCL_ERROR * consider only catch ranges (and ignore any - * closer loop ranges). */ + * closer loop ranges). If TCL_CONTINUE, look + * for loop ranges that define a continue + * point or a catch range. */ ByteCode *codePtr) /* Points to the ByteCode in which to search * for the enclosing ExceptionRange. */ { @@ -9018,8 +9469,13 @@ GetExceptRangeForPc( start = rangePtr->codeOffset; if ((start <= pcOffset) && (pcOffset < (start + rangePtr->numCodeBytes))) { - if ((!catchOnly) - || (rangePtr->type == CATCH_EXCEPTION_RANGE)) { + if (rangePtr->type == CATCH_EXCEPTION_RANGE) { + return rangePtr; + } + if (searchMode == TCL_BREAK) { + return rangePtr; + } + if (searchMode == TCL_CONTINUE && rangePtr->continueOffset != -1){ return rangePtr; } } @@ -9101,7 +9557,7 @@ TclExprFloatError( "unknown floating-point error, errno = %d", errno); Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", - Tcl_GetString(objPtr), NULL); + TclGetString(objPtr), NULL); Tcl_SetObjResult(interp, objPtr); } } @@ -9317,7 +9773,7 @@ EvalStatsCmd( if (entryPtr->objPtr->typePtr == &tclByteCodeType) { numByteCodeLits++; } - (void) Tcl_GetStringFromObj(entryPtr->objPtr, &length); + (void) TclGetStringFromObj(entryPtr->objPtr, &length); refCountSum += entryPtr->refCount; objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj)); strBytesIfUnshared += (entryPtr->refCount * (length+1)); @@ -9539,7 +9995,7 @@ EvalStatsCmd( Tcl_SetObjResult(interp, objPtr); } else { Tcl_Channel outChan; - char *str = Tcl_GetStringFromObj(objv[1], &length); + char *str = TclGetStringFromObj(objv[1], &length); if (length) { if (strcmp(str, "stdout") == 0) { diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 13377d3..ea2a1c5 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -120,7 +120,7 @@ FileCopyRename( } i++; if ((objc - i) < 2) { - Tcl_WrongNumArgs(interp, 1, objv, + Tcl_WrongNumArgs(interp, 1, objv, "?-option value ...? source ?source ...? target"); return TCL_ERROR; } @@ -240,9 +240,13 @@ TclFileMakeDirsCmd( break; } for (j = 0; j < pobjc; j++) { + int errCount = 2; + target = Tcl_FSJoinPath(split, j + 1); Tcl_IncrRefCount(target); + createDir: + /* * Call Tcl_FSStat() so that if target is a symlink that points to * a directory we will create subdirectories in that directory. @@ -269,23 +273,25 @@ TclFileMakeDirsCmd( * subdirectory. */ - if (errno != EEXIST) { - errfile = target; - goto done; - } else if ((Tcl_FSStat(target, &statBuf) == 0) - && S_ISDIR(statBuf.st_mode)) { - /* - * It is a directory that wasn't there before, so keep - * going without error. - */ - - Tcl_ResetResult(interp); - } else { - errfile = target; - goto done; + if (errno == EEXIST) { + /* Be aware other workers could delete it immediately after + * creation, so give this worker still one chance (repeat once), + * see [270f78ca95] for description of the race-condition. + * Don't repeat the create always (to avoid endless loop). */ + if (--errCount > 0) { + goto createDir; + } + /* Already tried, with delete in-between directly after + * creation, so just continue (assume created successful). */ + goto nextPart; } + + /* return with error */ + errfile = target; + goto done; } + nextPart: /* * Forget about this sub-path. */ @@ -363,14 +369,7 @@ TclFileDeleteCmd( */ 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 - */ - - if (errno != ENOENT) { - result = TCL_ERROR; - } + result = TCL_ERROR; } else if (S_ISDIR(statBuf.st_mode)) { /* * We own a reference count on errorBuffer, if it was set as a @@ -406,13 +405,20 @@ TclFileDeleteCmd( } if (result != TCL_OK) { - result = TCL_ERROR; /* + * Avoid possible race condition (file/directory deleted after call + * of lstat), so bypass ENOENT because not an error, just a no-op + */ + if (errno == ENOENT) { + result = TCL_OK; + continue; + } + /* * It is important that we break on error, otherwise we might end * up owning reference counts on numerous errorBuffers. */ - + result = TCL_ERROR; break; } } @@ -517,7 +523,7 @@ CopyRenameOneFile( * 16 bits and we get collisions. See bug #2015723. */ -#if !defined(WIN32) && !defined(__CYGWIN__) +#if !defined(_WIN32) && !defined(__CYGWIN__) if ((sourceStatBuf.st_ino != 0) && (targetStatBuf.st_ino != 0)) { if ((sourceStatBuf.st_ino == targetStatBuf.st_ino) && (sourceStatBuf.st_dev == targetStatBuf.st_dev)) { @@ -735,7 +741,7 @@ CopyRenameOneFile( errfile = target; } - /* + /* * We now need to reset the result, because the above call, * may have left set it. (Ideally we would prefer not to pass * an interpreter in above, but the channel IO code used by @@ -1079,12 +1085,9 @@ TclFileAttrsCmd( } if (Tcl_GetIndexFromObj(interp, objv[0], attributeStrings, - "option", 0, &index) != TCL_OK) { + "option", INDEX_TEMP_TABLE, &index) != TCL_OK) { goto end; } - if (attributeStringsAllocated != NULL) { - TclFreeIntRep(objv[0]); - } if (Tcl_FSFileAttrsGet(interp, index, filePtr, &objPtr) != TCL_OK) { goto end; @@ -1107,12 +1110,9 @@ TclFileAttrsCmd( for (i = 0; i < objc ; i += 2) { if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings, - "option", 0, &index) != TCL_OK) { + "option", INDEX_TEMP_TABLE, &index) != TCL_OK) { goto end; } - if (attributeStringsAllocated != NULL) { - TclFreeIntRep(objv[i]); - } if (i + 1 == objc) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "value for \"%s\" missing", TclGetString(objv[i]))); @@ -1196,7 +1196,7 @@ TclFileLinkCmd( static const char *const linkTypes[] = { "-symbolic", "-hard", NULL }; - if (Tcl_GetIndexFromObj(interp, objv[1], linkTypes, "switch", 0, + if (Tcl_GetIndexFromObj(interp, objv[1], linkTypes, "option", 0, &linkAction) != TCL_OK) { return TCL_ERROR; } diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 5d4702b..15fcde7 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -235,9 +235,9 @@ ExtractWinRoot( if ((path[0] == 'c' || path[0] == 'C') && (path[1] == 'o' || path[1] == 'O')) { if ((path[2] == 'm' || path[2] == 'M') - && path[3] >= '1' && path[3] <= '4') { + && path[3] >= '1' && path[3] <= '9') { /* - * May have match for 'com[1-4]:?', which is a serial port. + * May have match for 'com[1-9]:?', which is a serial port. */ if (path[4] == '\0') { @@ -257,9 +257,9 @@ ExtractWinRoot( } else if ((path[0] == 'l' || path[0] == 'L') && (path[1] == 'p' || path[1] == 'P') && (path[2] == 't' || path[2] == 'T')) { - if (path[3] >= '1' && path[3] <= '3') { + if (path[3] >= '1' && path[3] <= '9') { /* - * May have match for 'lpt[1-3]:?' + * May have match for 'lpt[1-9]:?' */ if (path[4] == '\0') { @@ -387,7 +387,7 @@ TclpGetNativePathType( { Tcl_PathType type = TCL_PATH_ABSOLUTE; int pathLen; - const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen); + const char *path = TclGetStringFromObj(pathPtr, &pathLen); if (path[0] == '~') { /* @@ -578,7 +578,7 @@ Tcl_SplitPath( size = 1; for (i = 0; i < *argcPtr; i++) { Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr); - Tcl_GetStringFromObj(eltPtr, &len); + TclGetStringFromObj(eltPtr, &len); size += len + 1; } @@ -597,7 +597,7 @@ Tcl_SplitPath( p = (char *) &(*argvPtr)[(*argcPtr) + 1]; for (i = 0; i < *argcPtr; i++) { Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr); - str = Tcl_GetStringFromObj(eltPtr, &len); + str = TclGetStringFromObj(eltPtr, &len); memcpy(p, str, (size_t) len+1); p += len+1; } @@ -821,10 +821,10 @@ Tcl_FSJoinToPath( return TclJoinPath(2, pair); } else { int elemc = objc + 1; - Tcl_Obj *ret, **elemv = ckalloc(elemc*sizeof(Tcl_Obj **)); + Tcl_Obj *ret, **elemv = ckalloc(elemc*sizeof(Tcl_Obj *)); elemv[0] = pathPtr; - memcpy(elemv+1, objv, objc*sizeof(Tcl_Obj **)); + memcpy(elemv+1, objv, objc*sizeof(Tcl_Obj *)); ret = TclJoinPath(elemc, elemv); ckfree(elemv); return ret; @@ -857,7 +857,7 @@ TclpNativeJoinPath( const char *p; const char *start; - start = Tcl_GetStringFromObj(prefix, &length); + start = TclGetStringFromObj(prefix, &length); /* * Remove the ./ from tilde prefixed elements, and drive-letter prefixed @@ -885,7 +885,7 @@ TclpNativeJoinPath( if (length > 0 && (start[length-1] != '/')) { Tcl_AppendToObj(prefix, "/", 1); - Tcl_GetStringFromObj(prefix, &length); + TclGetStringFromObj(prefix, &length); } needsSep = 0; @@ -921,7 +921,7 @@ TclpNativeJoinPath( if ((length > 0) && (start[length-1] != '/') && (start[length-1] != ':')) { Tcl_AppendToObj(prefix, "/", 1); - Tcl_GetStringFromObj(prefix, &length); + TclGetStringFromObj(prefix, &length); } needsSep = 0; @@ -1003,7 +1003,7 @@ Tcl_JoinPath( * Store the result. */ - resultStr = Tcl_GetStringFromObj(resultObj, &len); + resultStr = TclGetStringFromObj(resultObj, &len); Tcl_DStringAppend(resultPtr, resultStr, len); Tcl_DecrRefCount(resultObj); @@ -1249,7 +1249,7 @@ Tcl_GlobObjCmd( for (i = 1; i < objc; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) != TCL_OK) { - string = Tcl_GetStringFromObj(objv[i], &length); + string = TclGetStringFromObj(objv[i], &length); if (string[0] == '-') { /* * It looks like the command contains an option so signal an @@ -1357,7 +1357,7 @@ Tcl_GlobObjCmd( if (dir == PATH_GENERAL) { int pathlength; const char *last; - const char *first = Tcl_GetStringFromObj(pathOrDir,&pathlength); + const char *first = TclGetStringFromObj(pathOrDir,&pathlength); /* * Find the last path separator in the path @@ -1460,7 +1460,7 @@ Tcl_GlobObjCmd( const char *str; Tcl_ListObjIndex(interp, typePtr, length, &look); - str = Tcl_GetStringFromObj(look, &len); + str = TclGetStringFromObj(look, &len); if (strcmp("readonly", str) == 0) { globTypes->perm |= TCL_GLOB_PERM_RONLY; } else if (strcmp("hidden", str) == 0) { @@ -1595,8 +1595,9 @@ Tcl_GlobObjCmd( } else if (dir == PATH_GENERAL) { Tcl_DString str; + Tcl_DStringInit(&str); for (i = 0; i < objc; i++) { - Tcl_DStringInit(&str); + Tcl_DStringSetLength(&str, 0); if (dir == PATH_GENERAL) { TclDStringAppendDString(&str, &prefix); } @@ -1903,7 +1904,7 @@ TclGlob( } /* - * To process a [glob] invokation, this function may be called multiple + * To process a [glob] invocation, this function may be called multiple * times. Each time, the previously discovered filenames are in the * interpreter result. We stash that away here so the result is free for * error messsages. @@ -1991,7 +1992,7 @@ TclGlob( Tcl_Panic("Called TclGlob with TCL_GLOBMODE_TAILS and pathPrefix==NULL"); } - pre = Tcl_GetStringFromObj(pathPrefix, &prefixLen); + pre = TclGetStringFromObj(pathPrefix, &prefixLen); if (prefixLen > 0 && (strchr(separators, pre[prefixLen-1]) == NULL)) { /* @@ -2009,7 +2010,7 @@ TclGlob( Tcl_ListObjGetElements(NULL, filenamesObj, &objc, &objv); for (i = 0; i< objc; i++) { int len; - const char *oldStr = Tcl_GetStringFromObj(objv[i], &len); + const char *oldStr = TclGetStringFromObj(objv[i], &len); Tcl_Obj *elem; if (len == prefixLen) { @@ -2361,7 +2362,7 @@ DoGlob( Tcl_Obj *fixme, *newObj; Tcl_ListObjIndex(NULL, matchesObj, repair, &fixme); - bytes = Tcl_GetStringFromObj(fixme, &numBytes); + bytes = TclGetStringFromObj(fixme, &numBytes); newObj = Tcl_NewStringObj(bytes+2, numBytes-2); Tcl_ListObjReplace(NULL, matchesObj, repair, 1, 1, &newObj); @@ -2399,7 +2400,7 @@ DoGlob( Tcl_DStringAppend(&append, pattern, p-pattern); if (pathPtr != NULL) { - (void) Tcl_GetStringFromObj(pathPtr, &length); + (void) TclGetStringFromObj(pathPtr, &length); } else { length = 0; } @@ -2445,7 +2446,7 @@ DoGlob( */ int len; - const char *joined = Tcl_GetStringFromObj(joinedPtr,&len); + const char *joined = TclGetStringFromObj(joinedPtr,&len); if (strchr(separators, joined[len-1]) == NULL) { Tcl_AppendToObj(joinedPtr, "/", 1); @@ -2482,7 +2483,7 @@ DoGlob( */ int len; - const char *joined = Tcl_GetStringFromObj(joinedPtr,&len); + const char *joined = TclGetStringFromObj(joinedPtr,&len); if (strchr(separators, joined[len-1]) == NULL) { if (Tcl_FSGetPathType(pathPtr) != TCL_PATH_VOLUME_RELATIVE) { diff --git a/generic/tclFileSystem.h b/generic/tclFileSystem.h index 6be3e03..1eec7ff 100644 --- a/generic/tclFileSystem.h +++ b/generic/tclFileSystem.h @@ -33,7 +33,7 @@ MODULE_SCOPE void TclFSSetPathDetails(Tcl_Obj *pathPtr, const Tcl_Filesystem *fsPtr, ClientData clientData); MODULE_SCOPE Tcl_Obj * TclFSNormalizeAbsolutePath(Tcl_Interp *interp, Tcl_Obj *pathPtr); -MODULE_SCOPE int TclFSEpoch(void); +MODULE_SCOPE size_t TclFSEpoch(void); /* * Private shared variables for use by tclIOUtil.c and tclPathObj.c @@ -55,7 +55,7 @@ MODULE_SCOPE Tcl_PathType TclFSNonnativePathType(const char *pathPtr, MODULE_SCOPE Tcl_PathType TclGetPathType(Tcl_Obj *pathPtr, const Tcl_Filesystem **filesystemPtrPtr, int *driveNameLengthPtr, Tcl_Obj **driveNameRef); -MODULE_SCOPE int TclFSEpochOk(int filesystemEpoch); +MODULE_SCOPE int TclFSEpochOk(size_t filesystemEpoch); MODULE_SCOPE int TclFSCwdIsNative(void); MODULE_SCOPE Tcl_Obj * TclWinVolumeRelativeNormalize(Tcl_Interp *interp, const char *path, Tcl_Obj **useThisCwdPtr); diff --git a/generic/tclGet.c b/generic/tclGet.c index 97e8c7b..12e0e79 100644 --- a/generic/tclGet.c +++ b/generic/tclGet.c @@ -142,7 +142,7 @@ Tcl_GetBoolean( Tcl_Panic("invalid sharing of Tcl_Obj on C stack"); } if (code == TCL_OK) { - *boolPtr = obj.internalRep.longValue; + TclGetBooleanFromObj(NULL, &obj, boolPtr); } return code; } diff --git a/generic/tclHash.c b/generic/tclHash.c index 90be511..32c9aec 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -43,20 +43,7 @@ static Tcl_HashEntry * AllocArrayEntry(Tcl_HashTable *tablePtr, void *keyPtr); static int CompareArrayKeys(void *keyPtr, Tcl_HashEntry *hPtr); -static unsigned int HashArrayKey(Tcl_HashTable *tablePtr, void *keyPtr); - -/* - * Prototypes for the one word hash key methods. Not actually declared because - * this is a critical path that is implemented in the core hash table access - * function. - */ - -#if 0 -static Tcl_HashEntry * AllocOneWordEntry(Tcl_HashTable *tablePtr, - void *keyPtr); -static int CompareOneWordKeys(void *keyPtr, Tcl_HashEntry *hPtr); -static unsigned int HashOneWordKey(Tcl_HashTable *tablePtr, void *keyPtr); -#endif +static TCL_HASH_TYPE HashArrayKey(Tcl_HashTable *tablePtr, void *keyPtr); /* * Prototypes for the string hash key methods. @@ -65,7 +52,7 @@ static unsigned int HashOneWordKey(Tcl_HashTable *tablePtr, void *keyPtr); static Tcl_HashEntry * AllocStringEntry(Tcl_HashTable *tablePtr, void *keyPtr); static int CompareStringKeys(void *keyPtr, Tcl_HashEntry *hPtr); -static unsigned int HashStringKey(Tcl_HashTable *tablePtr, void *keyPtr); +static TCL_HASH_TYPE HashStringKey(Tcl_HashTable *tablePtr, void *keyPtr); /* * Function prototypes for static functions in this file: @@ -321,12 +308,10 @@ CreateHashEntry( for (hPtr = tablePtr->buckets[index]; hPtr != NULL; hPtr = hPtr->nextPtr) { -#if TCL_HASH_KEY_STORE_HASH if (hash != PTR2UINT(hPtr->hash)) { continue; } -#endif - if (compareKeysProc((void *) key, hPtr)) { + if (((void *) key == hPtr) || compareKeysProc((void *) key, hPtr)) { if (newPtr) { *newPtr = 0; } @@ -336,11 +321,9 @@ CreateHashEntry( } else { for (hPtr = tablePtr->buckets[index]; hPtr != NULL; hPtr = hPtr->nextPtr) { -#if TCL_HASH_KEY_STORE_HASH if (hash != PTR2UINT(hPtr->hash)) { continue; } -#endif if (key == hPtr->key.oneWordValue) { if (newPtr) { *newPtr = 0; @@ -368,15 +351,9 @@ CreateHashEntry( } hPtr->tablePtr = tablePtr; -#if TCL_HASH_KEY_STORE_HASH hPtr->hash = UINT2PTR(hash); hPtr->nextPtr = tablePtr->buckets[index]; tablePtr->buckets[index] = hPtr; -#else - hPtr->bucketPtr = &tablePtr->buckets[index]; - hPtr->nextPtr = *hPtr->bucketPtr; - *hPtr->bucketPtr = hPtr; -#endif tablePtr->numEntries++; /* @@ -416,9 +393,7 @@ Tcl_DeleteHashEntry( const Tcl_HashKeyType *typePtr; Tcl_HashTable *tablePtr; Tcl_HashEntry **bucketPtr; -#if TCL_HASH_KEY_STORE_HASH int index; -#endif tablePtr = entryPtr->tablePtr; @@ -433,7 +408,6 @@ Tcl_DeleteHashEntry( typePtr = &tclArrayHashKeyType; } -#if TCL_HASH_KEY_STORE_HASH if (typePtr->hashKeyProc == NULL || typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { index = RANDOM_INDEX(tablePtr, PTR2INT(entryPtr->hash)); @@ -442,9 +416,6 @@ Tcl_DeleteHashEntry( } bucketPtr = &tablePtr->buckets[index]; -#else - bucketPtr = entryPtr->bucketPtr; -#endif if (*bucketPtr == entryPtr) { *bucketPtr = entryPtr->nextPtr; @@ -790,7 +761,7 @@ CompareArrayKeys( *---------------------------------------------------------------------- */ -static unsigned int +static TCL_HASH_TYPE HashArrayKey( Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key from which to compute hash value. */ @@ -803,7 +774,7 @@ HashArrayKey( count--, array++) { result += *array; } - return result; + return (TCL_HASH_TYPE) result; } /* @@ -886,7 +857,7 @@ CompareStringKeys( *---------------------------------------------------------------------- */ -static unsigned +static TCL_HASH_TYPE HashStringKey( Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key from which to compute hash value. */ @@ -932,7 +903,7 @@ HashStringKey( result += (result << 3) + UCHAR(c); } } - return result; + return (TCL_HASH_TYPE) result; } /* @@ -940,7 +911,7 @@ HashStringKey( * * BogusFind -- * - * This function is invoked when an Tcl_FindHashEntry is called on a + * This function is invoked when Tcl_FindHashEntry is called on a * table that has been deleted. * * Results: @@ -967,7 +938,7 @@ BogusFind( * * BogusCreate -- * - * This function is invoked when an Tcl_CreateHashEntry is called on a + * This function is invoked when Tcl_CreateHashEntry is called on a * table that has been deleted. * * Results: @@ -1014,12 +985,18 @@ static void RebuildTable( register Tcl_HashTable *tablePtr) /* Table to enlarge. */ { - int oldSize, count, index; - Tcl_HashEntry **oldBuckets; + int count, index, oldSize = tablePtr->numBuckets; + Tcl_HashEntry **oldBuckets = tablePtr->buckets; register Tcl_HashEntry **oldChainPtr, **newChainPtr; register Tcl_HashEntry *hPtr; const Tcl_HashKeyType *typePtr; + /* Avoid outgrowing capability of the memory allocators */ + if (oldSize > (int)(UINT_MAX / (4 * sizeof(Tcl_HashEntry *)))) { + tablePtr->rebuildSize = INT_MAX; + return; + } + if (tablePtr->keyType == TCL_STRING_KEYS) { typePtr = &tclStringHashKeyType; } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) { @@ -1031,9 +1008,6 @@ RebuildTable( typePtr = &tclArrayHashKeyType; } - oldSize = tablePtr->numBuckets; - oldBuckets = tablePtr->buckets; - /* * Allocate and initialize the new bucket array, and set up hashing * constants for new array size. @@ -1062,7 +1036,6 @@ RebuildTable( for (oldChainPtr = oldBuckets; oldSize > 0; oldSize--, oldChainPtr++) { for (hPtr = *oldChainPtr; hPtr != NULL; hPtr = *oldChainPtr) { *oldChainPtr = hPtr->nextPtr; -#if TCL_HASH_KEY_STORE_HASH if (typePtr->hashKeyProc == NULL || typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { index = RANDOM_INDEX(tablePtr, PTR2INT(hPtr->hash)); @@ -1071,26 +1044,6 @@ RebuildTable( } hPtr->nextPtr = tablePtr->buckets[index]; tablePtr->buckets[index] = hPtr; -#else - void *key = Tcl_GetHashKey(tablePtr, hPtr); - - if (typePtr->hashKeyProc) { - unsigned int hash; - - hash = typePtr->hashKeyProc(tablePtr, key); - if (typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { - index = RANDOM_INDEX(tablePtr, hash); - } else { - index = hash & tablePtr->mask; - } - } else { - index = RANDOM_INDEX(tablePtr, key); - } - - hPtr->bucketPtr = &tablePtr->buckets[index]; - hPtr->nextPtr = *hPtr->bucketPtr; - *hPtr->bucketPtr = hPtr; -#endif } } diff --git a/generic/tclHistory.c b/generic/tclHistory.c index b10d423..47806d4 100644 --- a/generic/tclHistory.c +++ b/generic/tclHistory.c @@ -62,15 +62,14 @@ Tcl_RecordAndEval( * instead of Tcl_Eval. */ { register Tcl_Obj *cmdPtr; - int length = strlen(cmd); int result; - if (length > 0) { + if (cmd[0]) { /* * Call Tcl_RecordAndEvalObj to do the actual work. */ - cmdPtr = Tcl_NewStringObj(cmd, length); + cmdPtr = Tcl_NewStringObj(cmd, -1); Tcl_IncrRefCount(cmdPtr); result = Tcl_RecordAndEvalObj(interp, cmdPtr, flags); @@ -161,7 +160,7 @@ Tcl_RecordAndEvalObj( Tcl_Obj *list[3]; /* - * Do recording by eval'ing a tcl history command: history add $cmd. + * Do recording by eval'ing a tcl history command: history add $cmd. */ list[0] = histObjsPtr->historyObj; @@ -175,7 +174,7 @@ Tcl_RecordAndEvalObj( /* * One possible failure mode above: exceeding a resource limit. */ - + if (Tcl_LimitExceeded(interp)) { return TCL_ERROR; } diff --git a/generic/tclIO.c b/generic/tclIO.c index f1d85bf..ad6c7ee 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -6,6 +6,7 @@ * * Copyright (c) 1998-2000 Ajuba Solutions * Copyright (c) 1995-1997 Sun Microsystems, Inc. + * Contributions from Don Porter, NIST, 2014. (not subject to US copyright) * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -34,15 +35,15 @@ typedef struct ChannelHandler { /* * This structure keeps track of the current ChannelHandler being invoked in - * the current invocation of ChannelHandlerEventProc. There is a potential + * the current invocation of Tcl_NotifyChannel. There is a potential * problem if a ChannelHandler is deleted while it is the current one, since - * ChannelHandlerEventProc needs to look at the nextPtr field. To handle this + * Tcl_NotifyChannel needs to look at the nextPtr field. To handle this * problem, structures of the type below indicate the next handler to be * processed for any (recursively nested) dispatches in progress. The * nextHandlerPtr field is updated if the handler being pointed to is deleted. - * The nextPtr field is used to chain together all recursive invocations, so - * that Tcl_DeleteChannelHandler can find all the recursively nested - * invocations of ChannelHandlerEventProc and compare the handler being + * The nestedHandlerPtr field is used to chain together all recursive + * invocations, so that Tcl_DeleteChannelHandler can find all the recursively + * nested invocations of Tcl_NotifyChannel and compare the handler being * deleted against the NEXT handler to be invoked in that invocation; when it * finds such a situation, Tcl_DeleteChannelHandler updates the nextHandlerPtr * field of the structure to the next handler. @@ -53,21 +54,10 @@ typedef struct NextChannelHandler { * this invocation. */ struct NextChannelHandler *nestedHandlerPtr; /* Next nested invocation of - * ChannelHandlerEventProc. */ + * Tcl_NotifyChannel. */ } NextChannelHandler; /* - * The following structure describes the event that is added to the Tcl - * event queue by the channel handler check procedure. - */ - -typedef struct ChannelHandlerEvent { - Tcl_Event header; /* Standard header for all events. */ - Channel *chanPtr; /* The channel that is ready. */ - int readyMask; /* Events that have occurred. */ -} ChannelHandlerEvent; - -/* * The following structure is used by Tcl_GetsObj() to encapsulates the * state for a "gets" operation. */ @@ -126,10 +116,10 @@ typedef struct CopyState { * The structure defined below is used in this file only. */ -typedef struct ThreadSpecificData { +typedef struct { NextChannelHandler *nestedHandlerPtr; /* This variable holds the list of nested - * ChannelHandlerEventProc invocations. */ + * Tcl_NotifyChannel invocations. */ ChannelState *firstCSPtr; /* List of all channels currently open, * indexed by ChannelState, as only one * ChannelState exists per set of stacked @@ -162,11 +152,14 @@ typedef struct CloseCallback { */ static ChannelBuffer * AllocChannelBuffer(int length); +static void PreserveChannelBuffer(ChannelBuffer *bufPtr); +static void ReleaseChannelBuffer(ChannelBuffer *bufPtr); +static int IsShared(ChannelBuffer *bufPtr); +static void ChannelFree(Channel *chanPtr); static void ChannelTimerProc(ClientData clientData); +static int ChanRead(Channel *chanPtr, char *dst, int dstSize); static int CheckChannelErrors(ChannelState *statePtr, int direction); -static int CheckFlush(Channel *chanPtr, ChannelBuffer *bufPtr, - int newlineFlag); static int CheckForDeadChannel(Tcl_Interp *interp, ChannelState *statePtr); static void CheckForStdChannelsBeingClosed(Tcl_Channel chan); @@ -178,10 +171,15 @@ static int CloseChannelPart(Tcl_Interp *interp, Channel *chanPtr, int errorCode, int flags); static int CloseWrite(Tcl_Interp *interp, Channel *chanPtr); static void CommonGetsCleanup(Channel *chanPtr); -static int CopyAndTranslateBuffer(ChannelState *statePtr, - char *result, int space); -static int CopyBuffer(Channel *chanPtr, char *result, int space); static int CopyData(CopyState *csPtr, int mask); +static int MoveBytes(CopyState *csPtr); + +static void MBCallback(CopyState *csPtr, Tcl_Obj *errObj); +static void MBError(CopyState *csPtr, int mask, int errorCode); +static int MBRead(CopyState *csPtr); +static int MBWrite(CopyState *csPtr); +static void MBEvent(ClientData clientData, int mask); + static void CopyEventProc(ClientData clientData, int mask); static void CreateScriptRecord(Tcl_Interp *interp, Channel *chanPtr, int mask, Tcl_Obj *scriptPtr); @@ -193,16 +191,16 @@ static int DetachChannel(Tcl_Interp *interp, Tcl_Channel chan); static void DiscardInputQueued(ChannelState *statePtr, int discardSavedBuffers); static void DiscardOutputQueued(ChannelState *chanPtr); -static int DoRead(Channel *chanPtr, char *srcPtr, int slen, int allowShortReads); -static int DoWrite(Channel *chanPtr, const char *src, int srcLen); +static int DoRead(Channel *chanPtr, char *dst, int bytesToRead, + int allowShortReads); static int DoReadChars(Channel *chan, Tcl_Obj *objPtr, int toRead, int appendFlag); -static int DoWriteChars(Channel *chan, const char *src, int len); static int FilterInputBytes(Channel *chanPtr, GetsState *statePtr); static int FlushChannel(Tcl_Interp *interp, Channel *chanPtr, int calledFromAsyncFlush); static int TclGetsObjBinary(Tcl_Channel chan, Tcl_Obj *objPtr); +static Tcl_Encoding GetBinaryEncoding(); static void FreeBinaryEncoding(ClientData clientData); static Tcl_HashTable * GetChannelTable(Tcl_Interp *interp); static int GetInput(Channel *chanPtr); @@ -211,29 +209,30 @@ static int HaveVersion(const Tcl_ChannelType *typePtr, static void PeekAhead(Channel *chanPtr, char **dstEndPtr, GetsState *gsPtr); static int ReadBytes(ChannelState *statePtr, Tcl_Obj *objPtr, - int charsLeft, int *offsetPtr); + int charsLeft); static int ReadChars(ChannelState *statePtr, Tcl_Obj *objPtr, - int charsLeft, int *offsetPtr, int *factorPtr); + int charsLeft, int *factorPtr); static void RecycleBuffer(ChannelState *statePtr, ChannelBuffer *bufPtr, int mustDiscard); static int StackSetBlockMode(Channel *chanPtr, int mode); static int SetBlockMode(Tcl_Interp *interp, Channel *chanPtr, int mode); static void StopCopy(CopyState *csPtr); -static int TranslateInputEOL(ChannelState *statePtr, char *dst, - const char *src, int *dstLenPtr, int *srcLenPtr); -static int TranslateOutputEOL(ChannelState *statePtr, char *dst, +static void TranslateInputEOL(ChannelState *statePtr, char *dst, const char *src, int *dstLenPtr, int *srcLenPtr); static void UpdateInterest(Channel *chanPtr); -static int WriteBytes(Channel *chanPtr, const char *src, - int srcLen); -static int WriteChars(Channel *chanPtr, const char *src, - int srcLen); +static int Write(Channel *chanPtr, const char *src, + int srcLen, Tcl_Encoding encoding); static Tcl_Obj * FixLevelCode(Tcl_Obj *msg); static void SpliceChannel(Tcl_Channel chan); static void CutChannel(Tcl_Channel chan); static int WillRead(Channel *chanPtr); +#define WriteChars(chanPtr, src, srcLen) \ + Write(chanPtr, src, srcLen, chanPtr->state->encoding) +#define WriteBytes(chanPtr, src, srcLen) \ + Write(chanPtr, src, srcLen, tclIdentityEncoding) + /* * Simplifying helper macros. All may use their argument(s) multiple times. * The ANSI C "prototypes" for the macros are listed below, together with a @@ -286,7 +285,7 @@ static int WillRead(Channel *chanPtr); #define IsBufferEmpty(bufPtr) ((bufPtr)->nextAdded == (bufPtr)->nextRemoved) -#define IsBufferFull(bufPtr) ((bufPtr)->nextAdded >= (bufPtr)->bufLength) +#define IsBufferFull(bufPtr) ((bufPtr) && (bufPtr)->nextAdded >= (bufPtr)->bufLength) #define IsBufferOverflowing(bufPtr) ((bufPtr)->nextAdded>(bufPtr)->bufLength) @@ -314,35 +313,30 @@ static int WillRead(Channel *chanPtr); && (strncmp(optionName, (nameString), len) == 0)) /* - * The ChannelObjType type. We actually store the ChannelState structure - * as that lives longest and we want to return the bottomChanPtr when - * requested (consistent with Tcl_GetChannel). The setFromAny and - * updateString can be NULL as they should not be called. + * The ChannelObjType type. Used to store the result of looking up + * a channel name in the context of an interp. Saves the lookup + * result and values needed to check its continued validity. */ +typedef struct ResolvedChanName { + ChannelState *statePtr; /* The saved lookup result */ + Tcl_Interp *interp; /* The interp in which the lookup was done. */ + size_t epoch; /* The epoch of the channel when the lookup + * was done. Use to verify validity. */ + size_t refCount; /* Share this struct among many Tcl_Obj. */ +} ResolvedChanName; + static void DupChannelIntRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); -static int SetChannelFromAny(Tcl_Interp *interp, - Tcl_Obj *objPtr); -static void UpdateStringOfChannel(Tcl_Obj *objPtr); static void FreeChannelIntRep(Tcl_Obj *objPtr); -static const Tcl_ObjType tclChannelType = { +static const Tcl_ObjType chanObjType = { "channel", /* name for this type */ FreeChannelIntRep, /* freeIntRepProc */ DupChannelIntRep, /* dupIntRepProc */ - NULL, /* updateStringProc UpdateStringOfChannel */ - NULL /* setFromAnyProc SetChannelFromAny */ + NULL, /* updateStringProc */ + NULL /* setFromAnyProc */ }; -#define GET_CHANNELSTATE(objPtr) \ - ((ChannelState *) (objPtr)->internalRep.twoPtrValue.ptr1) -#define SET_CHANNELSTATE(objPtr, storePtr) \ - ((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (storePtr)) -#define GET_CHANNELINTERP(objPtr) \ - ((Interp *) (objPtr)->internalRep.twoPtrValue.ptr2) -#define SET_CHANNELINTERP(objPtr, storePtr) \ - ((objPtr)->internalRep.twoPtrValue.ptr2 = (void *) (storePtr)) - #define BUSY_STATE(st, fl) \ ((((st)->csPtrR) && ((fl) & TCL_READABLE)) || \ (((st)->csPtrW) && ((fl) & TCL_WRITABLE))) @@ -382,19 +376,92 @@ ChanCloseHalf( return chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp, flags); } -static inline int +/* + *--------------------------------------------------------------------------- + * + * ChanRead -- + * + * Read up to dstSize bytes using the inputProc of chanPtr, store them at + * dst, and return the number of bytes stored. + * + * Results: + * The return value of the driver inputProc, + * - number of bytes stored at dst, ot + * - -1 on error, with a Posix error code available to the caller by + * calling Tcl_GetErrno(). + * + * Side effects: + * The CHANNEL_BLOCKED and CHANNEL_EOF flags of the channel state are set + * as appropriate. On EOF, the inputEncodingFlags are set to perform + * ending operations on decoding. + * + * TODO - Is this really the right place for that? + * + *--------------------------------------------------------------------------- + */ +static int ChanRead( Channel *chanPtr, char *dst, - int dstSize, - int *errnoPtr) + int dstSize) { + int bytesRead, result; + + /* + * If the caller asked for zero bytes, we'd force the inputProc to return + * zero bytes, and then misinterpret that as EOF. + */ + + assert(dstSize > 0); + + /* + * Each read op must set the blocked and eof states anew, not let + * the effect of prior reads leak through. + */ + + if (GotFlag(chanPtr->state, CHANNEL_EOF)) { + chanPtr->state->inputEncodingFlags |= TCL_ENCODING_START; + } + ResetFlag(chanPtr->state, CHANNEL_BLOCKED | CHANNEL_EOF); + chanPtr->state->inputEncodingFlags &= ~TCL_ENCODING_END; if (WillRead(chanPtr) < 0) { return -1; } - return chanPtr->typePtr->inputProc(chanPtr->instanceData, dst, dstSize, - errnoPtr); + bytesRead = chanPtr->typePtr->inputProc(chanPtr->instanceData, + dst, dstSize, &result); + + /* + * Stop any flag leakage through stacked channel levels. + */ + + if (GotFlag(chanPtr->state, CHANNEL_EOF)) { + chanPtr->state->inputEncodingFlags |= TCL_ENCODING_START; + } + ResetFlag(chanPtr->state, CHANNEL_BLOCKED | CHANNEL_EOF); + chanPtr->state->inputEncodingFlags &= ~TCL_ENCODING_END; + if (bytesRead > 0) { + /* + * If we get a short read, signal up that we may be BLOCKED. We should + * avoid calling the driver because on some platforms we will block in + * the low level reading code even though the channel is set into + * nonblocking mode. + */ + + if (bytesRead < dstSize) { + SetFlag(chanPtr->state, CHANNEL_BLOCKED); + } + } else if (bytesRead == 0) { + SetFlag(chanPtr->state, CHANNEL_EOF); + chanPtr->state->inputEncodingFlags |= TCL_ENCODING_END; + } else if (bytesRead < 0) { + if ((result == EWOULDBLOCK) || (result == EAGAIN)) { + SetFlag(chanPtr->state, CHANNEL_BLOCKED); + result = EAGAIN; + } + Tcl_SetErrno(result); + } + return bytesRead; } static inline Tcl_WideInt @@ -512,11 +579,14 @@ TclFinalizeIOSubsystem(void) int active = 1; /* Flag == 1 while there's still work to do */ int doflushnb; - /* Fetch the pre-TIP#398 compatibility flag */ + /* + * Fetch the pre-TIP#398 compatibility flag. + */ + { const char *s; Tcl_DString ds; - + s = TclGetEnv("TCL_FLUSH_NONBLOCKING_ON_EXIT", &ds); doflushnb = ((s != NULL) && strcmp(s, "0")); if (s != NULL) { @@ -557,20 +627,23 @@ TclFinalizeIOSubsystem(void) */ if (active) { + TclChannelPreserve((Tcl_Channel)chanPtr); /* - * TIP #398: by default, we no longer set the channel back into - * blocking mode. To restore the old blocking behavior, the - * environment variable TCL_FLUSH_NONBLOCKING_ON_EXIT must be set + * TIP #398: by default, we no longer set the channel back into + * blocking mode. To restore the old blocking behavior, the + * environment variable TCL_FLUSH_NONBLOCKING_ON_EXIT must be set * and not be "0". */ + if (doflushnb) { - /* Set the channel back into blocking mode to ensure that we wait - * for all data to flush out. - */ - + /* + * Set the channel back into blocking mode to ensure that we + * wait for all data to flush out. + */ + (void) Tcl_SetChannelOption(NULL, (Tcl_Channel) chanPtr, - "-blocking", "on"); + "-blocking", "on"); } if ((chanPtr == (Channel *) tsdPtr->stdinChannel) || @@ -616,6 +689,7 @@ TclFinalizeIOSubsystem(void) chanPtr->instanceData = NULL; SetFlag(statePtr, CHANNEL_DEAD); } + TclChannelRelease((Tcl_Channel)chanPtr); } } @@ -647,17 +721,18 @@ Tcl_SetStdChannel( { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + int init = channel ? 1 : -1; switch (type) { case TCL_STDIN: - tsdPtr->stdinInitialized = 1; + tsdPtr->stdinInitialized = init; tsdPtr->stdinChannel = channel; break; case TCL_STDOUT: - tsdPtr->stdoutInitialized = 1; + tsdPtr->stdoutInitialized = init; tsdPtr->stdoutChannel = channel; break; case TCL_STDERR: - tsdPtr->stderrInitialized = 1; + tsdPtr->stderrInitialized = init; tsdPtr->stderrChannel = channel; break; } @@ -694,8 +769,8 @@ Tcl_GetStdChannel( switch (type) { case TCL_STDIN: if (!tsdPtr->stdinInitialized) { + tsdPtr->stdinInitialized = -1; tsdPtr->stdinChannel = TclpGetDefaultStdChannel(TCL_STDIN); - tsdPtr->stdinInitialized = 1; /* * Artificially bump the refcount to ensure that the channel is @@ -707,6 +782,7 @@ Tcl_GetStdChannel( */ if (tsdPtr->stdinChannel != NULL) { + tsdPtr->stdinInitialized = 1; Tcl_RegisterChannel(NULL, tsdPtr->stdinChannel); } } @@ -714,9 +790,10 @@ Tcl_GetStdChannel( break; case TCL_STDOUT: if (!tsdPtr->stdoutInitialized) { + tsdPtr->stdoutInitialized = -1; tsdPtr->stdoutChannel = TclpGetDefaultStdChannel(TCL_STDOUT); - tsdPtr->stdoutInitialized = 1; if (tsdPtr->stdoutChannel != NULL) { + tsdPtr->stdoutInitialized = 1; Tcl_RegisterChannel(NULL, tsdPtr->stdoutChannel); } } @@ -724,9 +801,10 @@ Tcl_GetStdChannel( break; case TCL_STDERR: if (!tsdPtr->stderrInitialized) { + tsdPtr->stderrInitialized = -1; tsdPtr->stderrChannel = TclpGetDefaultStdChannel(TCL_STDERR); - tsdPtr->stderrInitialized = 1; if (tsdPtr->stderrChannel != NULL) { + tsdPtr->stderrInitialized = 1; Tcl_RegisterChannel(NULL, tsdPtr->stderrChannel); } } @@ -953,9 +1031,8 @@ DeleteChannelTable( */ Tcl_DeleteHashEntry(hPtr); - SetFlag(statePtr, CHANNEL_TAINTED); - statePtr->refCount--; - if (statePtr->refCount <= 0) { + statePtr->epoch++; + if (statePtr->refCount-- <= 1) { if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { (void) Tcl_Close(interp, (Tcl_Channel) chanPtr); } @@ -995,7 +1072,7 @@ CheckForStdChannelsBeingClosed( ChannelState *statePtr = ((Channel *) chan)->state; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - if (tsdPtr->stdinInitialized + if (tsdPtr->stdinInitialized == 1 && tsdPtr->stdinChannel != NULL && statePtr == ((Channel *)tsdPtr->stdinChannel)->state) { if (statePtr->refCount < 2) { @@ -1003,7 +1080,7 @@ CheckForStdChannelsBeingClosed( tsdPtr->stdinChannel = NULL; return; } - } else if (tsdPtr->stdoutInitialized + } else if (tsdPtr->stdoutInitialized == 1 && tsdPtr->stdoutChannel != NULL && statePtr == ((Channel *)tsdPtr->stdoutChannel)->state) { if (statePtr->refCount < 2) { @@ -1011,7 +1088,7 @@ CheckForStdChannelsBeingClosed( tsdPtr->stdoutChannel = NULL; return; } - } else if (tsdPtr->stderrInitialized + } else if (tsdPtr->stderrInitialized == 1 && tsdPtr->stderrChannel != NULL && statePtr == ((Channel *)tsdPtr->stderrChannel)->state) { if (statePtr->refCount < 2) { @@ -1177,15 +1254,6 @@ Tcl_UnregisterChannel( */ if (statePtr->refCount <= 0) { - /* - * Ensure that if there is another buffer, it gets flushed whether or - * not we are doing a background flush. - */ - - if ((statePtr->curOutPtr != NULL) && - IsBufferReady(statePtr->curOutPtr)) { - SetFlag(statePtr, BUFFER_READY); - } Tcl_Preserve(statePtr); if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { /* @@ -1307,7 +1375,7 @@ DetachChannel( return TCL_ERROR; } Tcl_DeleteHashEntry(hPtr); - SetFlag(statePtr, CHANNEL_TAINTED); + statePtr->epoch++; /* * Remove channel handlers that refer to this interpreter, so that @@ -1440,12 +1508,62 @@ TclGetChannelFromObj( int flags) { ChannelState *statePtr; + ResolvedChanName *resPtr = NULL; + Tcl_Channel chan; - if (SetChannelFromAny(interp, objPtr) != TCL_OK) { + if (interp == NULL) { return TCL_ERROR; } - statePtr = GET_CHANNELSTATE(objPtr); + if (objPtr->typePtr == &chanObjType) { + /* + * Confirm validity of saved lookup results. + */ + + resPtr = (ResolvedChanName *) objPtr->internalRep.twoPtrValue.ptr1; + statePtr = resPtr->statePtr; + if ((resPtr->interp == interp) /* Same interp context */ + /* No epoch change in channel since lookup */ + && (resPtr->epoch == statePtr->epoch)) { + /* + * Have a valid saved lookup. Jump to end to return it. + */ + + goto valid; + } + } + + chan = Tcl_GetChannel(interp, TclGetString(objPtr), NULL); + + if (chan == NULL) { + if (resPtr) { + FreeChannelIntRep(objPtr); + } + return TCL_ERROR; + } + + if (resPtr && resPtr->refCount == 1) { + /* + * Re-use the ResolvedCmdName struct. + */ + + Tcl_Release((ClientData) resPtr->statePtr); + + } else { + TclFreeIntRep(objPtr); + + resPtr = (ResolvedChanName *) ckalloc(sizeof(ResolvedChanName)); + resPtr->refCount = 1; + objPtr->internalRep.twoPtrValue.ptr1 = (ClientData) resPtr; + objPtr->typePtr = &chanObjType; + } + statePtr = ((Channel *)chan)->state; + resPtr->statePtr = statePtr; + Tcl_Preserve((ClientData) statePtr); + resPtr->interp = interp; + resPtr->epoch = statePtr->epoch; + + valid: *channelPtr = (Tcl_Channel) statePtr->bottomChanPtr; if (modePtr != NULL) { @@ -1497,6 +1615,22 @@ Tcl_CreateChannel( */ assert(sizeof(Tcl_ChannelTypeVersion) == sizeof(Tcl_DriverBlockModeProc *)); + assert(typePtr->typeName != NULL); + if (NULL == typePtr->closeProc) { + Tcl_Panic("channel type %s must define closeProc", typePtr->typeName); + } + if ((TCL_READABLE & mask) && (NULL == typePtr->inputProc)) { + Tcl_Panic("channel type %s must define inputProc when used for reader channel", typePtr->typeName); + } + if ((TCL_WRITABLE & mask) && (NULL == typePtr->outputProc)) { + Tcl_Panic("channel type %s must define outputProc when used for writer channel", typePtr->typeName); + } + if (NULL == typePtr->watchProc) { + Tcl_Panic("channel type %s must define watchProc", typePtr->typeName); + } + if ((NULL!=typePtr->wideSeekProc) && (NULL == typePtr->seekProc)) { + Tcl_Panic("channel type %s must define seekProc if defining wideSeekProc", typePtr->typeName); + } /* * JH: We could subsequently memset these to 0 to avoid the numerous @@ -1556,7 +1690,7 @@ Tcl_CreateChannel( * Set the channel up initially in AUTO input translation mode to accept * "\n", "\r" and "\r\n". Output translation mode is set to a platform * specific default value. The eofChar is set to 0 for both input and - * output, so that Tcl does not look for an in-file EOF indicator (e.g. + * output, so that Tcl does not look for an in-file EOF indicator (e.g., * ^Z) and does not append an EOF indicator to files. */ @@ -1581,11 +1715,7 @@ Tcl_CreateChannel( statePtr->timer = NULL; statePtr->csPtrR = NULL; statePtr->csPtrW = NULL; - statePtr->outputStage = NULL; - if ((statePtr->encoding != NULL) && GotFlag(statePtr, TCL_WRITABLE)) { - statePtr->outputStage = ckalloc(statePtr->bufSize + 2); - } /* * As we are creating the channel, it is obviously the top for now. @@ -1597,6 +1727,7 @@ Tcl_CreateChannel( chanPtr->upChanPtr = NULL; chanPtr->inQueueHead = NULL; chanPtr->inQueueTail = NULL; + chanPtr->refCount = 0; /* * TIP #219, Tcl Channel Reflection API @@ -1605,6 +1736,8 @@ Tcl_CreateChannel( statePtr->chanMsg = NULL; statePtr->unreportedMsg = NULL; + statePtr->epoch = 0; + /* * 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 @@ -1750,6 +1883,10 @@ Tcl_StackChannel( statePtr->csPtrR = NULL; statePtr->csPtrW = NULL; + /* + * TODO: Examine what can go wrong if Tcl_Flush() call disturbs + * the stacking state of this channel during its operations. + */ if (Tcl_Flush((Tcl_Channel) prevChanPtr) != TCL_OK) { statePtr->csPtrR = csPtrR; statePtr->csPtrW = csPtrW; @@ -1782,16 +1919,15 @@ Tcl_StackChannel( if (((mask & TCL_READABLE) != 0) && (statePtr->inQueueHead != NULL)) { /* - * Remark: It is possible that the channel buffers contain data from - * some earlier push-backs. + * When statePtr->inQueueHead is not NULL, we know + * prevChanPtr->inQueueHead must be NULL. */ - statePtr->inQueueTail->nextPtr = prevChanPtr->inQueueHead; - prevChanPtr->inQueueHead = statePtr->inQueueHead; + assert(prevChanPtr->inQueueHead == NULL); + assert(prevChanPtr->inQueueTail == NULL); - if (prevChanPtr->inQueueTail == NULL) { - prevChanPtr->inQueueTail = statePtr->inQueueTail; - } + prevChanPtr->inQueueHead = statePtr->inQueueHead; + prevChanPtr->inQueueTail = statePtr->inQueueTail; statePtr->inQueueHead = NULL; statePtr->inQueueTail = NULL; @@ -1813,6 +1949,7 @@ Tcl_StackChannel( chanPtr->upChanPtr = NULL; chanPtr->inQueueHead = NULL; chanPtr->inQueueTail = NULL; + chanPtr->refCount = 0; /* * Place new block at the head of a possibly existing list of previously @@ -1837,6 +1974,41 @@ Tcl_StackChannel( return (Tcl_Channel) chanPtr; } + +void +TclChannelPreserve( + Tcl_Channel chan) +{ + ((Channel *)chan)->refCount++; +} + +void +TclChannelRelease( + Tcl_Channel chan) +{ + Channel *chanPtr = (Channel *) chan; + + if (chanPtr->refCount == 0) { + Tcl_Panic("Channel released more than preserved"); + } + if (--chanPtr->refCount) { + return; + } + if (chanPtr->typePtr == NULL) { + ckfree(chanPtr); + } +} + +static void +ChannelFree( + Channel *chanPtr) +{ + if (chanPtr->refCount == 0) { + ckfree(chanPtr); + return; + } + chanPtr->typePtr = NULL; +} /* *---------------------------------------------------------------------- @@ -1877,6 +2049,11 @@ Tcl_UnstackChannel( * of registered channels we wind down the state of the * transformation, and then restore the state of underlying channel * into the old structure. + * + * TODO: Figure out how to handle the situation where the chan + * operations called below by this unstacking operation cause + * another unstacking recursively. In that case the downChanPtr + * value we're holding on to will not be the right thing. */ Channel *downChanPtr = chanPtr->downChanPtr; @@ -1976,14 +2153,9 @@ Tcl_UnstackChannel( */ result = ChanClose(chanPtr, interp); - chanPtr->typePtr = NULL; + ChannelFree(chanPtr); - /* - * AK: Tcl_NotifyChannel may hold a reference to this block of memory - */ - - Tcl_EventuallyFree(chanPtr, TCL_DYNAMIC); - UpdateInterest(downChanPtr); + UpdateInterest(statePtr->topChanPtr); if (result != 0) { Tcl_SetErrno(result); @@ -2295,8 +2467,36 @@ AllocChannelBuffer( bufPtr->nextRemoved = BUFFER_PADDING; bufPtr->bufLength = length + BUFFER_PADDING; bufPtr->nextPtr = NULL; + bufPtr->refCount = 1; return bufPtr; } + +static void +PreserveChannelBuffer( + ChannelBuffer *bufPtr) +{ + if (bufPtr->refCount == 0) { + Tcl_Panic("Reuse of ChannelBuffer! %p", bufPtr); + } + bufPtr->refCount++; +} + +static void +ReleaseChannelBuffer( + ChannelBuffer *bufPtr) +{ + if (--bufPtr->refCount) { + return; + } + ckfree(bufPtr); +} + +static int +IsShared( + ChannelBuffer *bufPtr) +{ + return bufPtr->refCount > 1; +} /* *---------------------------------------------------------------------- @@ -2328,19 +2528,22 @@ RecycleBuffer( * Do we have to free the buffer to the OS? */ + if (IsShared(bufPtr)) { + mustDiscard = 1; + } + if (mustDiscard) { - ckfree(bufPtr); + ReleaseChannelBuffer(bufPtr); return; } /* - * 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. + * Only save buffers which have 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(bufPtr); + if ((bufPtr->bufLength - BUFFER_PADDING) != statePtr->bufSize) { + ReleaseChannelBuffer(bufPtr); return; } @@ -2375,7 +2578,7 @@ RecycleBuffer( * If we reached this code we return the buffer to the OS. */ - ckfree(bufPtr); + ReleaseChannelBuffer(bufPtr); return; keepBuffer: @@ -2413,6 +2616,11 @@ DiscardOutputQueued( } statePtr->outQueueHead = NULL; statePtr->outQueueTail = NULL; + bufPtr = statePtr->curOutPtr; + if (bufPtr && BytesLeft(bufPtr)) { + statePtr->curOutPtr = NULL; + RecycleBuffer(statePtr, bufPtr, 0); + } } /* @@ -2480,8 +2688,6 @@ FlushChannel( ChannelState *statePtr = chanPtr->state; /* State of the channel stack. */ ChannelBuffer *bufPtr; /* Iterates over buffered output queue. */ - int toWrite; /* Amount of output data in current buffer - * available to be written. */ int written; /* Amount of output data actually written in * current round. */ int errorCode = 0; /* Stores POSIX error codes from channel @@ -2501,63 +2707,65 @@ FlushChannel( } /* - * Loop over the queued buffers and attempt to flush as much as possible - * of the queued output to the channel. + * Should we shift the current output buffer over to the output queue? + * First check that there are bytes in it. If so then... + * + * If the output queue is empty, then yes, trusting the caller called us + * only when written bytes ought to be flushed. + * + * If the current output buffer is full, then yes, so we can meet the + * post-condition that on a successful return to caller we've left space + * in the current output buffer for more writing (the flush call was to + * make new room). + * + * If the channel is blocking, then yes, so we guarantee that blocking + * flushes actually flush all pending data. + * + * Otherwise, no. Keep the current output buffer where it is so more + * can be written to it, possibly filling it, to promote more efficient + * buffer usage. */ - Tcl_Preserve(chanPtr); - while (1) { - /* - * If the queue is empty and there is a ready current buffer, OR if - * the current buffer is full, then move the current buffer to the - * queue. - */ - - if (((statePtr->curOutPtr != NULL) && - IsBufferFull(statePtr->curOutPtr)) - || (GotFlag(statePtr, BUFFER_READY) && - (statePtr->outQueueHead == NULL))) { - ResetFlag(statePtr, BUFFER_READY); - statePtr->curOutPtr->nextPtr = NULL; - if (statePtr->outQueueHead == NULL) { - statePtr->outQueueHead = statePtr->curOutPtr; - } else { - statePtr->outQueueTail->nextPtr = statePtr->curOutPtr; - } - statePtr->outQueueTail = statePtr->curOutPtr; - statePtr->curOutPtr = NULL; + bufPtr = statePtr->curOutPtr; + if (bufPtr && BytesLeft(bufPtr) && /* Keep empties off queue */ + (statePtr->outQueueHead == NULL || IsBufferFull(bufPtr) + || !GotFlag(statePtr, CHANNEL_NONBLOCKING))) { + if (statePtr->outQueueHead == NULL) { + statePtr->outQueueHead = bufPtr; + } else { + statePtr->outQueueTail->nextPtr = bufPtr; } - bufPtr = statePtr->outQueueHead; + statePtr->outQueueTail = bufPtr; + statePtr->curOutPtr = NULL; + } - /* - * If we are not being called from an async flush and an async flush - * is active, we just return without producing any output. - */ + assert(!IsBufferFull(statePtr->curOutPtr)); - if (!calledFromAsyncFlush && GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { - errorCode = 0; - goto done; - } + /* + * If we are not being called from an async flush and an async flush + * is active, we just return without producing any output. + */ - /* - * If the output queue is still empty, break out of the while loop. - */ + if (!calledFromAsyncFlush && GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { + return 0; + } - if (bufPtr == NULL) { - break; /* Out of the "while (1)". */ - } + /* + * Loop over the queued buffers and attempt to flush as much as possible + * of the queued output to the channel. + */ + + TclChannelPreserve((Tcl_Channel)chanPtr); + while (statePtr->outQueueHead) { + bufPtr = statePtr->outQueueHead; /* * Produce the output on the channel. */ - toWrite = BytesLeft(bufPtr); - if (toWrite == 0) { - written = 0; - } else { - written = ChanWrite(chanPtr, RemovePoint(bufPtr), toWrite, - &errorCode); - } + PreserveChannelBuffer(bufPtr); + written = ChanWrite(chanPtr, RemovePoint(bufPtr), BytesLeft(bufPtr), + &errorCode); /* * If the write failed completely attempt to start the asynchronous @@ -2572,6 +2780,7 @@ FlushChannel( if (errorCode == EINTR) { errorCode = 0; + ReleaseChannelBuffer(bufPtr); continue; } @@ -2593,6 +2802,7 @@ FlushChannel( UpdateInterest(chanPtr); } errorCode = 0; + ReleaseChannelBuffer(bufPtr); break; } @@ -2604,8 +2814,8 @@ FlushChannel( /* * TIP #219, Tcl Channel Reflection API. * When defering the error copy a message from the bypass into - * the unreported area. Or discard it if the new error is to be - * ignored in favor of an earlier defered error. + * the unreported area. Or discard it if the new error is to + * be ignored in favor of an earlier defered error. */ Tcl_Obj *msg = statePtr->chanMsg; @@ -2654,14 +2864,18 @@ FlushChannel( */ DiscardOutputQueued(statePtr); - continue; + ReleaseChannelBuffer(bufPtr); + break; } else { + /* + * TODO: Consider detecting and reacting to short writes on + * blocking channels. Ought not happen. See iocmd-24.2. + */ + wroteSome = 1; } - if (!IsBufferEmpty(bufPtr)) { - bufPtr->nextRemoved += written; - } + bufPtr->nextRemoved += written; /* * If this buffer is now empty, recycle it. @@ -2674,7 +2888,8 @@ FlushChannel( } RecycleBuffer(statePtr, bufPtr, 0); } - } /* Closes "while (1)". */ + ReleaseChannelBuffer(bufPtr); + } /* Closes "while". */ /* * If we wrote some data while flushing in the background, we are done. @@ -2689,6 +2904,24 @@ FlushChannel( } else if (statePtr->outQueueHead == NULL) { ResetFlag(statePtr, BG_FLUSH_SCHEDULED); ChanWatch(chanPtr, statePtr->interestMask); + } else { + /* + * When we are calledFromAsyncFlush, that means a writable + * state on the channel triggered the call, so we should be + * able to write something. Either we did write something + * and wroteSome should be set, or there was nothing left to + * write in this call, and we've completed the BG flush. + * These are the two cases above. If we get here, that means + * there is some kind failure in the writable event machinery. + * + * The tls extension indeed suffers from flaws in its channel + * event mgmt. See http://core.tcl.tk/tcl/info/c31ca233ca. + * Until that patch is broadly distributed, disable the + * assertion checking here, so that programs using Tcl and + * tls can be debugged. + + assert(!calledFromAsyncFlush); + */ } } @@ -2716,12 +2949,13 @@ FlushChannel( (statePtr->outQueueHead == NULL) && ((statePtr->curOutPtr == NULL) || IsBufferEmpty(statePtr->curOutPtr))) { - errorCode = CloseChannelPart(interp, chanPtr, errorCode, TCL_CLOSE_WRITE); + errorCode = CloseChannelPart(interp, chanPtr, errorCode, + TCL_CLOSE_WRITE); goto done; } done: - Tcl_Release(chanPtr); + TclChannelRelease((Tcl_Channel)chanPtr); return errorCode; } @@ -2775,7 +3009,7 @@ CloseChannel( */ if (statePtr->curOutPtr != NULL) { - ckfree(statePtr->curOutPtr); + ReleaseChannelBuffer(statePtr->curOutPtr); statePtr->curOutPtr = NULL; } @@ -2838,10 +3072,6 @@ CloseChannel( } Tcl_FreeEncoding(statePtr->encoding); - if (statePtr->outputStage != NULL) { - ckfree(statePtr->outputStage); - statePtr->outputStage = NULL; - } } /* @@ -2891,9 +3121,9 @@ CloseChannel( statePtr->topChanPtr = downChanPtr; downChanPtr->upChanPtr = NULL; - chanPtr->typePtr = NULL; - Tcl_EventuallyFree(chanPtr, TCL_DYNAMIC); + ChannelFree(chanPtr); + return Tcl_Close(interp, (Tcl_Channel) downChanPtr); } @@ -2901,13 +3131,11 @@ CloseChannel( * There is only the TOP Channel, so we free the remaining 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 references. */ - chanPtr->typePtr = NULL; + ChannelFree(chanPtr); Tcl_EventuallyFree(statePtr, TCL_DYNAMIC); - Tcl_EventuallyFree(chanPtr, TCL_DYNAMIC); return errorCode; } @@ -3191,10 +3419,17 @@ Tcl_Close( stickyError = 0; - if ((statePtr->encoding != NULL) && (statePtr->curOutPtr != NULL) - && (CheckChannelErrors(statePtr, TCL_WRITABLE) == 0)) { - statePtr->outputEncodingFlags |= TCL_ENCODING_END; - if (WriteChars(chanPtr, "", 0) < 0) { + if (GotFlag(statePtr, TCL_WRITABLE) && (statePtr->encoding != NULL) + && !(statePtr->outputEncodingFlags & TCL_ENCODING_START)) { + int code = CheckChannelErrors(statePtr, TCL_WRITABLE); + + if (code == 0) { + statePtr->outputEncodingFlags |= TCL_ENCODING_END; + code = WriteChars(chanPtr, "", 0); + statePtr->outputEncodingFlags &= ~TCL_ENCODING_END; + statePtr->outputEncodingFlags |= TCL_ENCODING_START; + } + if (code < 0) { stickyError = Tcl_GetErrno(); } @@ -3229,14 +3464,6 @@ Tcl_Close( ResetFlag(statePtr, CHANNEL_INCLOSE); /* - * Ensure that the last output buffer will be flushed. - */ - - if ((statePtr->curOutPtr != NULL) && IsBufferReady(statePtr->curOutPtr)) { - SetFlag(statePtr, 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. */ @@ -3281,7 +3508,19 @@ Tcl_Close( Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_PosixError(interp), -1)); } - flushcode = -1; + return TCL_ERROR; + } + + /* + * Bug 97069ea11a: set error message if a flush code is set and no error + * message set up to now. + */ + + if (flushcode != 0 && interp != NULL + && 0 == Tcl_GetCharLength(Tcl_GetObjResult(interp))) { + Tcl_SetErrno(flushcode); + Tcl_SetObjResult(interp, + Tcl_NewStringObj(Tcl_PosixError(interp), -1)); } if ((flushcode != 0) || (result != 0)) { return TCL_ERROR; @@ -3373,8 +3612,8 @@ Tcl_CloseEx( } /* - * A user may try to call half-close from within a channel close - * handler. That won't do. + * A user may try to call half-close from within a channel close handler. + * That won't do. */ if (statePtr->flags & CHANNEL_INCLOSE) { @@ -3394,10 +3633,6 @@ Tcl_CloseEx( return CloseChannelPart(interp, chanPtr, 0, flags); } else if (flags & TCL_CLOSE_WRITE) { - if ((statePtr->curOutPtr != NULL) && - IsBufferReady(statePtr->curOutPtr)) { - SetFlag(statePtr, BUFFER_READY); - } Tcl_Preserve(statePtr); if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { /* @@ -3449,9 +3684,12 @@ CloseWrite( * closed. May still be used by some * interpreter */ { - /* Notes: clear-channel-handlers - write side only ? or keep around, just - * not called. */ - /* No close cllbacks are run - channel is still open (read side) */ + /* + * Notes: clear-channel-handlers - write side only ? or keep around, just + * not called. + * + * No close callbacks are run - channel is still open (read side) + */ ChannelState *statePtr = chanPtr->state; /* State of real IO channel. */ @@ -3459,14 +3697,6 @@ CloseWrite( int result = 0; /* - * Ensure that the last output buffer will be flushed. - */ - - if ((statePtr->curOutPtr != NULL) && IsBufferReady(statePtr->curOutPtr)) { - SetFlag(statePtr, BUFFER_READY); - } - - /* * The call to FlushChannel will flush any queued output and invoke the * close function of the channel driver, or it will set up the channel to * be flushed and closed asynchronously. @@ -3484,9 +3714,9 @@ CloseWrite( * Notes: Due to the assertion of CHANNEL_CLOSEDWRITE in the flags * FlushChannel() has called CloseChannelPart(). While we can still access * "chan" (no structures were freed), the only place which may still - * contain a message is the interpreter itself, and "CloseChannelPart" made - * sure to lift any channel message it generated into it. Hence the NULL - * argument in the call below. + * contain a message is the interpreter itself, and "CloseChannelPart" + * made sure to lift any channel message it generated into it. Hence the + * NULL argument in the call below. */ if (TclChanCaughtErrorBypass(interp, NULL)) { @@ -3710,10 +3940,10 @@ Tcl_ClearChannelHandlers( StopCopy(statePtr->csPtrW); /* - * Must set the interest mask now to 0, otherwise infinite loops - * will occur if Tcl_DoOneEvent is called before the channel is - * finally deleted in FlushChannel. This can happen if the channel - * has a background flush active. + * Must set the interest mask now to 0, otherwise infinite loops will + * occur if Tcl_DoOneEvent is called before the channel is finally deleted + * in FlushChannel. This can happen if the channel has a background flush + * active. */ statePtr->interestMask = 0; @@ -3778,7 +4008,10 @@ Tcl_Write( if (srcLen < 0) { srcLen = strlen(src); } - return DoWrite(chanPtr, src, srcLen); + if (WriteBytes(chanPtr, src, srcLen) < 0) { + return -1; + } + return srcLen; } /* @@ -3869,82 +4102,40 @@ Tcl_WriteChars( int len) /* Length of string in bytes, or < 0 for * strlen(). */ { - ChannelState *statePtr; /* State info for channel */ - - statePtr = ((Channel *) chan)->state; + Channel *chanPtr = (Channel *) chan; + ChannelState *statePtr = chanPtr->state; /* State info for channel */ + int result; + Tcl_Obj *objPtr; 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( - 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); } - if (statePtr->encoding == NULL) { - /* - * Inefficient way to convert UTF-8 to byte-array, but the code - * parallels the way it is done for objects. - * Special case for 1-byte (used by eg [puts] for the \n) could - * be extended to more efficient translation of the src string. - */ - - int result; + if (statePtr->encoding) { + return WriteChars(chanPtr, src, len); + } - if ((len == 1) && (UCHAR(*src) < 0xC0)) { - result = WriteBytes(chanPtr, src, len); - } else { - Tcl_Obj *objPtr = Tcl_NewStringObj(src, len); + /* + * Inefficient way to convert UTF-8 to byte-array, but the code + * parallels the way it is done for objects. Special case for 1-byte + * (used by eg [puts] for the \n) could be extended to more efficient + * translation of the src string. + */ - src = (char *) Tcl_GetByteArrayFromObj(objPtr, &len); - result = WriteBytes(chanPtr, src, len); - TclDecrRefCount(objPtr); - } - return result; + if ((len == 1) && (UCHAR(*src) < 0xC0)) { + return WriteBytes(chanPtr, src, len); } - return WriteChars(chanPtr, src, len); + + objPtr = Tcl_NewStringObj(src, len); + src = (char *) Tcl_GetByteArrayFromObj(objPtr, &len); + result = WriteBytes(chanPtr, src, len); + TclDecrRefCount(objPtr); + return result; } /* @@ -4020,12 +4211,27 @@ static int WillRead( Channel *chanPtr) { + if (chanPtr->typePtr == NULL) { + /* + * Prevent read attempts on a closed channel. + */ + + DiscardInputQueued(chanPtr->state, 0); + Tcl_SetErrno(EINVAL); + return -1; + } if ((chanPtr->typePtr->seekProc != NULL) && (Tcl_OutputBuffered((Tcl_Channel) chanPtr) > 0)) { - if ((chanPtr->state->curOutPtr != NULL) - && IsBufferReady(chanPtr->state->curOutPtr)) { - SetFlag(chanPtr->state, BUFFER_READY); - } + /* + * CAVEAT - The assumption here is that FlushChannel() will push out + * the bytes of any writes that are in progress. Since this is a + * seekable channel, we assume it is not one that can block and force + * bg flushing. Channels we know that can do that - sockets, pipes - + * are not seekable. If the assumption is wrong, more drastic measures + * may be required here like temporarily setting the channel into + * blocking mode. + */ + if (FlushChannel(NULL, chanPtr, 0) != 0) { return -1; } @@ -4036,110 +4242,9 @@ WillRead( /* *---------------------------------------------------------------------- * - * WriteBytes -- - * - * Write a sequence of bytes into an output buffer, may queue the buffer - * for output if it gets full, and also remembers whether the current - * buffer is ready e.g. if it contains a newline and we are in line - * buffering mode. - * - * Results: - * 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. + * Write -- * - *---------------------------------------------------------------------- - */ - -static int -WriteBytes( - Channel *chanPtr, /* The channel to buffer output for. */ - const char *src, /* Bytes to write. */ - int srcLen) /* Number of bytes to write. */ -{ - ChannelState *statePtr = chanPtr->state; - /* State info for channel */ - ChannelBuffer *bufPtr; - char *dst; - int dstMax, sawLF, savedLF, total, dstLen, toWrite, translate; - - if (srcLen) { - WillWrite(chanPtr); - } - - total = 0; - sawLF = 0; - savedLF = 0; - translate = GotFlag(statePtr, CHANNEL_LINEBUFFERED) - || (statePtr->outputTranslation != TCL_TRANSLATE_LF); - - /* - * Loop over all bytes in src, storing them in output buffer with proper - * EOL translation. - */ - - while (srcLen + savedLF > 0) { - bufPtr = statePtr->curOutPtr; - if (bufPtr == NULL) { - bufPtr = AllocChannelBuffer(statePtr->bufSize); - statePtr->curOutPtr = bufPtr; - } - dst = InsertPoint(bufPtr); - dstMax = SpaceLeft(bufPtr); - dstLen = dstMax; - - toWrite = dstLen; - if (toWrite > srcLen) { - toWrite = srcLen; - } - - if (translate) { - if (savedLF) { - /* - * A '\n' was left over from last call to TranslateOutputEOL() - * and we need to store it in this buffer. If the channel is - * line-based, we will need to flush it. - */ - - *dst++ = '\n'; - dstLen--; - sawLF++; - } - if (TranslateOutputEOL(statePtr, dst, src, &dstLen, &toWrite)) { - sawLF++; - } - dstLen += savedLF; - savedLF = 0; - if (dstLen > dstMax) { - savedLF = 1; - dstLen = dstMax; - } - } else { - memcpy(dst, src, toWrite); - dstLen = toWrite; - } - - bufPtr->nextAdded += dstLen; - if (CheckFlush(chanPtr, bufPtr, sawLF) != 0) { - return -1; - } - total += dstLen; - src += toWrite; - srcLen -= toWrite; - sawLF = 0; - } - return total; -} - -/* - *---------------------------------------------------------------------- - * - * WriteChars -- - * - * Convert UTF-8 bytes to the channel's external encoding and write the + * Convert srcLen bytes starting at src according to encoding and write * produced bytes into an output buffer, may queue the buffer for output * if it gets full, and also remembers whether the current buffer is * ready e.g. if it contains a newline and we are in line buffering mode. @@ -4156,381 +4261,181 @@ WriteBytes( */ static int -WriteChars( +Write( Channel *chanPtr, /* The channel to buffer output for. */ const char *src, /* UTF-8 string to write. */ - int srcLen) /* Length of UTF-8 string in bytes. */ + int srcLen, /* Length of UTF-8 string in bytes. */ + Tcl_Encoding encoding) { ChannelState *statePtr = chanPtr->state; /* State info for channel */ - ChannelBuffer *bufPtr; - char *dst, *stage; - int saved, savedLF, sawLF, total, dstLen, stageMax, dstWrote; - int stageLen, toWrite, stageRead, endEncoding, result; - int consumedSomething, translate; - Tcl_Encoding encoding; - char safe[BUFFER_PADDING]; + char *nextNewLine = NULL; + int endEncoding, saved = 0, total = 0, flushed = 0, needNlFlush = 0; if (srcLen) { WillWrite(chanPtr); } - total = 0; - sawLF = 0; - savedLF = 0; - saved = 0; - encoding = statePtr->encoding; - /* * Write the terminated escape sequence even if srcLen is 0. */ endEncoding = ((statePtr->outputEncodingFlags & TCL_ENCODING_END) != 0); - translate = GotFlag(statePtr, CHANNEL_LINEBUFFERED) - || (statePtr->outputTranslation != TCL_TRANSLATE_LF); - - /* - * Loop over all UTF-8 characters in src, storing them in staging buffer - * with proper EOL translation. - */ + if (GotFlag(statePtr, CHANNEL_LINEBUFFERED) + || (statePtr->outputTranslation != TCL_TRANSLATE_LF)) { + nextNewLine = memchr(src, '\n', srcLen); + } - consumedSomething = 1; - while (consumedSomething && (srcLen + savedLF + endEncoding > 0)) { - consumedSomething = 0; - stage = statePtr->outputStage; - stageMax = statePtr->bufSize; - stageLen = stageMax; + while (srcLen + saved + endEncoding > 0) { + ChannelBuffer *bufPtr; + char *dst, safe[BUFFER_PADDING]; + int result, srcRead, dstLen, dstWrote, srcLimit = srcLen; - toWrite = stageLen; - if (toWrite > srcLen) { - toWrite = srcLen; + if (nextNewLine) { + srcLimit = nextNewLine - src; } - if (translate) { - if (savedLF) { - /* - * A '\n' was left over from last call to TranslateOutputEOL() - * and we need to store it in the staging buffer. If the - * channel is line-based, we will need to flush the output - * buffer (after translating the staging buffer). - */ - - *stage++ = '\n'; - stageLen--; - sawLF++; - } - if (TranslateOutputEOL(statePtr, stage, src, &stageLen, - &toWrite)) { - sawLF++; - } - - stage -= savedLF; - stageLen += savedLF; - savedLF = 0; - - if (stageLen > stageMax) { - savedLF = 1; - stageLen = stageMax; - } - } else { - memcpy(stage, src, toWrite); - stageLen = toWrite; + /* Get space to write into */ + bufPtr = statePtr->curOutPtr; + if (bufPtr == NULL) { + bufPtr = AllocChannelBuffer(statePtr->bufSize); + statePtr->curOutPtr = bufPtr; } - src += toWrite; - srcLen -= toWrite; - - /* - * Loop over all UTF-8 characters in staging buffer, converting them - * to external encoding, storing them in output buffer. - */ + if (saved) { + /* + * Here's some translated bytes left over from the last buffer + * that we need to stick at the beginning of this buffer. + */ - while (stageLen + saved + endEncoding > 0) { - bufPtr = statePtr->curOutPtr; - if (bufPtr == NULL) { - bufPtr = AllocChannelBuffer(statePtr->bufSize); - statePtr->curOutPtr = bufPtr; - } - dst = InsertPoint(bufPtr); - dstLen = SpaceLeft(bufPtr); + memcpy(InsertPoint(bufPtr), safe, (size_t) saved); + bufPtr->nextAdded += saved; + saved = 0; + } + PreserveChannelBuffer(bufPtr); + dst = InsertPoint(bufPtr); + dstLen = SpaceLeft(bufPtr); - if (saved != 0) { - /* - * Here's some translated bytes left over from the last buffer - * that we need to stick at the beginning of this buffer. - */ + result = Tcl_UtfToExternal(NULL, encoding, src, srcLimit, + statePtr->outputEncodingFlags, + &statePtr->outputEncodingState, dst, + dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL); - memcpy(dst, safe, (size_t) saved); - bufPtr->nextAdded += saved; - dst += saved; - dstLen -= saved; - saved = 0; - } + /* + * See chan-io-1.[89]. Tcl Bug 506297. + */ - result = Tcl_UtfToExternal(NULL, encoding, stage, stageLen, - statePtr->outputEncodingFlags, - &statePtr->outputEncodingState, dst, - dstLen + BUFFER_PADDING, &stageRead, &dstWrote, NULL); + statePtr->outputEncodingFlags &= ~TCL_ENCODING_START; + if ((result != TCL_OK) && (srcRead + 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. - */ + * We're reading from invalid/incomplete UTF-8. + */ - statePtr->outputEncodingFlags &= ~TCL_ENCODING_START; + ReleaseChannelBuffer(bufPtr); + if (total == 0) { + Tcl_SetErrno(EINVAL); + return -1; + } + break; + } - /* - * The following code must be executed only when result is not 0. - */ + bufPtr->nextAdded += dstWrote; + src += srcRead; + srcLen -= srcRead; + total += dstWrote; + dst += dstWrote; + dstLen -= dstWrote; - if ((result != 0) && (stageRead + dstWrote == 0)) { - /* - * We have an incomplete UTF-8 character at the end of the - * staging buffer. It will get moved to the beginning of the - * staging buffer followed by more bytes from src. - */ + if (src == nextNewLine && dstLen > 0) { + static char crln[3] = "\r\n"; + char *nl = NULL; + int nlLen = 0; - src -= stageLen; - srcLen += stageLen; - stageLen = 0; - savedLF = 0; + switch (statePtr->outputTranslation) { + case TCL_TRANSLATE_LF: + nl = crln + 1; + nlLen = 1; + break; + case TCL_TRANSLATE_CR: + nl = crln; + nlLen = 1; + break; + case TCL_TRANSLATE_CRLF: + nl = crln; + nlLen = 2; + break; + default: + Tcl_Panic("unknown output translation requested"); break; } - bufPtr->nextAdded += dstWrote; - if (IsBufferOverflowing(bufPtr)) { - /* - * When translating from UTF-8 to external encoding, we - * allowed the translation to produce a character that crossed - * the end of the output buffer, so that we would get a - * completely full buffer before flushing it. The extra bytes - * will be moved to the beginning of the next buffer. - */ - saved = -SpaceLeft(bufPtr); - memcpy(safe, dst + dstLen, (size_t) saved); - bufPtr->nextAdded = bufPtr->bufLength; - } - if (CheckFlush(chanPtr, bufPtr, sawLF) != 0) { - return -1; - } + result |= Tcl_UtfToExternal(NULL, encoding, nl, nlLen, + statePtr->outputEncodingFlags, + &statePtr->outputEncodingState, dst, + dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL); + assert(srcRead == nlLen); + bufPtr->nextAdded += dstWrote; + src++; + srcLen--; total += dstWrote; - stage += stageRead; - stageLen -= stageRead; - sawLF = 0; - - consumedSomething = 1; + dst += dstWrote; + dstLen -= dstWrote; + nextNewLine = memchr(src, '\n', srcLen); + needNlFlush = 1; + } + if (IsBufferOverflowing(bufPtr)) { /* - * If all translated characters are written to the buffer, - * endEncoding is set to 0 because the escape sequence may be - * output. + * When translating from UTF-8 to external encoding, we allowed + * the translation to produce a character that crossed the end of + * the output buffer, so that we would get a completely full + * buffer before flushing it. The extra bytes will be moved to the + * beginning of the next buffer. */ - if ((stageLen + saved == 0) && (result == 0)) { - endEncoding = 0; - } + saved = -SpaceLeft(bufPtr); + memcpy(safe, dst + dstLen, (size_t) saved); + bufPtr->nextAdded = bufPtr->bufLength; } - } - - /* - * 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; -} - -/* - *--------------------------------------------------------------------------- - * - * TranslateOutputEOL -- - * - * Helper function for WriteBytes() and WriteChars(). Converts the '\n' - * characters in the source buffer into the appropriate EOL form - * specified by the output translation mode. - * - * EOL translation stops either when the source buffer is empty or the - * output buffer is full. - * - * When converting to CRLF mode and there is only 1 byte left in the - * output buffer, this routine stores the '\r' in the last byte and then - * stores the '\n' in the byte just past the end of the buffer. The - * caller is responsible for passing in a buffer that is large enough to - * hold the extra byte. - * - * Results: - * The return value is 1 if a '\n' was translated from the source buffer, - * or 0 otherwise -- this can be used by the caller to decide to flush a - * line-based channel even though the channel buffer is not full. - * - * *dstLenPtr is filled with how many bytes of the output buffer were - * used. As mentioned above, this can be one more that the output - * buffer's specified length if a CRLF was stored. - * - * *srcLenPtr is filled with how many bytes of the source buffer were - * consumed. - * - * Side effects: - * It may be obvious, but bears mentioning that when converting in CRLF - * mode (which requires two bytes of storage in the output buffer), the - * number of bytes consumed from the source buffer will be less than the - * number of bytes stored in the output buffer. - * - *--------------------------------------------------------------------------- - */ - -static int -TranslateOutputEOL( - ChannelState *statePtr, /* Channel being read, for translation and - * buffering modes. */ - char *dst, /* Output buffer filled with UTF-8 chars by - * applying appropriate EOL translation to - * source characters. */ - const char *src, /* Source UTF-8 characters. */ - int *dstLenPtr, /* On entry, the maximum length of output - * buffer in bytes. On exit, the number of - * bytes actually used in output buffer. */ - int *srcLenPtr) /* On entry, the length of source buffer. On - * exit, the number of bytes read from the - * source buffer. */ -{ - char *dstEnd; - int srcLen, newlineFound; - - newlineFound = 0; - srcLen = *srcLenPtr; - - switch (statePtr->outputTranslation) { - case TCL_TRANSLATE_LF: - for (dstEnd = dst + srcLen; dst < dstEnd; ) { - if (*src == '\n') { - newlineFound = 1; - } - *dst++ = *src++; + if ((srcLen + saved == 0) && (result == TCL_OK)) { + endEncoding = 0; } - *dstLenPtr = srcLen; - break; - case TCL_TRANSLATE_CR: - for (dstEnd = dst + srcLen; dst < dstEnd;) { - if (*src == '\n') { - *dst++ = '\r'; - newlineFound = 1; - src++; - } else { - *dst++ = *src++; - } - } - *dstLenPtr = srcLen; - break; - case TCL_TRANSLATE_CRLF: { - /* - * Since this causes the number of bytes to grow, we start off trying - * to put 'srcLen' bytes into the output buffer, but allow it to store - * more bytes, as long as there's still source bytes and room in the - * output buffer. - */ - - char *dstStart, *dstMax; - const char *srcStart; - dstStart = dst; - dstMax = dst + *dstLenPtr; - - srcStart = src; - - if (srcLen < *dstLenPtr) { - dstEnd = dst + srcLen; - } else { - dstEnd = dst + *dstLenPtr; - } - while (dst < dstEnd) { - if (*src == '\n') { - if (dstEnd < dstMax) { - dstEnd++; - } - *dst++ = '\r'; - newlineFound = 1; + if (IsBufferFull(bufPtr)) { + if (FlushChannel(NULL, chanPtr, 0) != 0) { + ReleaseChannelBuffer(bufPtr); + return -1; } - *dst++ = *src++; - } - *srcLenPtr = src - srcStart; - *dstLenPtr = dst - dstStart; - break; - } - default: - break; - } - return newlineFound; -} - -/* - *--------------------------------------------------------------------------- - * - * CheckFlush -- - * - * Helper function for WriteBytes() and WriteChars(). If the channel - * buffer is ready to be flushed, flush it. - * - * Results: - * The return value is -1 if there was a problem flushing the channel - * buffer, or 0 otherwise. - * - * Side effects: - * The buffer will be recycled if it is flushed. - * - *--------------------------------------------------------------------------- - */ - -static int -CheckFlush( - Channel *chanPtr, /* Channel being read, for buffering mode. */ - ChannelBuffer *bufPtr, /* Channel buffer to possibly flush. */ - int newlineFlag) /* Non-zero if a the channel buffer contains a - * newline. */ -{ - ChannelState *statePtr = chanPtr->state; - /* State info for channel */ + flushed += statePtr->bufSize; - /* - * The current buffer is ready for output: - * 1. if it is full. - * 2. if it contains a newline and this channel is line-buffered. - * 3. if it contains any output and this channel is unbuffered. - */ + /* + * We just flushed. So if we have needNlFlush set to record that + * we need to flush because theres a (translated) newline in the + * buffer, that's likely not true any more. But there is a tricky + * exception. If we have saved bytes that did not really get + * flushed and those bytes came from a translation of a newline as + * the last thing taken from the src array, then needNlFlush needs + * to remain set to flag that the next buffer still needs a + * newline flush. + */ - if (!GotFlag(statePtr, BUFFER_READY)) { - if (IsBufferFull(bufPtr)) { - SetFlag(statePtr, BUFFER_READY); - } else if (GotFlag(statePtr, CHANNEL_LINEBUFFERED)) { - if (newlineFlag != 0) { - SetFlag(statePtr, BUFFER_READY); + if (needNlFlush && (saved == 0 || src[-1] != '\n')) { + needNlFlush = 0; } - } else if (GotFlag(statePtr, CHANNEL_UNBUFFERED)) { - SetFlag(statePtr, BUFFER_READY); } + ReleaseChannelBuffer(bufPtr); } - if (GotFlag(statePtr, BUFFER_READY)) { + if ((flushed < total) && (GotFlag(statePtr, CHANNEL_UNBUFFERED) || + (needNlFlush && GotFlag(statePtr, CHANNEL_LINEBUFFERED)))) { if (FlushChannel(NULL, chanPtr, 0) != 0) { return -1; } } - return 0; + + return total; } /* @@ -4612,8 +4517,22 @@ Tcl_GetsObj( Tcl_EncodingState oldState; if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) { - copiedTotal = -1; - goto done; + return -1; + } + + /* + * If we're sitting ready to read the eofchar, there's no need to + * do it. + */ + + if (GotFlag(statePtr, CHANNEL_STICKY_EOF)) { + SetFlag(statePtr, CHANNEL_EOF); + assert(statePtr->inputEncodingFlags & TCL_ENCODING_END); + assert(!GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR)); + + /* TODO: Do we need this? */ + UpdateInterest(chanPtr); + return -1; } /* @@ -4633,6 +4552,7 @@ Tcl_GetsObj( */ chanPtr = statePtr->topChanPtr; + TclChannelPreserve((Tcl_Channel)chanPtr); bufPtr = statePtr->inQueueHead; encoding = statePtr->encoding; @@ -4656,16 +4576,7 @@ Tcl_GetsObj( */ if (encoding == NULL) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - if (tsdPtr->binaryEncoding == NULL) { - tsdPtr->binaryEncoding = Tcl_GetEncoding(NULL, "iso8859-1"); - Tcl_CreateThreadExitHandler(FreeBinaryEncoding, NULL); - } - encoding = tsdPtr->binaryEncoding; - if (encoding == NULL) { - Tcl_Panic("attempted gets on binary channel where no iso8859-1 encoding available"); - } + encoding = GetBinaryEncoding(); } /* @@ -4690,6 +4601,7 @@ Tcl_GetsObj( eof = NULL; inEofChar = statePtr->inEofChar; + ResetFlag(statePtr, CHANNEL_BLOCKED); while (1) { if (dst >= dstEnd) { if (FilterInputBytes(chanPtr, &gs) != 0) { @@ -4781,14 +4693,14 @@ Tcl_GetsObj( * Skip the raw bytes that make up the '\n'. */ - char tmp[1 + TCL_UTF_MAX]; + char tmp[TCL_UTF_MAX]; int rawRead; bufPtr = gs.bufPtr; Tcl_ExternalToUtf(NULL, gs.encoding, RemovePoint(bufPtr), - gs.rawRead, statePtr->inputEncodingFlags, - &gs.state, tmp, 1 + TCL_UTF_MAX, &rawRead, NULL, - NULL); + gs.rawRead, statePtr->inputEncodingFlags + | TCL_ENCODING_NO_TERMINATE, &gs.state, tmp, + TCL_UTF_MAX, &rawRead, NULL, NULL); bufPtr->nextRemoved += rawRead; gs.rawRead -= rawRead; gs.bytesWrote--; @@ -4841,6 +4753,7 @@ Tcl_GetsObj( dstEnd = eof; SetFlag(statePtr, CHANNEL_EOF | CHANNEL_STICKY_EOF); statePtr->inputEncodingFlags |= TCL_ENCODING_END; + ResetFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR); } if (GotFlag(statePtr, CHANNEL_EOF)) { skip = 0; @@ -4854,6 +4767,7 @@ Tcl_GetsObj( Tcl_SetObjLength(objPtr, oldLength); CommonGetsCleanup(chanPtr); copiedTotal = -1; + ResetFlag(statePtr, CHANNEL_BLOCKED); goto done; } goto gotEOL; @@ -4875,7 +4789,11 @@ Tcl_GetsObj( * self-modifying reflected transforms. */ - chanPtr = statePtr->topChanPtr; + if (chanPtr != statePtr->topChanPtr) { + TclChannelRelease((Tcl_Channel)chanPtr); + chanPtr = statePtr->topChanPtr; + TclChannelPreserve((Tcl_Channel)chanPtr); + } bufPtr = gs.bufPtr; if (bufPtr == NULL) { @@ -4883,8 +4801,9 @@ Tcl_GetsObj( } statePtr->inputEncodingState = gs.state; Tcl_ExternalToUtf(NULL, gs.encoding, RemovePoint(bufPtr), gs.rawRead, - statePtr->inputEncodingFlags, &statePtr->inputEncodingState, dst, - eol - dst + skip + TCL_UTF_MAX, &gs.rawRead, NULL, + statePtr->inputEncodingFlags | TCL_ENCODING_NO_TERMINATE, + &statePtr->inputEncodingState, dst, + eol - dst + skip + TCL_UTF_MAX - 1, &gs.rawRead, NULL, &gs.charsWrote); bufPtr->nextRemoved += gs.rawRead; @@ -4909,16 +4828,18 @@ Tcl_GetsObj( * Regenerate the top channel, in case it was changed due to * self-modifying reflected transforms. */ - - chanPtr = statePtr->topChanPtr; - + if (chanPtr != statePtr->topChanPtr) { + TclChannelRelease((Tcl_Channel)chanPtr); + chanPtr = statePtr->topChanPtr; + TclChannelPreserve((Tcl_Channel)chanPtr); + } bufPtr = statePtr->inQueueHead; - if (bufPtr == NULL) { - Tcl_Panic("Tcl_GetsObj: restore reached with bufPtr==NULL"); + if (bufPtr != NULL) { + bufPtr->nextRemoved = oldRemoved; + bufPtr = bufPtr->nextPtr; } - bufPtr->nextRemoved = oldRemoved; - for (bufPtr = bufPtr->nextPtr; bufPtr != NULL; bufPtr = bufPtr->nextPtr) { + for ( ; bufPtr != NULL; bufPtr = bufPtr->nextPtr) { bufPtr->nextRemoved = BUFFER_PADDING; } CommonGetsCleanup(chanPtr); @@ -4947,14 +4868,24 @@ Tcl_GetsObj( */ done: + assert(!GotFlag(statePtr, CHANNEL_EOF) + || GotFlag(statePtr, CHANNEL_STICKY_EOF) + || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); + assert(!(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) + == (CHANNEL_EOF|CHANNEL_BLOCKED))); + /* * Regenerate the top channel, in case it was changed due to * self-modifying reflected transforms. */ - chanPtr = statePtr->topChanPtr; - + if (chanPtr != statePtr->topChanPtr) { + TclChannelRelease((Tcl_Channel)chanPtr); + chanPtr = statePtr->topChanPtr; + TclChannelPreserve((Tcl_Channel)chanPtr); + } UpdateInterest(chanPtr); + TclChannelRelease((Tcl_Channel)chanPtr); return copiedTotal; } @@ -4967,6 +4898,10 @@ Tcl_GetsObj( * end-of-line or end-of-file has been seen. Bytes read from the input * channel return as a ByteArray obj. * + * WARNING! The notion of "binary" used here is different from notions + * of "binary" used in other places. In particular, this "binary" routine + * may be called when an -eofchar is set on the channel. + * * Results: * Number of characters accumulated in the object or -1 if error, * blocked, or EOF. If -1, use Tcl_GetErrno() to retrieve the POSIX error @@ -5000,6 +4935,7 @@ TclGetsObjBinary( */ chanPtr = statePtr->topChanPtr; + TclChannelPreserve((Tcl_Channel)chanPtr); bufPtr = statePtr->inQueueHead; @@ -5027,10 +4963,11 @@ TclGetsObjBinary( eolChar = (statePtr->inputTranslation == TCL_TRANSLATE_LF) ? '\n' : '\r'; + ResetFlag(statePtr, CHANNEL_BLOCKED); while (1) { /* - * Subtract the number of bytes that were removed from channel - * buffer during last call. + * Subtract the number of bytes that were removed from channel buffer + * during last call. */ if (bufPtr != NULL) { @@ -5042,21 +4979,29 @@ TclGetsObjBinary( if ((bufPtr == NULL) || (bufPtr->nextAdded == BUFFER_PADDING)) { /* - * All channel buffers were exhausted and the caller still - * hasn't seen EOL. Need to read more bytes from the channel - * device. Side effect is to allocate another channel buffer. + * All channel buffers were exhausted and the caller still hasn't + * seen EOL. Need to read more bytes from the channel device. Side + * effect is to allocate another channel buffer. */ - if (GotFlag(statePtr, CHANNEL_BLOCKED)) { - if (GotFlag(statePtr, CHANNEL_NONBLOCKING)) { - goto restore; - } - ResetFlag(statePtr, CHANNEL_BLOCKED); - } if (GetInput(chanPtr) != 0) { goto restore; } bufPtr = statePtr->inQueueTail; + if (bufPtr == NULL) { + goto restore; + } + } else { + /* + * Incoming CHANNEL_STICKY_EOF is filtered out on entry. A new + * CHANNEL_STICKY_EOF set in this routine leads to return before + * coming back here. When we are not dealing with + * CHANNEL_STICKY_EOF, a CHANNEL_EOF implies an empty buffer. + * Here the buffer is non-empty so we know we're a non-EOF. + */ + + assert(!GotFlag(statePtr, CHANNEL_STICKY_EOF)); + assert(!GotFlag(statePtr, CHANNEL_EOF)); } dst = (unsigned char *) RemovePoint(bufPtr); @@ -5098,6 +5043,7 @@ TclGetsObjBinary( SetFlag(statePtr, CHANNEL_EOF | CHANNEL_STICKY_EOF); statePtr->inputEncodingFlags |= TCL_ENCODING_END; + ResetFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR); } if (GotFlag(statePtr, CHANNEL_EOF)) { skip = 0; @@ -5111,14 +5057,19 @@ TclGetsObjBinary( byteArray = Tcl_SetByteArrayLength(objPtr, oldLength); CommonGetsCleanup(chanPtr); copiedTotal = -1; + ResetFlag(statePtr, CHANNEL_BLOCKED); goto done; } goto gotEOL; } + if (GotFlag(statePtr, CHANNEL_BLOCKED|CHANNEL_NONBLOCKING) + == (CHANNEL_BLOCKED|CHANNEL_NONBLOCKING)) { + goto restore; + } /* - * Copy bytes from the channel buffer to the ByteArray. - * This may realloc space, so keep track of result. + * Copy bytes from the channel buffer to the ByteArray. This may + * realloc space, so keep track of result. */ rawLen = dstEnd - dst; @@ -5169,12 +5120,12 @@ TclGetsObjBinary( restore: bufPtr = statePtr->inQueueHead; - if (bufPtr == NULL) { - Tcl_Panic("TclGetsObjBinary: restore reached with bufPtr==NULL"); + if (bufPtr) { + bufPtr->nextRemoved = oldRemoved; + bufPtr = bufPtr->nextPtr; } - bufPtr->nextRemoved = oldRemoved; - for (bufPtr = bufPtr->nextPtr; bufPtr != NULL; bufPtr = bufPtr->nextPtr) { + for ( ; bufPtr != NULL; bufPtr = bufPtr->nextPtr) { bufPtr->nextRemoved = BUFFER_PADDING; } CommonGetsCleanup(chanPtr); @@ -5202,7 +5153,13 @@ TclGetsObjBinary( */ done: + assert(!GotFlag(statePtr, CHANNEL_EOF) + || GotFlag(statePtr, CHANNEL_STICKY_EOF) + || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); + assert(!(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) + == (CHANNEL_EOF|CHANNEL_BLOCKED))); UpdateInterest(chanPtr); + TclChannelRelease((Tcl_Channel)chanPtr); return copiedTotal; } @@ -5231,6 +5188,21 @@ FreeBinaryEncoding( tsdPtr->binaryEncoding = NULL; } } + +static Tcl_Encoding +GetBinaryEncoding() +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + if (tsdPtr->binaryEncoding == NULL) { + tsdPtr->binaryEncoding = Tcl_GetEncoding(NULL, "iso8859-1"); + Tcl_CreateThreadExitHandler(FreeBinaryEncoding, NULL); + } + if (tsdPtr->binaryEncoding == NULL) { + Tcl_Panic("binary encoding is not available"); + } + return tsdPtr->binaryEncoding; +} /* *--------------------------------------------------------------------------- @@ -5264,7 +5236,7 @@ FilterInputBytes( ChannelState *statePtr = chanPtr->state; /* State info for channel */ ChannelBuffer *bufPtr; - char *raw, *rawStart, *dst; + char *raw, *dst; int offset, toRead, dstNeeded, spaceLeft, result, rawLen; Tcl_Obj *objPtr; #define ENCODING_LINESIZE 20 /* Lower bound on how many bytes to convert at @@ -5298,13 +5270,11 @@ FilterInputBytes( */ read: - if (GotFlag(statePtr, CHANNEL_BLOCKED)) { - if (GotFlag(statePtr, CHANNEL_NONBLOCKING)) { - gsPtr->charsWrote = 0; - gsPtr->rawRead = 0; - return -1; - } - ResetFlag(statePtr, CHANNEL_BLOCKED); + if (GotFlag(statePtr, CHANNEL_NONBLOCKING|CHANNEL_BLOCKED) + == (CHANNEL_NONBLOCKING|CHANNEL_BLOCKED)) { + gsPtr->charsWrote = 0; + gsPtr->rawRead = 0; + return -1; } if (GetInput(chanPtr) != 0) { gsPtr->charsWrote = 0; @@ -5313,6 +5283,22 @@ FilterInputBytes( } bufPtr = statePtr->inQueueTail; gsPtr->bufPtr = bufPtr; + if (bufPtr == NULL) { + gsPtr->charsWrote = 0; + gsPtr->rawRead = 0; + return -1; + } + } else { + /* + * Incoming CHANNEL_STICKY_EOF is filtered out on entry. A new + * CHANNEL_STICKY_EOF set in this routine leads to return before + * coming back here. When we are not dealing with CHANNEL_STICKY_EOF, + * a CHANNEL_EOF implies an empty buffer. Here the buffer is + * non-empty so we know we're a non-EOF. + */ + + assert(!GotFlag(statePtr, CHANNEL_STICKY_EOF)); + assert(!GotFlag(statePtr, CHANNEL_EOF)); } /* @@ -5321,8 +5307,7 @@ FilterInputBytes( * string rep if we need more space. */ - rawStart = RemovePoint(bufPtr); - raw = rawStart; + raw = RemovePoint(bufPtr); rawLen = BytesLeft(bufPtr); dst = *gsPtr->dstPtr; @@ -5350,9 +5335,9 @@ FilterInputBytes( } gsPtr->state = statePtr->inputEncodingState; result = Tcl_ExternalToUtf(NULL, gsPtr->encoding, raw, rawLen, - statePtr->inputEncodingFlags, &statePtr->inputEncodingState, - dst, spaceLeft+1, &gsPtr->rawRead, &gsPtr->bytesWrote, - &gsPtr->charsWrote); + statePtr->inputEncodingFlags | TCL_ENCODING_NO_TERMINATE, + &statePtr->inputEncodingState, dst, spaceLeft, &gsPtr->rawRead, + &gsPtr->bytesWrote, &gsPtr->charsWrote); /* * Make sure that if we go through 'gets', that we reset the @@ -5389,7 +5374,7 @@ FilterInputBytes( } else { /* * There are no more cached raw bytes left. See if we can get - * some more. + * some more, but avoid blocking on a non-blocking channel. */ goto read; @@ -5630,134 +5615,96 @@ Tcl_Read( int Tcl_ReadRaw( Tcl_Channel chan, /* The channel from which to read. */ - char *bufPtr, /* Where to store input read. */ + char *readBuf, /* Where to store input read. */ int bytesToRead) /* Maximum number of bytes to read. */ { Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; /* State info for channel */ - int nread, result, copied, copiedNow; - - /* - * The check below does too much because it will reject a call to this - * function with a channel which is part of an 'fcopy'. But we have to - * allow this here or else the chaining in the transformation drivers will - * fail with 'file busy' error instead of retrieving and transforming the - * data to copy. - * - * We let the check procedure now believe that there is no fcopy in - * progress. A better solution than this might be an additional flag - * argument to switch off specific checks. - */ + int copied = 0; + assert(bytesToRead > 0); if (CheckChannelErrors(statePtr, TCL_READABLE | CHANNEL_RAW_MODE) != 0) { return -1; } /* - * Check for information in the push-back buffers. If there is some, use - * it. Go to the driver only if there is none (anymore) and the caller - * requests more bytes. + * First read bytes from the push-back buffers. */ - for (copied = 0; copied < bytesToRead; copied += copiedNow) { - copiedNow = CopyBuffer(chanPtr, bufPtr + copied, - bytesToRead - copied); - if (copiedNow == 0) { - if (GotFlag(statePtr, CHANNEL_EOF)) { - goto done; - } - if (GotFlag(statePtr, CHANNEL_BLOCKED)) { - if (GotFlag(statePtr, CHANNEL_NONBLOCKING)) { - goto done; - } - ResetFlag(statePtr, CHANNEL_BLOCKED); - } + while (chanPtr->inQueueHead && bytesToRead > 0) { + ChannelBuffer *bufPtr = chanPtr->inQueueHead; + int bytesInBuffer = BytesLeft(bufPtr); + int toCopy = (bytesInBuffer < bytesToRead) ? bytesInBuffer + : bytesToRead; -#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING - /* - * [Bug 943274]. Better emulation of non-blocking channels for - * channels without BlockModeProc, by keeping track of true - * fileevents generated by the OS == Data waiting and reading if - * and only if we are sure to have data. - */ + /* + * Copy the current chunk into the read buffer. + */ - if (GotFlag(statePtr, CHANNEL_NONBLOCKING) && - (Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL) && - !GotFlag(statePtr, CHANNEL_HAS_MORE_DATA)) { - /* - * We bypass the driver; it would block as no data is - * available. - */ + memcpy(readBuf, RemovePoint(bufPtr), (size_t) toCopy); + bufPtr->nextRemoved += toCopy; + copied += toCopy; + readBuf += toCopy; + bytesToRead -= toCopy; - nread = -1; - result = EWOULDBLOCK; - } else -#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ - { - /* - * Now go to the driver to get as much as is possible to fill - * the remaining request. Do all the error handling by - * ourselves. The code was stolen from 'GetInput' and slightly - * adapted (different return value here). - * - * The case of 'bytesToRead == 0' at this point cannot happen. - */ + /* + * If the current buffer is empty recycle it. + */ - nread = ChanRead(chanPtr, bufPtr + copied, - bytesToRead - copied, &result); + if (IsBufferEmpty(bufPtr)) { + chanPtr->inQueueHead = bufPtr->nextPtr; + if (chanPtr->inQueueHead == NULL) { + chanPtr->inQueueTail = NULL; } + RecycleBuffer(chanPtr->state, bufPtr, 0); + } + } - if (nread > 0) { - /* - * If we get a short read, signal up that we may be BLOCKED. - * We should avoid calling the driver because on some - * platforms we will block in the low level reading code even - * though the channel is set into nonblocking mode. - */ + /* + * Go to the driver only if we got nothing from pushback. Have to do it + * this way to avoid EOF mis-timings when we consider the ability that EOF + * may not be a permanent condition in the driver, and in that case we + * have to synchronize. + */ - if (nread < (bytesToRead - copied)) { - SetFlag(statePtr, CHANNEL_BLOCKED); - } + if (copied) { + return copied; + } -#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING - if (nread <= (bytesToRead - copied)) { - /* - * [Bug 943274] We have read the available data, clear - * flag. - */ + /* + * This test not needed. + */ - ResetFlag(statePtr, CHANNEL_HAS_MORE_DATA); - } -#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ - } else if (nread == 0) { - SetFlag(statePtr, CHANNEL_EOF); - statePtr->inputEncodingFlags |= TCL_ENCODING_END; - - } else if (nread < 0) { - if ((result == EWOULDBLOCK) || (result == EAGAIN)) { - if (copied > 0) { - /* - * Information that was copied earlier has precedence - * over EAGAIN/WOULDBLOCK handling. - */ + if (bytesToRead > 0) { + int nread = ChanRead(chanPtr, readBuf, bytesToRead); - return copied; - } + if (nread > 0) { + /* + * Successful read (short is OK) - add to bytes copied. + */ - SetFlag(statePtr, CHANNEL_BLOCKED); - result = EAGAIN; - } + copied += nread; + } else if (nread < 0) { + /* + * An error signaled. If CHANNEL_BLOCKED, then the error is not + * real, but an indication of blocked state. In that case, retain + * the flag and let caller receive the short read of copied bytes + * from the pushback. HOWEVER, if copied==0 bytes from pushback + * then repeat signalling the blocked state as an error to caller + * so there is no false report of an EOF. When !CHANNEL_BLOCKED, + * the error is real and passes on to caller. + */ - Tcl_SetErrno(result); - return -1; + if (!GotFlag(statePtr, CHANNEL_BLOCKED) || copied == 0) { + copied = -1; } - - return copied + nread; + } else { + /* + * nread == 0. Driver is at EOF. Let that state filter up. + */ } } - - done: return copied; } @@ -5854,20 +5801,18 @@ DoReadChars( ChannelState *statePtr = chanPtr->state; /* State info for channel */ ChannelBuffer *bufPtr; - int offset, factor, copied, copiedNow, result; - Tcl_Encoding encoding; + int copied, copiedNow, result; + Tcl_Encoding encoding = statePtr->encoding; + int binaryMode; #define UTF_EXPANSION_FACTOR 1024 + int factor = UTF_EXPANSION_FACTOR; - /* - * This operation should occur at the top of a channel stack. - */ - - chanPtr = statePtr->topChanPtr; - encoding = statePtr->encoding; - factor = UTF_EXPANSION_FACTOR; + binaryMode = (encoding == NULL) + && (statePtr->inputTranslation == TCL_TRANSLATE_LF) + && (statePtr->inEofChar == '\0'); if (appendFlag == 0) { - if (encoding == NULL) { + if (binaryMode) { Tcl_SetByteArrayLength(objPtr, 0); } else { Tcl_SetObjLength(objPtr, 0); @@ -5876,27 +5821,68 @@ DoReadChars( * We're going to access objPtr->bytes directly, so we must ensure * that this is actually a string object (otherwise it might have * been pure Unicode). + * + * Probably not needed anymore. */ TclGetString(objPtr); } - offset = 0; - } else { - if (encoding == NULL) { - Tcl_GetByteArrayFromObj(objPtr, &offset); - } else { - TclGetStringFromObj(objPtr, &offset); + } + + /* + * Early out when next read will see eofchar. + * + * NOTE: See DoRead for argument that it's a bug (one we're keeping) to + * have this escape before the one for zero-char read request. + */ + + if (GotFlag(statePtr, CHANNEL_STICKY_EOF)) { + SetFlag(statePtr, CHANNEL_EOF); + assert(statePtr->inputEncodingFlags & TCL_ENCODING_END); + assert(!GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR)); + + /* TODO: We don't need this call? */ + UpdateInterest(chanPtr); + return 0; + } + + /* + * Special handling for zero-char read request. + */ + if (toRead == 0) { + if (GotFlag(statePtr, CHANNEL_EOF)) { + statePtr->inputEncodingFlags |= TCL_ENCODING_START; } + ResetFlag(statePtr, CHANNEL_BLOCKED|CHANNEL_EOF); + statePtr->inputEncodingFlags &= ~TCL_ENCODING_END; + /* TODO: We don't need this call? */ + UpdateInterest(chanPtr); + return 0; } + /* + * This operation should occur at the top of a channel stack. + */ + + chanPtr = statePtr->topChanPtr; + TclChannelPreserve((Tcl_Channel)chanPtr); + + /* + * Must clear the BLOCKED|EOF flags here since we check before reading. + */ + + if (GotFlag(statePtr, CHANNEL_EOF)) { + statePtr->inputEncodingFlags |= TCL_ENCODING_START; + } + ResetFlag(statePtr, CHANNEL_BLOCKED|CHANNEL_EOF); + statePtr->inputEncodingFlags &= ~TCL_ENCODING_END; for (copied = 0; (unsigned) toRead > 0; ) { copiedNow = -1; if (statePtr->inQueueHead != NULL) { - if (encoding == NULL) { - copiedNow = ReadBytes(statePtr, objPtr, toRead, &offset); + if (binaryMode) { + copiedNow = ReadBytes(statePtr, objPtr, toRead); } else { - copiedNow = ReadChars(statePtr, objPtr, toRead, &offset, - &factor); + copiedNow = ReadChars(statePtr, objPtr, toRead, &factor); } /* @@ -5919,19 +5905,21 @@ DoReadChars( if (GotFlag(statePtr, CHANNEL_EOF)) { break; } - if (GotFlag(statePtr, CHANNEL_BLOCKED)) { - if (GotFlag(statePtr, CHANNEL_NONBLOCKING)) { - break; - } - ResetFlag(statePtr, CHANNEL_BLOCKED); + if (GotFlag(statePtr, CHANNEL_NONBLOCKING|CHANNEL_BLOCKED) + == (CHANNEL_NONBLOCKING|CHANNEL_BLOCKED)) { + break; } result = GetInput(chanPtr); + if (chanPtr != statePtr->topChanPtr) { + TclChannelRelease((Tcl_Channel)chanPtr); + chanPtr = statePtr->topChanPtr; + TclChannelPreserve((Tcl_Channel)chanPtr); + } if (result != 0) { - if (result == EAGAIN) { - break; + if (!GotFlag(statePtr, CHANNEL_BLOCKED)) { + copied = -1; } - copied = -1; - goto done; + break; } } else { copied += copiedNow; @@ -5939,27 +5927,39 @@ DoReadChars( } } - ResetFlag(statePtr, CHANNEL_BLOCKED); - if (encoding == NULL) { - Tcl_SetByteArrayLength(objPtr, offset); - } else { - Tcl_SetObjLength(objPtr, offset); - } - /* - * Update the notifier state so we don't block while there is still data - * in the buffers. + * Failure to fill a channel buffer may have left channel reporting a + * "blocked" state, but so long as we fulfilled the request here, the + * caller does not consider us blocked. */ - done: + if (toRead == 0) { + ResetFlag(statePtr, CHANNEL_BLOCKED); + } + /* * Regenerate the top channel, in case it was changed due to * self-modifying reflected transforms. */ - chanPtr = statePtr->topChanPtr; + if (chanPtr != statePtr->topChanPtr) { + TclChannelRelease((Tcl_Channel)chanPtr); + chanPtr = statePtr->topChanPtr; + TclChannelPreserve((Tcl_Channel)chanPtr); + } + + /* + * Update the notifier state so we don't block while there is still data + * in the buffers. + */ + assert(!GotFlag(statePtr, CHANNEL_EOF) + || GotFlag(statePtr, CHANNEL_STICKY_EOF) + || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); + assert(!(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) + == (CHANNEL_EOF|CHANNEL_BLOCKED))); UpdateInterest(chanPtr); + TclChannelRelease((Tcl_Channel)chanPtr); return copied; } @@ -5977,13 +5977,11 @@ DoReadChars( * allocated to hold data read from the channel as needed. * * Results: - * The return value is the number of bytes appended to the object and - * *offsetPtr is filled with the total number of bytes in the object - * (greater than the return value if there were already bytes in the - * object). + * The return value is the number of bytes appended to the object, or + * -1 to indicate that zero bytes were read due to an EOF. * * Side effects: - * None. + * The storage of bytes in objPtr can cause (re-)allocation of memory. * *--------------------------------------------------------------------------- */ @@ -5996,72 +5994,22 @@ ReadBytes( * 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 + 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, offset, length, srcRead, dstWrote; - ChannelBuffer *bufPtr; - char *src, *dst; - - offset = *offsetPtr; - - bufPtr = statePtr->inQueueHead; - src = RemovePoint(bufPtr); - srcLen = BytesLeft(bufPtr); - - toRead = bytesToRead; - if ((unsigned) toRead > (unsigned) srcLen) { - toRead = srcLen; - } - - dst = (char *) Tcl_GetByteArrayFromObj(objPtr, &length); - if (toRead > length - offset - 1) { - /* - * Double the existing size of the object or make enough room to hold - * all the characters we may get from the source buffer, whichever is - * larger. - */ - - length = offset * 2; - if (offset < toRead) { - length = offset + toRead + 1; - } - dst = (char *) Tcl_SetByteArrayLength(objPtr, length); - } - dst += offset; - - if (GotFlag(statePtr, INPUT_NEED_NL)) { - ResetFlag(statePtr, INPUT_NEED_NL); - if ((srcLen == 0) || (*src != '\n')) { - *dst = '\r'; - *offsetPtr += 1; - return 1; - } - *dst++ = '\n'; - src++; - srcLen--; - toRead--; - } + ChannelBuffer *bufPtr = statePtr->inQueueHead; + int srcLen = BytesLeft(bufPtr); + int toRead = bytesToRead>srcLen || bytesToRead<0 ? srcLen : bytesToRead; - srcRead = srcLen; - dstWrote = toRead; - if (TranslateInputEOL(statePtr, dst, src, &dstWrote, &srcRead) != 0) { - if (dstWrote == 0) { - return -1; - } - } - bufPtr->nextRemoved += srcRead; - *offsetPtr += dstWrote; - return dstWrote; + TclAppendBytesToByteArray(objPtr, (unsigned char *) RemovePoint(bufPtr), + toRead); + bufPtr->nextRemoved += toRead; + return toRead; } /* @@ -6105,35 +6053,34 @@ ReadChars( * is larger than the number of characters * available in the first buffer, only the * characters 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. */ + * returned. The execption is when there is + * not any complete character in the first + * buffer. In that case, a recursive call + * effectively obtains chars from the + * second buffer. */ int *factorPtr) /* On input, contains a guess of how many * bytes need to be allocated to hold the * result of converting N source bytes to * UTF-8. On output, contains another guess * based on the data seen so far. */ { - int toRead, factor, offset, spaceLeft, srcLen, dstNeeded; - int srcRead, dstWrote, numChars, dstRead; - ChannelBuffer *bufPtr; - char *src, *dst; - Tcl_EncodingState oldState; - int encEndFlagSuppressed = 0; + Tcl_Encoding encoding = statePtr->encoding? statePtr->encoding + : GetBinaryEncoding(); + Tcl_EncodingState savedState = statePtr->inputEncodingState; + ChannelBuffer *bufPtr = statePtr->inQueueHead; + int savedIEFlags = statePtr->inputEncodingFlags; + int savedFlags = statePtr->flags; + char *dst, *src = RemovePoint(bufPtr); + int numBytes, srcLen = BytesLeft(bufPtr); - factor = *factorPtr; - offset = *offsetPtr; - - bufPtr = statePtr->inQueueHead; - src = RemovePoint(bufPtr); - srcLen = BytesLeft(bufPtr); + /* + * One src byte can yield at most one character. So when the number of + * src bytes we plan to read is less than the limit on character count to + * be read, clearly we will remain within that limit, and we can use the + * value of "srcLen" as a tighter limit for sizing receiving buffers. + */ - toRead = charsToRead; - if ((unsigned) toRead > (unsigned) srcLen) { - toRead = srcLen; - } + int toRead = ((charsToRead<0)||(charsToRead > srcLen)) ? srcLen : charsToRead; /* * 'factor' is how much we guess that the bytes in the source buffer will @@ -6141,226 +6088,331 @@ ReadChars( * how many characters were produced by the previous pass. */ - dstNeeded = TCL_UTF_MAX - 1 + toRead * factor / UTF_EXPANSION_FACTOR; - spaceLeft = objPtr->length - offset; - - if (dstNeeded > spaceLeft) { - /* - * Double the existing size of the object or make enough room to hold - * all the characters we want from the source buffer, whichever is - * larger. - */ - - int length = offset + ((offset < dstNeeded) ? dstNeeded : offset); + int factor = *factorPtr; + int dstLimit = TCL_UTF_MAX - 1 + toRead * factor / UTF_EXPANSION_FACTOR; - if (Tcl_AttemptSetObjLength(objPtr, length) == 0) { - length = offset + dstNeeded; - if (Tcl_AttemptSetObjLength(objPtr, length) == 0) { - dstNeeded = TCL_UTF_MAX - 1 + toRead; - length = offset + dstNeeded; - Tcl_SetObjLength(objPtr, length); - } - } - spaceLeft = length - offset; - } + (void) TclGetStringFromObj(objPtr, &numBytes); + Tcl_AppendToObj(objPtr, NULL, dstLimit); if (toRead == srcLen) { - /* - * Want to convert the whole buffer in one pass. If we have enough - * space, convert it using all available space in object rather than - * using the factor. - */ + unsigned int size; - dstNeeded = spaceLeft; + dst = TclGetStringStorage(objPtr, &size) + numBytes; + dstLimit = size - numBytes; + } else { + dst = TclGetString(objPtr) + numBytes; } - dst = objPtr->bytes + offset; /* - * [Bug 1462248]: The cause of the crash reported in this bug is this: - * - * - ReadChars, called with a single buffer, with a incomplete - * multi-byte character at the end (only the first byte of it). - * - Encoding translation fails, asks for more data - * - Data is read, and eof is reached, TCL_ENCODING_END (TEE) is set. - * - ReadChar is called again, converts the first buffer, but due to TEE - * it does not check for incomplete multi-byte data, and the character - * just after the end of the first buffer is a valid completion of the - * multi-byte header in the actual buffer. The conversion reads more - * characters from the buffer then present. This causes nextRemoved to - * overshoot nextAdded and the next reads compute a negative srcLen, - * cause further translations to fail, causing copying of data into the - * next buffer using bad arguments, causing the mecpy for to eventually - * fail. - * - * In the end it is a memory access bug spiraling out of control if the - * conditions are _just so_. And ultimate cause is that TEE is given to a - * conversion where it should not. TEE signals that this is the last - * buffer. Except in our case it is not. + * This routine is burdened with satisfying several constraints. It cannot + * append more than 'charsToRead` chars onto objPtr. This is measured + * after encoding and translation transformations are completed. There is + * no precise number of src bytes that can be associated with the limit. + * Yet, when we are done, we must know precisely the number of src bytes + * that were consumed to produce the appended chars, so that all + * subsequent bytes are left in the buffers for future read operations. * - * My solution is to suppress TEE if the first buffer is not the last. We - * will eventually need it given that EOF has been reached, but not right - * now. This is what the new flag "endEncSuppressFlag" is for. - * - * The bug in 'Tcl_Utf2UtfProc' where it read from memory behind the - * actual buffer has been fixed as well, and fixes the problem with the - * crash too, but this would still allow the generic layer to - * accidentially break a multi-byte sequence if the conditions are just - * right, because again the ExternalToUtf would be successful where it - * should not. + * The consequence is that we have no choice but to implement a "trial and + * error" approach, where in general we may need to perform + * transformations and copies multiple times to achieve a consistent set + * of results. This takes the shape of a loop. */ - if ((statePtr->inputEncodingFlags & TCL_ENCODING_END) && - (bufPtr->nextPtr != NULL)) { + while (1) { + int dstDecoded, dstRead, dstWrote, srcRead, numChars, code; + int flags = statePtr->inputEncodingFlags | TCL_ENCODING_NO_TERMINATE; + + if (charsToRead > 0) { + flags |= TCL_ENCODING_CHAR_LIMIT; + numChars = charsToRead; + } + /* - * TEE is set for a buffer which is not the last. Squash it for now, - * and restore it later, before yielding control to our caller. + * Perform the encoding transformation. Read no more than srcLen + * bytes, write no more than dstLimit bytes. + * + * Some trickiness with encoding flags here. We do not want the end + * of a buffer to be treated as the end of all input when the presence + * of bytes in a next buffer are already known to exist. This is + * checked with an assert() because so far no test case causing the + * assertion to be false has been created. The normal operations of + * channel reading appear to cause EOF and TCL_ENCODING_END setting to + * appear only in situations where there are no further bytes in any + * buffers. */ - statePtr->inputEncodingFlags &= ~TCL_ENCODING_END; - encEndFlagSuppressed = 1; - } + assert(bufPtr->nextPtr == NULL || BytesLeft(bufPtr->nextPtr) == 0 + || (statePtr->inputEncodingFlags & TCL_ENCODING_END) == 0); + + code = Tcl_ExternalToUtf(NULL, encoding, src, srcLen, + flags, &statePtr->inputEncodingState, + dst, dstLimit, &srcRead, &dstDecoded, &numChars); - oldState = statePtr->inputEncodingState; - if (GotFlag(statePtr, INPUT_NEED_NL)) { /* - * We want a '\n' because the last character we saw was '\r'. + * Perform the translation transformation in place. Read no more than + * the dstDecoded bytes the encoding transformation actually produced. + * Capture the number of bytes written in dstWrote. Capture the number + * of bytes actually consumed in dstRead. */ - ResetFlag(statePtr, INPUT_NEED_NL); - Tcl_ExternalToUtf(NULL, statePtr->encoding, src, srcLen, - statePtr->inputEncodingFlags, &statePtr->inputEncodingState, - dst, TCL_UTF_MAX + 1, &srcRead, &dstWrote, &numChars); - if ((dstWrote > 0) && (*dst == '\n')) { + dstWrote = dstLimit; + dstRead = dstDecoded; + TranslateInputEOL(statePtr, dst, dst, &dstWrote, &dstRead); + + if (dstRead < dstDecoded) { /* - * The next char was a '\n'. Consume it and produce a '\n'. + * The encoding transformation produced bytes that the translation + * transformation did not consume. Why did this happen? */ - bufPtr->nextRemoved += srcRead; - } else { + if (statePtr->inEofChar && dst[dstRead] == statePtr->inEofChar) { + /* + * 1) There's an eof char set on the channel, and + * we saw it and stopped translating at that point. + * + * NOTE the bizarre spec of TranslateInputEOL in this case. + * Clearly the eof char had to be read in order to account for + * the stopping, but the value of dstRead does not include it. + * + * Also rather bizarre, our caller can only notice an EOF + * condition if we return the value -1 as the number of chars + * read. This forces us to perform a 2-call dance where the + * first call can read all the chars up to the eof char, and + * the second call is solely for consuming the encoded eof + * char then pointed at by src so that we can return that + * magic -1 value. This seems really wasteful, especially + * since the first decoding pass of each call is likely to + * decode many bytes beyond that eof char that's all we care + * about. + */ + + if (dstRead == 0) { + /* + * Curious choice in the eof char handling. We leave the + * eof char in the buffer. So, no need to compute a proper + * srcRead value. At this point, there are no chars before + * the eof char in the buffer. + */ + + Tcl_SetObjLength(objPtr, numBytes); + return -1; + } + + { + /* + * There are chars leading the buffer before the eof char. + * Adjust the dstLimit so we go back and read only those + * and do not encounter the eof char this time. + */ + + dstLimit = dstRead - 1 + TCL_UTF_MAX; + statePtr->flags = savedFlags; + statePtr->inputEncodingFlags = savedIEFlags; + statePtr->inputEncodingState = savedState; + continue; + } + } + /* - * The next char was not a '\n'. Produce a '\r'. + * 2) The other way to read fewer bytes than are decoded is when + * the final byte is \r and we're in a CRLF translation mode so + * we cannot decide whether to record \r or \n yet. */ - *dst = '\r'; - } - statePtr->inputEncodingFlags &= ~TCL_ENCODING_START; - *offsetPtr += 1; + assert(dst[dstRead] == '\r'); + assert(statePtr->inputTranslation == TCL_TRANSLATE_CRLF); - if (encEndFlagSuppressed) { - statePtr->inputEncodingFlags |= TCL_ENCODING_END; - } - return 1; - } + if (dstWrote > 0) { + /* + * There are chars we can read before we hit the bare CR. Go + * back with a smaller dstLimit so we get them in the next + * pass, compute a matching srcRead, and don't end up back + * here in this call. + */ - Tcl_ExternalToUtf(NULL, statePtr->encoding, src, srcLen, - statePtr->inputEncodingFlags, &statePtr->inputEncodingState, dst, - dstNeeded + 1, &srcRead, &dstWrote, &numChars); + dstLimit = dstRead - 1 + TCL_UTF_MAX; + statePtr->flags = savedFlags; + statePtr->inputEncodingFlags = savedIEFlags; + statePtr->inputEncodingState = savedState; + continue; + } - if (encEndFlagSuppressed) { - statePtr->inputEncodingFlags |= TCL_ENCODING_END; - } + assert(dstWrote == 0); + assert(dstRead == 0); - if (srcRead == 0) { - /* - * Not enough bytes in src buffer to make a complete char. Copy the - * bytes to the next buffer to make a new contiguous string, then tell - * the caller to fill the buffer with more bytes. - */ + /* + * We decoded only the bare CR, and we cannot read a translated + * char from that alone. We have to know what's next. So why do + * we only have the one decoded char? + */ - ChannelBuffer *nextPtr; + if (code != TCL_OK) { + char buffer[TCL_UTF_MAX + 1]; + int read, decoded, count; - nextPtr = bufPtr->nextPtr; - if (nextPtr == NULL) { - 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. [Bug 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. + * Didn't get everything the buffer could offer + */ + + statePtr->flags = savedFlags; + statePtr->inputEncodingFlags = savedIEFlags; + statePtr->inputEncodingState = savedState; + + assert(bufPtr->nextPtr == NULL + || BytesLeft(bufPtr->nextPtr) == 0 || 0 == + (statePtr->inputEncodingFlags & TCL_ENCODING_END)); + + Tcl_ExternalToUtf(NULL, encoding, src, srcLen, + (statePtr->inputEncodingFlags | TCL_ENCODING_NO_TERMINATE), + &statePtr->inputEncodingState, buffer, TCL_UTF_MAX + 1, + &read, &decoded, &count); + + if (count == 2) { + if (buffer[1] == '\n') { + /* \r\n translate to \n */ + dst[0] = '\n'; + bufPtr->nextRemoved += read; + } else { + dst[0] = '\r'; + bufPtr->nextRemoved += srcRead; + } + + statePtr->inputEncodingFlags &= ~TCL_ENCODING_START; + + Tcl_SetObjLength(objPtr, numBytes + 1); + return 1; + } + + } else if (statePtr->flags & CHANNEL_EOF) { + /* + * The bare \r is the only char and we will never read a + * subsequent char to make the determination. */ - SetFlag(statePtr, CHANNEL_NEED_MORE_DATA); + dst[0] = '\r'; + bufPtr->nextRemoved = bufPtr->nextAdded; + Tcl_SetObjLength(objPtr, numBytes + 1); + return 1; } - return -1; + + /* + * Revise the dstRead value so that the numChars calc below + * correctly computes zero characters read. + */ + + dstRead = numChars; + + /* FALL THROUGH - get more data (dstWrote == 0) */ } /* - * Space is made at the beginning of the buffer to copy the previous - * unused bytes there. Check first if the buffer we are using actually - * has enough space at its beginning for the data we are copying. - * Because if not we will write over the buffer management - * information, especially the 'nextPtr'. - * - * Note that the BUFFER_PADDING (See AllocChannelBuffer) is used to - * prevent exactly this situation. I.e. it should never happen. - * Therefore it is ok to panic should it happen despite the - * precautions. + * The translation transformation can only reduce the number of chars + * when it converts \r\n into \n. The reduction in the number of chars + * is the difference in bytes read and written. */ - if (nextPtr->nextRemoved - srcLen < 0) { - Tcl_Panic("Buffer Underflow, BUFFER_PADDING not enough"); - } + numChars -= (dstRead - dstWrote); - nextPtr->nextRemoved -= srcLen; - memcpy(RemovePoint(nextPtr), src, (size_t) srcLen); - RecycleBuffer(statePtr, bufPtr, 0); - statePtr->inQueueHead = nextPtr; - return ReadChars(statePtr, objPtr, charsToRead, offsetPtr, factorPtr); - } + if (charsToRead > 0 && numChars > charsToRead) { - dstRead = dstWrote; - 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? Run the conversion again with an output buffer just - * big enough to hold the data so we can get the correct value for - * srcRead. - */ + /* + * TODO: This cannot happen anymore. + * + * We read more chars than allowed. Reset limits to prevent that + * and try again. Don't forget the extra padding of TCL_UTF_MAX + * bytes demanded by the Tcl_ExternalToUtf() call! + */ + + dstLimit = Tcl_UtfAtIndex(dst, charsToRead) - 1 + TCL_UTF_MAX - dst; + statePtr->flags = savedFlags; + statePtr->inputEncodingFlags = savedIEFlags; + statePtr->inputEncodingState = savedState; + continue; + } if (dstWrote == 0) { - return -1; + ChannelBuffer *nextPtr; + + /* + * We were not able to read any chars. + */ + + assert(numChars == 0); + + /* + * There is one situation where this is the correct final result. + * If the src buffer contains only a single \n byte, and we are in + * TCL_TRANSLATE_AUTO mode, and when the translation pass was made + * the INPUT_SAW_CR flag was set on the channel. In that case, the + * correct behavior is to consume that \n and produce the empty + * string. + */ + + if (dstRead == 1 && dst[0] == '\n') { + assert(statePtr->inputTranslation == TCL_TRANSLATE_AUTO); + + goto consume; + } + + /* + * Otherwise, reading zero characters indicates there's something + * incomplete at the end of the src buffer. Maybe there were not + * enough src bytes to decode into a char. Maybe a lone \r could + * not be translated (crlf mode). Need to combine any unused src + * bytes we have in the first buffer with subsequent bytes to try + * again. + */ + + nextPtr = bufPtr->nextPtr; + + if (nextPtr == NULL) { + if (srcLen > 0) { + SetFlag(statePtr, CHANNEL_NEED_MORE_DATA); + } + Tcl_SetObjLength(objPtr, numBytes); + return -1; + } + + /* + * Space is made at the beginning of the buffer to copy the + * previous unused bytes there. Check first if the buffer we are + * using actually has enough space at its beginning for the data + * we are copying. Because if not we will write over the buffer + * management information, especially the 'nextPtr'. + * + * Note that the BUFFER_PADDING (See AllocChannelBuffer) is used + * to prevent exactly this situation. I.e. it should never happen. + * Therefore it is ok to panic should it happen despite the + * precautions. + */ + + if (nextPtr->nextRemoved - srcLen < 0) { + Tcl_Panic("Buffer Underflow, BUFFER_PADDING not enough"); + } + + nextPtr->nextRemoved -= srcLen; + memcpy(RemovePoint(nextPtr), src, (size_t) srcLen); + RecycleBuffer(statePtr, bufPtr, 0); + statePtr->inQueueHead = nextPtr; + Tcl_SetObjLength(objPtr, numBytes); + return ReadChars(statePtr, objPtr, charsToRead, factorPtr); } - statePtr->inputEncodingState = oldState; - Tcl_ExternalToUtf(NULL, statePtr->encoding, src, srcLen, - statePtr->inputEncodingFlags, &statePtr->inputEncodingState, - dst, dstRead + TCL_UTF_MAX, &srcRead, &dstWrote, &numChars); - TranslateInputEOL(statePtr, dst, dst, &dstWrote, &dstRead); - } - /* - * The number of characters that we got may be less than the number that - * we started with because "\r\n" sequences may have been turned into just - * '\n' in dst. - */ + statePtr->inputEncodingFlags &= ~TCL_ENCODING_START; - numChars -= dstRead - dstWrote; + consume: + bufPtr->nextRemoved += srcRead; - if ((unsigned) numChars > (unsigned) toRead) { /* - * Got too many chars. + * If this read contained multibyte characters, revise factorPtr so + * the next read will allocate bigger buffers. */ - const char *eof = Tcl_UtfAtIndex(dst, toRead); - - statePtr->inputEncodingState = oldState; - Tcl_ExternalToUtf(NULL, statePtr->encoding, src, srcLen, - statePtr->inputEncodingFlags, &statePtr->inputEncodingState, - dst, eof - dst + TCL_UTF_MAX, &srcRead, &dstWrote, &numChars); - dstRead = dstWrote; - TranslateInputEOL(statePtr, dst, dst, &dstWrote, &dstRead); - numChars -= (dstRead - dstWrote); - } - statePtr->inputEncodingFlags &= ~TCL_ENCODING_START; - - bufPtr->nextRemoved += srcRead; - if (dstWrote > srcRead + 1) { - *factorPtr = dstWrote * UTF_EXPANSION_FACTOR / srcRead; + if (numChars && numChars < srcRead) { + *factorPtr = srcRead * UTF_EXPANSION_FACTOR / numChars; + } + Tcl_SetObjLength(objPtr, numBytes + dstWrote); + return numChars; } - *offsetPtr += dstWrote; - return numChars; } /* @@ -6381,7 +6433,7 @@ ReadChars( *--------------------------------------------------------------------------- */ -static int +static void TranslateInputEOL( ChannelState *statePtr, /* Channel being read, for EOL translation and * EOF character. */ @@ -6390,132 +6442,143 @@ TranslateInputEOL( * characters. */ const char *srcStart, /* Source characters. */ int *dstLenPtr, /* On entry, the maximum length of output - * buffer in bytes; must be <= *srcLenPtr. On - * exit, the number of bytes actually used in - * output buffer. */ + * buffer in bytes. On exit, the number of + * bytes actually used in output buffer. */ int *srcLenPtr) /* On entry, the length of source buffer. On * exit, the number of bytes read from the * source buffer. */ { - int dstLen, srcLen, inEofChar; - const char *eof; + const char *eof = NULL; + int dstLen = *dstLenPtr; + int srcLen = *srcLenPtr; + int inEofChar = statePtr->inEofChar; - dstLen = *dstLenPtr; + /* + * Depending on the translation mode in use, there's no need to scan more + * srcLen bytes at srcStart than can possibly transform to dstLen bytes. + * This keeps the scan for eof char below from being pointlessly long. + */ + + switch (statePtr->inputTranslation) { + case TCL_TRANSLATE_LF: + case TCL_TRANSLATE_CR: + if (srcLen > dstLen) { + /* + * In these modes, each src byte become a dst byte. + */ + + srcLen = dstLen; + } + break; + default: + /* + * In other modes, at most 2 src bytes become a dst byte. + */ + + if (srcLen/2 > dstLen) { + srcLen = 2 * dstLen; + } + break; + } - eof = NULL; - inEofChar = statePtr->inEofChar; if (inEofChar != '\0') { /* - * Find EOF in translated buffer then compress out the EOL. The source - * buffer may be much longer than the destination buffer - we only - * want to return EOF if the EOF has been copied to the destination - * buffer. + * Make sure we do not read past any logical end of channel input + * created by the presence of the input eof char. */ - const char *src, *srcMax = srcStart + *srcLenPtr; - - for (src = srcStart; src < srcMax; src++) { - if (*src == inEofChar) { - eof = src; - srcLen = src - srcStart; - if (srcLen < dstLen) { - dstLen = srcLen; - } - *srcLenPtr = srcLen; - break; - } + if ((eof = memchr(srcStart, inEofChar, srcLen))) { + srcLen = eof - srcStart; } } + switch (statePtr->inputTranslation) { case TCL_TRANSLATE_LF: + case TCL_TRANSLATE_CR: if (dstStart != srcStart) { - memcpy(dstStart, srcStart, (size_t) dstLen); + memcpy(dstStart, srcStart, (size_t) srcLen); } - srcLen = dstLen; - break; - case TCL_TRANSLATE_CR: { - char *dst, *dstEnd; + if (statePtr->inputTranslation == TCL_TRANSLATE_CR) { + char *dst = dstStart; + char *dstEnd = dstStart + srcLen; - if (dstStart != srcStart) { - memcpy(dstStart, srcStart, (size_t) dstLen); - } - dstEnd = dstStart + dstLen; - for (dst = dstStart; dst < dstEnd; dst++) { - if (*dst == '\r') { - *dst = '\n'; + while ((dst = memchr(dst, '\r', dstEnd - dst))) { + *dst++ = '\n'; } } - srcLen = dstLen; + dstLen = srcLen; break; - } case TCL_TRANSLATE_CRLF: { - char *dst; - const char *src, *srcEnd, *srcMax; - - dst = dstStart; - src = srcStart; - srcEnd = srcStart + dstLen; - srcMax = srcStart + *srcLenPtr; - - for ( ; src < srcEnd; ) { - if (*src == '\r') { - src++; - if (src >= srcMax) { - SetFlag(statePtr, INPUT_NEED_NL); - } else if (*src == '\n') { - *dst++ = *src++; - } else { + const char *crFound, *src = srcStart; + char *dst = dstStart; + int lesser = (dstLen < srcLen) ? dstLen : srcLen; + + while ((crFound = memchr(src, '\r', lesser))) { + int numBytes = crFound - src; + memmove(dst, src, numBytes); + + dst += numBytes; dstLen -= numBytes; + src += numBytes; srcLen -= numBytes; + if (srcLen == 1) { + /* valid src bytes end in \r */ + if (eof) { *dst++ = '\r'; + src++; srcLen--; + } else { + lesser = 0; + break; } + } else if (src[1] == '\n') { + *dst++ = '\n'; + src += 2; srcLen -= 2; } else { - *dst++ = *src++; + *dst++ = '\r'; + src++; srcLen--; } + dstLen--; + lesser = (dstLen < srcLen) ? dstLen : srcLen; } - srcLen = src - srcStart; - dstLen = dst - dstStart; + memmove(dst, src, lesser); + srcLen = src + lesser - srcStart; + dstLen = dst + lesser - dstStart; break; } case TCL_TRANSLATE_AUTO: { - char *dst; - const char *src, *srcEnd, *srcMax; - - dst = dstStart; - src = srcStart; - srcEnd = srcStart + dstLen; - srcMax = srcStart + *srcLenPtr; + const char *crFound, *src = srcStart; + char *dst = dstStart; + int lesser; - if (GotFlag(statePtr, INPUT_SAW_CR) && (src < srcMax)) { - if (*src == '\n') { - src++; - } + if ((statePtr->flags & INPUT_SAW_CR) && srcLen) { + if (*src == '\n') { src++; srcLen--; } ResetFlag(statePtr, INPUT_SAW_CR); } - for ( ; src < srcEnd; ) { - if (*src == '\r') { - src++; - if (src >= srcMax) { - SetFlag(statePtr, INPUT_SAW_CR); - } else if (*src == '\n') { - if (srcEnd < srcMax) { - srcEnd++; - } - src++; - } - *dst++ = '\n'; - } else { - *dst++ = *src++; + lesser = (dstLen < srcLen) ? dstLen : srcLen; + while ((crFound = memchr(src, '\r', lesser))) { + int numBytes = crFound - src; + memmove(dst, src, numBytes); + + dst[numBytes] = '\n'; + dst += numBytes + 1; dstLen -= numBytes + 1; + src += numBytes + 1; srcLen -= numBytes + 1; + if (srcLen == 0) { + SetFlag(statePtr, INPUT_SAW_CR); + } else if (*src == '\n') { + src++; srcLen--; } + lesser = (dstLen < srcLen) ? dstLen : srcLen; } - srcLen = src - srcStart; - dstLen = dst - dstStart; + memmove(dst, src, lesser); + srcLen = src + lesser - srcStart; + dstLen = dst + lesser - dstStart; break; } default: - return 0; + Tcl_Panic("unknown input translation %d", statePtr->inputTranslation); } *dstLenPtr = dstLen; + *srcLenPtr = srcLen; - if ((eof != NULL) && (srcStart + srcLen >= eof)) { + if (srcStart + srcLen == eof) { /* * EOF character was seen in EOL translated range. Leave current file * position pointing at the EOF character, but don't store the EOF @@ -6524,12 +6587,8 @@ TranslateInputEOL( SetFlag(statePtr, CHANNEL_EOF | CHANNEL_STICKY_EOF); statePtr->inputEncodingFlags |= TCL_ENCODING_END; - ResetFlag(statePtr, INPUT_SAW_CR | INPUT_NEED_NL); - return 1; + ResetFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR); } - - *srcLenPtr = srcLen; - return 0; } /* @@ -6583,16 +6642,15 @@ Tcl_Ungets( statePtr->flags = flags; /* - * If we have encountered a sticky EOF, just punt without storing (sticky - * EOF is set if we have seen the input eofChar, to prevent reading beyond - * the eofChar). Otherwise, clear the EOF flags, and clear the BLOCKED - * bit. We want to discover these conditions anew in each operation. + * Clear the EOF flags, and clear the BLOCKED bit. */ - if (GotFlag(statePtr, CHANNEL_STICKY_EOF)) { - goto done; + if (GotFlag(statePtr, CHANNEL_EOF)) { + statePtr->inputEncodingFlags |= TCL_ENCODING_START; } - ResetFlag(statePtr, CHANNEL_BLOCKED | CHANNEL_EOF); + ResetFlag(statePtr, + CHANNEL_BLOCKED | CHANNEL_STICKY_EOF | CHANNEL_EOF | INPUT_SAW_CR); + statePtr->inputEncodingFlags &= ~TCL_ENCODING_END; bufPtr = AllocChannelBuffer(len); memcpy(InsertPoint(bufPtr), str, (size_t) len); @@ -6654,15 +6712,7 @@ Tcl_Flush( chanPtr = statePtr->topChanPtr; if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) { - return -1; - } - - /* - * Force current output buffer to be output also. - */ - - if ((statePtr->curOutPtr != NULL) && IsBufferReady(statePtr->curOutPtr)) { - SetFlag(statePtr, BUFFER_READY); + return TCL_ERROR; } result = FlushChannel(NULL, chanPtr, 0); @@ -6715,7 +6765,7 @@ DiscardInputQueued( */ if (discardSavedBuffers && statePtr->saveInBufPtr != NULL) { - ckfree(statePtr->saveInBufPtr); + ReleaseChannelBuffer(statePtr->saveInBufPtr); statePtr->saveInBufPtr = NULL; } } @@ -6727,6 +6777,9 @@ DiscardInputQueued( * * Reads input data from a device into a channel buffer. * + * IMPORTANT! This routine is only called on a chanPtr argument + * that is the top channel of a stack! + * * Results: * The return value is the Posix error code if an error occurred while * reading from the file, or 0 otherwise. @@ -6749,6 +6802,14 @@ GetInput( /* State info for channel */ /* + * Verify that all callers know better than to call us when + * it's recorded that the next char waiting to be read is the + * eofchar. + */ + + assert(!GotFlag(statePtr, CHANNEL_STICKY_EOF)); + + /* * Prevent reading from a dead channel -- a channel that has been closed * but not yet deallocated, which can happen if the exit handler for * channel cleanup has run but the channel is still registered in some @@ -6760,20 +6821,30 @@ GetInput( } /* + * WARNING: There was once a comment here claiming that it was a bad idea + * to make another call to the inputproc of a channel driver when EOF has + * already been detected on the channel. Through much of Tcl's history, + * this warning was then completely negated by having all (most?) read + * paths clear the EOF setting before reaching here. So we had a guard + * that was never triggered. + * + * Don't be tempted to restore the guard. Even if EOF is set on the + * channel, continue through and call the inputproc again. This is the + * way to enable the ability to [read] again beyond the EOF, which seems a + * strange thing to do, but for which use cases exist [Tcl Bug 5adc350683] + * and which may even be essential for channels representing things like + * ttys or other devices where the stream might take the logical form of a + * series of 'files' separated by an EOF condition. + * * First check for more buffers in the pushback area of the topmost * channel in the stack and use them. They can be the result of a * transformation which went away without reading all the information * placed in the area when it was stacked. - * - * Two possibilities for the state: No buffers in it, or a single empty - * buffer. In the latter case we can recycle it now. */ if (chanPtr->inQueueHead != NULL) { - if (statePtr->inQueueHead != NULL) { - RecycleBuffer(statePtr, statePtr->inQueueHead, 0); - statePtr->inQueueHead = NULL; - } + /* TODO: Tests to cover this. */ + assert(statePtr->inQueueHead == NULL); statePtr->inQueueHead = chanPtr->inQueueHead; statePtr->inQueueTail = chanPtr->inQueueTail; @@ -6794,21 +6865,22 @@ GetInput( */ bufPtr = statePtr->inQueueTail; - if ((bufPtr != NULL) && !IsBufferFull(bufPtr)) { - toRead = SpaceLeft(bufPtr); - } else { + + if ((bufPtr == NULL) || IsBufferFull(bufPtr)) { 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. + * Saved buffers of the wrong size are squashed. This is done to honor + * dynamic changes of the buffersize made by the user. + * + * TODO: Tests to cover this. */ if ((bufPtr != NULL) - && (bufPtr->bufLength - BUFFER_PADDING < statePtr->bufSize)) { - ckfree(bufPtr); + && (bufPtr->bufLength - BUFFER_PADDING != statePtr->bufSize)) { + ReleaseChannelBuffer(bufPtr); bufPtr = NULL; } @@ -6817,21 +6889,8 @@ GetInput( } bufPtr->nextPtr = NULL; - /* - * 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 = SpaceLeft(bufPtr); + assert(toRead == statePtr->bufSize); if (statePtr->inQueueTail == NULL) { statePtr->inQueueHead = bufPtr; @@ -6839,75 +6898,22 @@ GetInput( statePtr->inQueueTail->nextPtr = bufPtr; } statePtr->inQueueTail = bufPtr; + } else { + toRead = SpaceLeft(bufPtr); } - /* - * If EOF is set, we should avoid calling the driver because on some - * platforms it is impossible to read from a device after EOF. - */ - - if (GotFlag(statePtr, CHANNEL_EOF)) { - return 0; - } - -#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING - /* - * [Bug 943274]: Better emulation of non-blocking channels for channels - * without BlockModeProc, by keeping track of true fileevents generated by - * the OS == Data waiting and reading if and only if we are sure to have - * data. - */ - - if (GotFlag(statePtr, CHANNEL_NONBLOCKING) && - (Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL) && - !GotFlag(statePtr, CHANNEL_HAS_MORE_DATA)) { - /* - * Bypass the driver, it would block, as no data is available - */ - - nread = -1; - result = EWOULDBLOCK; - } else -#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ - { - nread = ChanRead(chanPtr, InsertPoint(bufPtr), toRead, &result); - } + PreserveChannelBuffer(bufPtr); + nread = ChanRead(chanPtr, InsertPoint(bufPtr), toRead); - if (nread > 0) { + if (nread < 0) { + result = Tcl_GetErrno(); + } else { + result = 0; bufPtr->nextAdded += nread; - - /* - * If we get a short read, signal up that we may be BLOCKED. We should - * avoid calling the driver because on some platforms we will block in - * the low level reading code even though the channel is set into - * nonblocking mode. - */ - - if (nread < toRead) { - SetFlag(statePtr, CHANNEL_BLOCKED); - } - -#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING - if (nread <= toRead) { - /* - * [Bug 943274]: We have read the available data, clear flag. - */ - - ResetFlag(statePtr, CHANNEL_HAS_MORE_DATA); - } -#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ - } else if (nread == 0) { - SetFlag(statePtr, CHANNEL_EOF); - statePtr->inputEncodingFlags |= TCL_ENCODING_END; - } else if (nread < 0) { - if ((result == EWOULDBLOCK) || (result == EAGAIN)) { - SetFlag(statePtr, CHANNEL_BLOCKED); - result = EAGAIN; - } - Tcl_SetErrno(result); - return result; } - return 0; + + ReleaseChannelBuffer(bufPtr); + return result; } /* @@ -7011,8 +7017,12 @@ Tcl_Seek( * point. Also clear CR related flags. */ + if (GotFlag(statePtr, CHANNEL_EOF)) { + statePtr->inputEncodingFlags |= TCL_ENCODING_START; + } ResetFlag(statePtr, CHANNEL_EOF | CHANNEL_STICKY_EOF | CHANNEL_BLOCKED | INPUT_SAW_CR); + statePtr->inputEncodingFlags &= ~TCL_ENCODING_END; /* * If the channel is in asynchronous output mode, switch it back to @@ -7035,15 +7045,6 @@ Tcl_Seek( } /* - * If there is data buffered in statePtr->curOutPtr then mark the channel - * as ready to flush before invoking FlushChannel. - */ - - if ((statePtr->curOutPtr != NULL) && IsBufferReady(statePtr->curOutPtr)) { - SetFlag(statePtr, BUFFER_READY); - } - - /* * If the flush fails we cannot recover the original position. In that * case the seek is not attempted because we do not know where the access * position is - instead we return the error. FlushChannel has already @@ -7175,53 +7176,12 @@ Tcl_Tell( /* *--------------------------------------------------------------------------- * - * 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( - Tcl_Channel chan, /* The channel on which to seek. */ - int offset, /* Offset to seek to. */ - int mode) /* Relative to which location to seek? */ -{ - Tcl_WideInt wOffset, wResult; - - wOffset = Tcl_LongAsWide((long) offset); - wResult = Tcl_Seek(chan, wOffset, mode); - return (int) Tcl_WideAsLong(wResult); -} - -int -Tcl_TellOld( - Tcl_Channel chan) /* The channel to return pos for. */ -{ - Tcl_WideInt wResult = Tcl_Tell(chan); - - return (int) Tcl_WideAsLong(wResult); -} - -/* - *--------------------------------------------------------------------------- - * * Tcl_TruncateChannel -- * * Truncate a channel to the given length. * * Results: - * TCL_OK on success, TCL_ERROR if the operation failed (e.g. is not + * TCL_OK on success, TCL_ERROR if the operation failed (e.g., is not * supported by the type of channel, or the underlying OS operation * failed in some way). * @@ -7367,17 +7327,7 @@ CheckChannelErrors( } if (direction == TCL_READABLE) { - /* - * If we have not encountered a sticky EOF, clear the EOF bit (sticky - * EOF is set if we have seen the input eofChar, to prevent reading - * beyond the eofChar). Also, always clear the BLOCKED bit. We want to - * discover these conditions anew in each operation. - */ - - if (!GotFlag(statePtr, CHANNEL_STICKY_EOF)) { - ResetFlag(statePtr, CHANNEL_EOF); - } - ResetFlag(statePtr, CHANNEL_BLOCKED | CHANNEL_NEED_MORE_DATA); + ResetFlag(statePtr, CHANNEL_NEED_MORE_DATA); } return 0; @@ -7406,9 +7356,7 @@ Tcl_Eof( ChannelState *statePtr = ((Channel *) chan)->state; /* State of real channel structure. */ - return (GotFlag(statePtr, CHANNEL_STICKY_EOF) || - (GotFlag(statePtr, CHANNEL_EOF) && - (Tcl_InputBuffered(chan) == 0))) ? 1 : 0; + return GotFlag(statePtr, CHANNEL_EOF) ? 1 : 0; } /* @@ -7593,14 +7541,26 @@ Tcl_SetChannelBufferSize( } statePtr = ((Channel *) chan)->state; + + if (statePtr->bufSize == sz) { + return; + } statePtr->bufSize = sz; - if (statePtr->outputStage != NULL) { - ckfree(statePtr->outputStage); - statePtr->outputStage = NULL; + /* + * If bufsize changes, need to get rid of old utility buffer. + */ + + if (statePtr->saveInBufPtr != NULL) { + RecycleBuffer(statePtr, statePtr->saveInBufPtr, 1); + statePtr->saveInBufPtr = NULL; } - if ((statePtr->encoding != NULL) && GotFlag(statePtr, TCL_WRITABLE)) { - statePtr->outputStage = ckalloc(statePtr->bufSize + 2); + if ((statePtr->inQueueHead != NULL) + && (statePtr->inQueueHead->nextPtr == NULL) + && IsBufferEmpty(statePtr->inQueueHead)) { + RecycleBuffer(statePtr, statePtr->inQueueHead, 1); + statePtr->inQueueHead = NULL; + statePtr->inQueueTail = NULL; } } @@ -8036,6 +7996,7 @@ Tcl_SetChannelOption( return TCL_ERROR; } Tcl_SetChannelBufferSize(chan, newBufferSize); + return TCL_OK; } else if (HaveOpt(2, "-encoding")) { Tcl_Encoding encoding; @@ -8053,7 +8014,8 @@ Tcl_SetChannelOption( * iso2022, the terminated escape sequence must write to the buffer. */ - if ((statePtr->encoding != NULL) && (statePtr->curOutPtr != NULL) + if ((statePtr->encoding != NULL) + && !(statePtr->outputEncodingFlags & TCL_ENCODING_START) && (CheckChannelErrors(statePtr, TCL_WRITABLE) == 0)) { statePtr->outputEncodingFlags |= TCL_ENCODING_END; WriteChars(chanPtr, "", 0); @@ -8066,6 +8028,7 @@ Tcl_SetChannelOption( statePtr->outputEncodingFlags = TCL_ENCODING_START; ResetFlag(statePtr, CHANNEL_NEED_MORE_DATA); UpdateInterest(chanPtr); + return TCL_OK; } else if (HaveOpt(2, "-eofchar")) { if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) { return TCL_ERROR; @@ -8112,7 +8075,11 @@ Tcl_SetChannelOption( * ahead'. Ditto for blocked. */ + if (GotFlag(statePtr, CHANNEL_EOF)) { + statePtr->inputEncodingFlags |= TCL_ENCODING_START; + } ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_STICKY_EOF|CHANNEL_BLOCKED); + statePtr->inputEncodingFlags &= ~TCL_ENCODING_END; return TCL_OK; } else if (HaveOpt(1, "-translation")) { const char *readMode, *writeMode; @@ -8226,33 +8193,6 @@ Tcl_SetChannelOption( return Tcl_BadChannelOption(interp, optionName, NULL); } - /* - * If bufsize changes, need to get rid of old utility buffer. - */ - - if (statePtr->saveInBufPtr != NULL) { - RecycleBuffer(statePtr, statePtr->saveInBufPtr, 1); - statePtr->saveInBufPtr = NULL; - } - if ((statePtr->inQueueHead != NULL) - && (statePtr->inQueueHead->nextPtr == NULL) - && IsBufferEmpty(statePtr->inQueueHead)) { - RecycleBuffer(statePtr, statePtr->inQueueHead, 1); - statePtr->inQueueHead = NULL; - statePtr->inQueueTail = NULL; - } - - /* - * If encoding or bufsize changes, need to update output staging buffer. - */ - - if (statePtr->outputStage != NULL) { - ckfree(statePtr->outputStage); - statePtr->outputStage = NULL; - } - if ((statePtr->encoding != NULL) && GotFlag(statePtr, TCL_WRITABLE)) { - statePtr->outputStage = ckalloc(statePtr->bufSize + 2); - } return TCL_OK; } @@ -8344,21 +8284,6 @@ Tcl_NotifyChannel( Channel *upChanPtr; const Tcl_ChannelType *upTypePtr; -#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING - /* - * [SF Tcl Bug 943274] For a non-blocking channel without blockmodeproc we - * keep track of actual input coming from the OS so that we can do a - * credible imitation of non-blocking behaviour. - */ - - if ((mask & TCL_READABLE) && - GotFlag(statePtr, CHANNEL_NONBLOCKING) && - (Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL) && - !GotFlag(statePtr, CHANNEL_TIMER_FEV)) { - SetFlag(statePtr, CHANNEL_HAS_MORE_DATA); - } -#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ - /* * In contrast to the other API functions this procedure walks towards the * top of a stack and not down from it. @@ -8408,7 +8333,7 @@ Tcl_NotifyChannel( * Preserve the channel struct in case the script closes it. */ - Tcl_Preserve(channel); + TclChannelPreserve((Tcl_Channel)channel); Tcl_Preserve(statePtr); /* @@ -8418,13 +8343,14 @@ Tcl_NotifyChannel( */ if (GotFlag(statePtr, BG_FLUSH_SCHEDULED) && (mask & TCL_WRITABLE)) { - FlushChannel(NULL, chanPtr, 1); - mask &= ~TCL_WRITABLE; + if (0 == FlushChannel(NULL, chanPtr, 1)) { + mask &= ~TCL_WRITABLE; + } } /* * Add this invocation to the list of recursive invocations of - * ChannelHandlerEventProc. + * Tcl_NotifyChannel. */ nh.nextHandlerPtr = NULL; @@ -8439,7 +8365,7 @@ Tcl_NotifyChannel( if ((chPtr->mask & mask) != 0) { nh.nextHandlerPtr = chPtr->nextPtr; - chPtr->proc(chPtr->clientData, mask); + chPtr->proc(chPtr->clientData, chPtr->mask & mask); chPtr = nh.nextHandlerPtr; } else { chPtr = chPtr->nextPtr; @@ -8453,11 +8379,16 @@ Tcl_NotifyChannel( */ if (chanPtr->typePtr != NULL) { + /* + * TODO: This call may not be needed. If a handler induced a + * change in interest, that handler should have made its own + * UpdateInterest() call, one would think. + */ UpdateInterest(chanPtr); } Tcl_Release(statePtr); - Tcl_Release(channel); + TclChannelRelease(channel); tsdPtr->nestedHandlerPtr = nh.nestedHandlerPtr; } @@ -8487,6 +8418,11 @@ UpdateInterest( /* State info for channel */ int mask = statePtr->interestMask; + if (chanPtr->typePtr == NULL) { + /* Do not update interest on a closed channel */ + return; + } + /* * If there are flushed buffers waiting to be written, then we need to * watch for the channel to become writable. @@ -8594,29 +8530,8 @@ ChannelTimerProc( statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, ChannelTimerProc,chanPtr); - -#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING - /* - * 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 (GotFlag(statePtr, CHANNEL_NONBLOCKING) && - (Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL)) { - SetFlag(statePtr, CHANNEL_TIMER_FEV); - } -#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ - Tcl_Preserve(statePtr); Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_READABLE); - -#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING - ResetFlag(statePtr, CHANNEL_TIMER_FEV); -#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ - Tcl_Release(statePtr); } else { statePtr->timer = NULL; @@ -8759,7 +8674,7 @@ Tcl_DeleteChannelHandler( } /* - * If ChannelHandlerEventProc is about to process this handler, tell it to + * If Tcl_NotifyChannel is about to process this handler, tell it to * process the next one instead - we are going to delete *this* one. */ @@ -8955,7 +8870,7 @@ TclChannelEventScriptInvoker( */ Tcl_Preserve(interp); - Tcl_Preserve(chanPtr); + TclChannelPreserve((Tcl_Channel)chanPtr); result = Tcl_EvalObjEx(interp, esPtr->scriptPtr, TCL_EVAL_GLOBAL); /* @@ -8972,7 +8887,7 @@ TclChannelEventScriptInvoker( } Tcl_BackgroundException(interp, result); } - Tcl_Release(chanPtr); + TclChannelRelease((Tcl_Channel)chanPtr); Tcl_Release(interp); } @@ -9121,6 +9036,7 @@ ZeroTransferTimerProc( *---------------------------------------------------------------------- */ +#if !defined(TCL_NO_DEPRECATED) int TclCopyChannelOld( Tcl_Interp *interp, /* Current interpreter. */ @@ -9132,6 +9048,7 @@ TclCopyChannelOld( return TclCopyChannel(interp, inChan, outChan, (Tcl_WideInt) toRead, cmdPtr); } +#endif int TclCopyChannel( @@ -9147,6 +9064,7 @@ TclCopyChannel( int readFlags, writeFlags; CopyState *csPtr; int nonBlocking = (cmdPtr) ? CHANNEL_NONBLOCKING : 0; + int moveBytes; inStatePtr = inPtr->state; outStatePtr = outPtr->state; @@ -9198,13 +9116,24 @@ TclCopyChannel( | CHANNEL_UNBUFFERED; /* + * Test for conditions where we know we can just move bytes from input + * channel to output channel with no transformation or even examination + * of the bytes themselves. + */ + + moveBytes = inStatePtr->inEofChar == '\0' /* No eofChar to stop input */ + && inStatePtr->inputTranslation == TCL_TRANSLATE_LF + && outStatePtr->outputTranslation == TCL_TRANSLATE_LF + && inStatePtr->encoding == outStatePtr->encoding; + + /* * Allocate a new CopyState to maintain info about the current copy in * progress. This structure will be deallocated when the copy is * completed. */ - csPtr = ckalloc(sizeof(CopyState) + inStatePtr->bufSize); - csPtr->bufSize = inStatePtr->bufSize; + csPtr = ckalloc(sizeof(CopyState) + !moveBytes * inStatePtr->bufSize); + csPtr->bufSize = !moveBytes * inStatePtr->bufSize; csPtr->readPtr = inPtr; csPtr->writePtr = outPtr; csPtr->readFlags = readFlags; @@ -9220,6 +9149,10 @@ TclCopyChannel( inStatePtr->csPtrR = csPtr; outStatePtr->csPtrW = csPtr; + if (moveBytes) { + return MoveBytes(csPtr); + } + /* * Special handling of -size 0 async transfers, so that the -command is * still called asynchronously. @@ -9254,6 +9187,236 @@ TclCopyChannel( *---------------------------------------------------------------------- */ +static void +MBCallback( + CopyState *csPtr, + Tcl_Obj *errObj) +{ + Tcl_Obj *cmdPtr = Tcl_DuplicateObj(csPtr->cmdPtr); + Tcl_WideInt total = csPtr->total; + Tcl_Interp *interp = csPtr->interp; + int code; + + Tcl_IncrRefCount(cmdPtr); + StopCopy(csPtr); + + /* TODO: What if cmdPtr is not a list?! */ + + Tcl_ListObjAppendElement(NULL, cmdPtr, Tcl_NewWideIntObj(total)); + if (errObj) { + Tcl_ListObjAppendElement(NULL, cmdPtr, errObj); + } + + Tcl_Preserve(interp); + code = Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL); + if (code != TCL_OK) { + Tcl_BackgroundException(interp, code); + } + Tcl_Release(interp); + TclDecrRefCount(cmdPtr); +} + +static void +MBError( + CopyState *csPtr, + int mask, + int errorCode) +{ + Tcl_Channel inChan = (Tcl_Channel) csPtr->readPtr; + Tcl_Channel outChan = (Tcl_Channel) csPtr->writePtr; + Tcl_Obj *errObj; + + Tcl_SetErrno(errorCode); + + errObj = Tcl_ObjPrintf( "error %sing \"%s\": %s", + (mask & TCL_READABLE) ? "read" : "writ", + Tcl_GetChannelName((mask & TCL_READABLE) ? inChan : outChan), + Tcl_PosixError(csPtr->interp)); + + if (csPtr->cmdPtr) { + MBCallback(csPtr, errObj); + } else { + Tcl_SetObjResult(csPtr->interp, errObj); + StopCopy(csPtr); + } +} + +static void +MBEvent( + ClientData clientData, + int mask) +{ + CopyState *csPtr = (CopyState *) clientData; + Tcl_Channel inChan = (Tcl_Channel) csPtr->readPtr; + Tcl_Channel outChan = (Tcl_Channel) csPtr->writePtr; + ChannelState *inStatePtr = csPtr->readPtr->state; + + if (mask & TCL_WRITABLE) { + Tcl_DeleteChannelHandler(inChan, MBEvent, csPtr); + Tcl_DeleteChannelHandler(outChan, MBEvent, csPtr); + switch (MBWrite(csPtr)) { + case TCL_OK: + MBCallback(csPtr, NULL); + break; + case TCL_CONTINUE: + Tcl_CreateChannelHandler(inChan, TCL_READABLE, MBEvent, csPtr); + break; + } + } else if (mask & TCL_READABLE) { + if (TCL_OK == MBRead(csPtr)) { + /* When at least one full buffer is present, stop reading. */ + if (IsBufferFull(inStatePtr->inQueueHead) + || !Tcl_InputBlocked(inChan)) { + Tcl_DeleteChannelHandler(inChan, MBEvent, csPtr); + } + + /* Successful read -- set up to write the bytes we read */ + Tcl_CreateChannelHandler(outChan, TCL_WRITABLE, MBEvent, csPtr); + } + } +} + +static int +MBRead( + CopyState *csPtr) +{ + ChannelState *inStatePtr = csPtr->readPtr->state; + ChannelBuffer *bufPtr = inStatePtr->inQueueHead; + int code; + + if (bufPtr && BytesLeft(bufPtr) > 0) { + return TCL_OK; + } + + code = GetInput(inStatePtr->topChanPtr); + if (code == 0 || GotFlag(inStatePtr, CHANNEL_BLOCKED)) { + return TCL_OK; + } else { + MBError(csPtr, TCL_READABLE, code); + return TCL_ERROR; + } +} + +static int +MBWrite( + CopyState *csPtr) +{ + ChannelState *inStatePtr = csPtr->readPtr->state; + ChannelState *outStatePtr = csPtr->writePtr->state; + ChannelBuffer *bufPtr = inStatePtr->inQueueHead; + ChannelBuffer *tail = NULL; + int code; + Tcl_WideInt inBytes = 0; + + /* Count up number of bytes waiting in the input queue */ + while (bufPtr) { + inBytes += BytesLeft(bufPtr); + tail = bufPtr; + if (csPtr->toRead != -1 && csPtr->toRead < inBytes) { + /* Queue has enough bytes to complete the copy */ + break; + } + bufPtr = bufPtr->nextPtr; + } + + if (bufPtr) { + /* Split the overflowing buffer in two */ + int extra = (int) (inBytes - csPtr->toRead); + /* Note that going with int for extra assumes that inBytes is not too + * much over toRead to require a wide itself. If that gets violated + * then the calculations involving extra must be made wide too. + * + * Noted with Win32/MSVC debug build treating the warning (possible of + * data in __int64 to int conversion) as error. + */ + + bufPtr = AllocChannelBuffer(extra); + + tail->nextAdded -= extra; + memcpy(InsertPoint(bufPtr), InsertPoint(tail), extra); + bufPtr->nextAdded += extra; + bufPtr->nextPtr = tail->nextPtr; + tail->nextPtr = NULL; + inBytes = csPtr->toRead; + } + + /* Update the byte counts */ + if (csPtr->toRead != -1) { + csPtr->toRead -= inBytes; + } + csPtr->total += inBytes; + + /* Move buffers from input to output channels */ + if (outStatePtr->outQueueTail) { + outStatePtr->outQueueTail->nextPtr = inStatePtr->inQueueHead; + } else { + outStatePtr->outQueueHead = inStatePtr->inQueueHead; + } + outStatePtr->outQueueTail = tail; + inStatePtr->inQueueHead = bufPtr; + if (inStatePtr->inQueueTail == tail) { + inStatePtr->inQueueTail = bufPtr; + } + if (bufPtr == NULL) { + inStatePtr->inQueueTail = NULL; + } + + code = FlushChannel(csPtr->interp, outStatePtr->topChanPtr, 0); + if (code) { + MBError(csPtr, TCL_WRITABLE, code); + return TCL_ERROR; + } + if (csPtr->toRead == 0 || GotFlag(inStatePtr, CHANNEL_EOF)) { + return TCL_OK; + } + return TCL_CONTINUE; +} + +static int +MoveBytes( + CopyState *csPtr) /* State of copy operation. */ +{ + ChannelState *outStatePtr = csPtr->writePtr->state; + ChannelBuffer *bufPtr = outStatePtr->curOutPtr; + int errorCode; + + if (bufPtr && BytesLeft(bufPtr)) { + /* If we start with unflushed bytes in the destination + * channel, flush them out of the way first. */ + + errorCode = FlushChannel(csPtr->interp, outStatePtr->topChanPtr, 0); + if (errorCode != 0) { + MBError(csPtr, TCL_WRITABLE, errorCode); + return TCL_ERROR; + } + } + + if (csPtr->cmdPtr) { + Tcl_Channel inChan = (Tcl_Channel) csPtr->readPtr; + Tcl_CreateChannelHandler(inChan, TCL_READABLE, MBEvent, csPtr); + return TCL_OK; + } + + while (1) { + int code; + + if (TCL_ERROR == MBRead(csPtr)) { + return TCL_ERROR; + } + code = MBWrite(csPtr); + if (code == TCL_OK) { + Tcl_SetObjResult(csPtr->interp, Tcl_NewWideIntObj(csPtr->total)); + StopCopy(csPtr); + return TCL_OK; + } + if (code == TCL_ERROR) { + return TCL_ERROR; + } + /* code == TCL_CONTINUE --> continue the loop */ + } + return TCL_OK; /* Silence compiler warnings */ +} + static int CopyData( CopyState *csPtr, /* State of copy operation. */ @@ -9379,6 +9542,13 @@ CopyData( csPtr); } if (size == 0) { + if (!GotFlag(inStatePtr, CHANNEL_NONBLOCKING)) { + /* + * We allowed a short read. Keep trying. + */ + + continue; + } if (bufObj != NULL) { TclDecrRefCount(bufObj); bufObj = NULL; @@ -9399,9 +9569,9 @@ CopyData( } if (outBinary || sameEncoding) { - sizeb = DoWrite(outStatePtr->topChanPtr, buffer, sizeb); + sizeb = WriteBytes(outStatePtr->topChanPtr, buffer, sizeb); } else { - sizeb = DoWriteChars(outStatePtr->topChanPtr, buffer, sizeb); + sizeb = WriteChars(outStatePtr->topChanPtr, buffer, sizeb); } /* @@ -9556,12 +9726,23 @@ CopyData( * * DoRead -- * - * Reads a given number of bytes from a channel. No encoding conversions + * Stores up to "bytesToRead" bytes in memory pointed to by "dst". + * These bytes come from reading the channel "chanPtr" and + * performing the configured translations. 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. + * The number of bytes actually stored (<= bytesToRead), + * or -1 if there is an error in reading the channel. Use + * Tcl_GetErrno() to retrieve the error code for the error + * that occurred. + * + * The number of bytes stored can be less than the number + * requested when + * - EOF is reached on the channel; or + * - the channel is non-blocking, and we've read all we can + * without blocking. + * - a channel reading error occurs (and we return -1) * * Side effects: * May cause input to be buffered. @@ -9572,538 +9753,218 @@ CopyData( static int DoRead( Channel *chanPtr, /* The channel from which to read. */ - char *bufPtr, /* Where to store input read. */ - int toRead, /* Maximum number of bytes to read. */ + char *dst, /* Where to store input read. */ + int bytesToRead, /* Maximum number of bytes to read. */ int allowShortReads) /* Allow half-blocking (pipes,sockets) */ { ChannelState *statePtr = chanPtr->state; - /* State info for channel */ - int copied; /* How many characters were copied into the - * result string? */ - int copiedNow; /* How many characters were copied from the - * current input buffer? */ - int result; /* Of calling GetInput. */ + char *p = dst; - /* - * If we have not encountered a sticky EOF, clear the EOF bit. Either way - * clear the BLOCKED bit. We want to discover these anew during each - * operation. - */ - - if (!GotFlag(statePtr, CHANNEL_STICKY_EOF)) { - ResetFlag(statePtr, CHANNEL_EOF); - } - ResetFlag(statePtr, CHANNEL_BLOCKED | CHANNEL_NEED_MORE_DATA); - - for (copied = 0; copied < toRead; copied += copiedNow) { - copiedNow = CopyAndTranslateBuffer(statePtr, bufPtr + copied, - toRead - copied); - if (copiedNow == 0) { - if (GotFlag(statePtr, CHANNEL_EOF)) { - goto done; - } - if (GotFlag(statePtr, CHANNEL_BLOCKED)) { - if (GotFlag(statePtr, CHANNEL_NONBLOCKING)) { - goto done; - } - ResetFlag(statePtr, CHANNEL_BLOCKED); - } - result = GetInput(chanPtr); - if (result != 0) { - if (result != EAGAIN) { - copied = -1; - } - goto done; - } - } else if (allowShortReads) { - copied += copiedNow; - break; - } - } - - ResetFlag(statePtr, CHANNEL_BLOCKED); + assert(bytesToRead >= 0); /* - * Update the notifier state so we don't block while there is still data - * in the buffers. + * Early out when we know a read will get the eofchar. + * + * NOTE: This seems to be a bug. The special handling for + * a zero-char read request ought to come first. As coded + * the EOF due to eofchar has distinguishing behavior from + * the EOF due to reported EOF on the underlying device, and + * that seems undesirable. However recent history indicates + * that new inconsistent behavior in a patchlevel has problems + * too. Keep on keeping on for now. */ - done: - UpdateInterest(chanPtr); - return copied; -} - -/* - *---------------------------------------------------------------------- - * - * CopyAndTranslateBuffer -- - * - * Copy at most one buffer of input to the result space, doing eol - * translations according to mode in effect currently. - * - * Results: - * Number of bytes stored in the result buffer (as opposed to the number - * of bytes read from the channel). May return zero if no input is - * available to be translated. - * - * Side effects: - * Consumes buffered input. May deallocate one buffer. - * - *---------------------------------------------------------------------- - */ - -static int -CopyAndTranslateBuffer( - ChannelState *statePtr, /* Channel state from which to read input. */ - char *result, /* Where to store the copied input. */ - int space) /* How many bytes are available in result to - * store the copied input? */ -{ - ChannelBuffer *bufPtr; /* The buffer from which to copy bytes. */ - int bytesInBuffer; /* How many bytes are available to be copied - * in the current input buffer? */ - int copied; /* How many characters were already copied - * into the destination space? */ - int i; /* Iterates over the copied input looking for - * the input eofChar. */ - - /* - * If there is no input at all, return zero. The invariant is that either - * there is no buffer in the queue, or if the first buffer is empty, it is - * also the last buffer (and thus there is no input in the queue). Note - * also that if the buffer is empty, we leave it in the queue. - */ + if (GotFlag(statePtr, CHANNEL_STICKY_EOF)) { + SetFlag(statePtr, CHANNEL_EOF); + assert(statePtr->inputEncodingFlags & TCL_ENCODING_END); + assert(!GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR)); - if (statePtr->inQueueHead == NULL) { + /* TODO: Don't need this call */ + UpdateInterest(chanPtr); return 0; } - bufPtr = statePtr->inQueueHead; - bytesInBuffer = BytesLeft(bufPtr); - - copied = 0; - switch (statePtr->inputTranslation) { - case TCL_TRANSLATE_LF: - if (bytesInBuffer == 0) { - return 0; - } - - /* - * Copy the current chunk into the result buffer. - */ - - if (bytesInBuffer < space) { - space = bytesInBuffer; - } - memcpy(result, RemovePoint(bufPtr), (size_t) space); - bufPtr->nextRemoved += space; - copied = space; - break; - case TCL_TRANSLATE_CR: { - char *end; - - if (bytesInBuffer == 0) { - return 0; - } - - /* - * Copy the current chunk into the result buffer, then replace all \r - * with \n. - */ - if (bytesInBuffer < space) { - space = bytesInBuffer; - } - memcpy(result, RemovePoint(bufPtr), (size_t) space); - bufPtr->nextRemoved += space; - copied = space; + /* + * Special handling for zero-char read request. + */ - for (end = result + copied; result < end; result++) { - if (*result == '\r') { - *result = '\n'; - } + if (bytesToRead == 0) { + if (GotFlag(statePtr, CHANNEL_EOF)) { + statePtr->inputEncodingFlags |= TCL_ENCODING_START; } - break; + ResetFlag(statePtr, CHANNEL_BLOCKED|CHANNEL_EOF); + statePtr->inputEncodingFlags &= ~TCL_ENCODING_END; + /* TODO: Don't need this call */ + UpdateInterest(chanPtr); + return 0; } - case TCL_TRANSLATE_CRLF: { - char *src, *end, *dst; - int curByte; + TclChannelPreserve((Tcl_Channel)chanPtr); + while (bytesToRead) { /* - * If there is a held-back "\r" at EOF, produce it now. + * Each pass through the loop is intended to process up to one channel + * buffer. */ - if (bytesInBuffer == 0) { - if ((statePtr->flags & (INPUT_SAW_CR | CHANNEL_EOF)) == - (INPUT_SAW_CR | CHANNEL_EOF)) { - result[0] = '\r'; - ResetFlag(statePtr, INPUT_SAW_CR); - return 1; - } - return 0; - } + int bytesRead, bytesWritten; + ChannelBuffer *bufPtr = statePtr->inQueueHead; /* - * Copy the current chunk and replace "\r\n" with "\n" (but not - * standalone "\r"!). + * Don't read more data if we have what we need. */ - if (bytesInBuffer < space) { - space = bytesInBuffer; - } - memcpy(result, RemovePoint(bufPtr), (size_t) space); - bufPtr->nextRemoved += space; - copied = space; + while (!bufPtr || /* We got no buffer! OR */ + (!IsBufferFull(bufPtr) && /* Our buffer has room AND */ + (BytesLeft(bufPtr) < bytesToRead))) { + /* Not enough bytes in it yet + * to fill the dst */ + int code; - end = result + copied; - dst = result; - for (src = result; src < end; src++) { - curByte = *src; - if (curByte == '\n') { - ResetFlag(statePtr, INPUT_SAW_CR); - } else if (GotFlag(statePtr, INPUT_SAW_CR)) { - ResetFlag(statePtr, INPUT_SAW_CR); - *dst = '\r'; - dst++; - } - if (curByte == '\r') { - SetFlag(statePtr, INPUT_SAW_CR); - } else { - *dst = (char) curByte; - dst++; - } - } - copied = dst - result; - break; - } - case TCL_TRANSLATE_AUTO: { - char *src, *end, *dst; - int curByte; - - if (bytesInBuffer == 0) { - return 0; - } + moreData: + code = GetInput(chanPtr); + bufPtr = statePtr->inQueueHead; - /* - * Loop over the current buffer, converting "\r" and "\r\n" to "\n". - */ + assert(bufPtr != NULL); - if (bytesInBuffer < space) { - space = bytesInBuffer; - } - memcpy(result, RemovePoint(bufPtr), (size_t) space); - bufPtr->nextRemoved += space; - copied = space; + if (GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED)) { + /* + * Further reads cannot do any more. + */ - end = result + copied; - dst = result; - for (src = result; src < end; src++) { - curByte = *src; - if (curByte == '\r') { - SetFlag(statePtr, INPUT_SAW_CR); - *dst = '\n'; - dst++; - } else { - if ((curByte != '\n') || !GotFlag(statePtr, INPUT_SAW_CR)) { - *dst = (char) curByte; - dst++; - } - ResetFlag(statePtr, INPUT_SAW_CR); + break; } - } - copied = dst - result; - break; - } - default: - Tcl_Panic("unknown eol translation mode"); - } - - /* - * If an in-stream EOF character is set for this channel, check that the - * input we copied so far does not contain the EOF char. If it does, copy - * only up to and excluding that character. - */ - if (statePtr->inEofChar != 0) { - for (i = 0; i < copied; i++) { - if (result[i] == (char) statePtr->inEofChar) { + if (code) { /* - * Set sticky EOF so that no further input is presented to the - * caller. - */ + * Read error + */ - SetFlag(statePtr, CHANNEL_EOF | CHANNEL_STICKY_EOF); - statePtr->inputEncodingFlags |= TCL_ENCODING_END; - copied = i; - break; + UpdateInterest(chanPtr); + TclChannelRelease((Tcl_Channel)chanPtr); + return -1; } - } - } - - /* - * If the current buffer is empty recycle it. - */ - if (IsBufferEmpty(bufPtr)) { - statePtr->inQueueHead = bufPtr->nextPtr; - if (statePtr->inQueueHead == NULL) { - statePtr->inQueueTail = NULL; + assert(IsBufferFull(bufPtr)); } - RecycleBuffer(statePtr, bufPtr, 0); - } - /* - * Return the number of characters copied into the result buffer. This may - * be different from the number of bytes consumed, because of EOL - * translations. - */ + assert(bufPtr != NULL); - return copied; -} - -/* - *---------------------------------------------------------------------- - * - * CopyBuffer -- - * - * Copy at most one buffer of input to the result space. - * - * Results: - * Number of bytes stored in the result buffer. May return zero if no - * input is available. - * - * Side effects: - * Consumes buffered input. May deallocate one buffer. - * - *---------------------------------------------------------------------- - */ - -static int -CopyBuffer( - Channel *chanPtr, /* Channel from which to read input. */ - char *result, /* Where to store the copied input. */ - int space) /* How many bytes are available in result to - * store the copied input? */ -{ - ChannelBuffer *bufPtr; /* The buffer from which to copy bytes. */ - int bytesInBuffer; /* How many bytes are available to be copied - * in the current input buffer? */ - int copied; /* How many characters were already copied - * into the destination space? */ - - /* - * If there is no input at all, return zero. The invariant is that either - * there is no buffer in the queue, or if the first buffer is empty, it is - * also the last buffer (and thus there is no input in the queue). Note - * also that if the buffer is empty, we don't leave it in the queue, but - * recycle it. - */ - - if (chanPtr->inQueueHead == NULL) { - return 0; - } - bufPtr = chanPtr->inQueueHead; - bytesInBuffer = BytesLeft(bufPtr); - - copied = 0; - - if (bytesInBuffer == 0) { - RecycleBuffer(chanPtr->state, bufPtr, 0); - chanPtr->inQueueHead = NULL; - chanPtr->inQueueTail = NULL; - return 0; - } + bytesRead = BytesLeft(bufPtr); + bytesWritten = bytesToRead; - /* - * Copy the current chunk into the result buffer. - */ + TranslateInputEOL(statePtr, p, RemovePoint(bufPtr), + &bytesWritten, &bytesRead); + bufPtr->nextRemoved += bytesRead; + p += bytesWritten; + bytesToRead -= bytesWritten; - if (bytesInBuffer < space) { - space = bytesInBuffer; - } + if (!IsBufferEmpty(bufPtr)) { + /* + * Buffer is not empty. How can that be? + * + * 0) We stopped early because we got all the bytes we were + * seeking. That's fine. + */ - memcpy(result, RemovePoint(bufPtr), (size_t) space); - bufPtr->nextRemoved += space; - copied = space; + if (bytesToRead == 0) { + break; + } - /* - * We don't care about in-stream EOF characters here as the data read here - * may still flow through one or more transformations, i.e. is not in its - * final state yet. - */ + /* + * 1) We're @EOF because we saw eof char. + */ - /* - * If the current buffer is empty recycle it. - */ + if (GotFlag(statePtr, CHANNEL_STICKY_EOF)) { + break; + } - if (IsBufferEmpty(bufPtr)) { - chanPtr->inQueueHead = bufPtr->nextPtr; - if (chanPtr->inQueueHead == NULL) { - chanPtr->inQueueTail = NULL; - } - RecycleBuffer(chanPtr->state, bufPtr, 0); - } + /* + * 2) The buffer holds a \r while in CRLF translation, followed by + * the end of the buffer. + */ - /* - * Return the number of characters copied into the result buffer. - */ + assert(statePtr->inputTranslation == TCL_TRANSLATE_CRLF); + assert(RemovePoint(bufPtr)[0] == '\r'); + assert(BytesLeft(bufPtr) == 1); - return copied; -} - -/* - *---------------------------------------------------------------------- - * - * DoWrite -- - * - * Puts a sequence of characters into an output buffer, may queue the - * buffer for output if it gets full, and also remembers whether the - * current buffer is ready e.g. if it contains a newline and we are in - * line buffering mode. - * - * Results: - * The number of bytes written or -1 in case of error. If -1, - * Tcl_GetErrno will return the error code. - * - * Side effects: - * May buffer up output and may cause output to be produced on the - * channel. - * - *---------------------------------------------------------------------- - */ + if (bufPtr->nextPtr == NULL) { + /* + * There's no more buffered data... + */ -static int -DoWrite( - Channel *chanPtr, /* The channel to buffer output for. */ - 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; - 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 its following NL. */ - int i; /* Loop index for newline search. */ - int destCopied; /* How many bytes were used in this - * destination buffer to hold the output? */ - int totalDestCopied; /* How many bytes total were copied to the - * channel buffer? */ - int srcCopied; /* How many bytes were copied from the source - * string? */ - char *destPtr; /* Where in line to copy to? */ + if (statePtr->flags & CHANNEL_EOF) { + /* + * ...and there never will be. + */ - /* - * If we are in network (or windows) translation mode, record the fact - * that we have not yet sent a CR to the channel. - */ + *p++ = '\r'; + bytesToRead--; + bufPtr->nextRemoved++; + } else if (statePtr->flags & CHANNEL_BLOCKED) { + /* + * ...and we cannot get more now. + */ - crsent = 0; + SetFlag(statePtr, CHANNEL_NEED_MORE_DATA); + break; + } else { + /* + * ...so we need to get some. + */ - /* - * Loop filling buffers and flushing them until all output has been - * consumed. - */ + goto moreData; + } + } - srcCopied = 0; - totalDestCopied = 0; + if (bufPtr->nextPtr) { + /* + * There's a next buffer. Shift orphan \r to it. + */ - while (srcLen > 0) { - /* - * Make sure there is a current output buffer to accept output. - */ + ChannelBuffer *nextPtr = bufPtr->nextPtr; - if (statePtr->curOutPtr == NULL) { - statePtr->curOutPtr = AllocChannelBuffer(statePtr->bufSize); + nextPtr->nextRemoved -= 1; + RemovePoint(nextPtr)[0] = '\r'; + bufPtr->nextRemoved++; + } } - outBufPtr = statePtr->curOutPtr; - - destCopied = SpaceLeft(outBufPtr); - if (destCopied > srcLen) { - destCopied = srcLen; + if (IsBufferEmpty(bufPtr)) { + statePtr->inQueueHead = bufPtr->nextPtr; + if (statePtr->inQueueHead == NULL) { + statePtr->inQueueTail = NULL; + } + RecycleBuffer(statePtr, bufPtr, 0); + bufPtr = statePtr->inQueueHead; } - destPtr = InsertPoint(outBufPtr); - switch (statePtr->outputTranslation) { - case TCL_TRANSLATE_LF: - srcCopied = destCopied; - memcpy(destPtr, src, (size_t) destCopied); + if ((GotFlag(statePtr, CHANNEL_NONBLOCKING) || allowShortReads) + && GotFlag(statePtr, CHANNEL_BLOCKED)) { break; - case TCL_TRANSLATE_CR: - srcCopied = destCopied; - memcpy(destPtr, src, (size_t) destCopied); - for (dPtr = destPtr; dPtr < destPtr + destCopied; dPtr++) { - if (*dPtr == '\n') { - *dPtr = '\r'; - } - } - break; - case TCL_TRANSLATE_CRLF: - for (srcCopied = 0, dPtr = destPtr, sPtr = src; - dPtr < destPtr + destCopied; - dPtr++, sPtr++, srcCopied++) { - if (*sPtr == '\n') { - if (crsent) { - *dPtr = '\n'; - crsent = 0; - } else { - *dPtr = '\r'; - crsent = 1; - sPtr--, srcCopied--; - } - } else { - *dPtr = *sPtr; - } - } - break; - case TCL_TRANSLATE_AUTO: - Tcl_Panic("Tcl_Write: AUTO output translation mode not supported"); - default: - Tcl_Panic("Tcl_Write: unknown output translation mode"); } /* - * The current buffer is ready for output if it is full, or if it - * contains a newline and this channel is line-buffered, or if it - * contains any output and this channel is unbuffered. + * When there's no buffered data to read, and we're at EOF, escape to + * the caller. */ - outBufPtr->nextAdded += destCopied; - if (!GotFlag(statePtr, BUFFER_READY)) { - if (IsBufferFull(outBufPtr)) { - SetFlag(statePtr, BUFFER_READY); - } else if (GotFlag(statePtr, CHANNEL_LINEBUFFERED)) { - for (sPtr = src, i = 0, foundNewline = 0; - (i < srcCopied) && (!foundNewline); - i++, sPtr++) { - if (*sPtr == '\n') { - foundNewline = 1; - break; - } - } - if (foundNewline) { - SetFlag(statePtr, BUFFER_READY); - } - } else if (GotFlag(statePtr, CHANNEL_UNBUFFERED)) { - SetFlag(statePtr, BUFFER_READY); - } - } - - totalDestCopied += srcCopied; - src += srcCopied; - srcLen -= srcCopied; - - if (GotFlag(statePtr, BUFFER_READY)) { - if (FlushChannel(NULL, chanPtr, 0) != 0) { - return -1; - } + if (GotFlag(statePtr, CHANNEL_EOF) + && (bufPtr == NULL || IsBufferEmpty(bufPtr))) { + break; } - } /* Closes "while" */ + } + if (bytesToRead == 0) { + ResetFlag(statePtr, CHANNEL_BLOCKED); + } - return totalDestCopied; + assert(!GotFlag(statePtr, CHANNEL_EOF) + || GotFlag(statePtr, CHANNEL_STICKY_EOF) + || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); + assert(!(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) + == (CHANNEL_EOF|CHANNEL_BLOCKED))); + UpdateInterest(chanPtr); + TclChannelRelease((Tcl_Channel)chanPtr); + return (int)(p - dst); } /* @@ -10154,12 +10015,16 @@ StopCopy( CopyState *csPtr) /* State for bg copy to stop . */ { ChannelState *inStatePtr, *outStatePtr; + Tcl_Channel inChan, outChan; + int nonBlocking; if (!csPtr) { return; } + inChan = (Tcl_Channel) csPtr->readPtr; + outChan = (Tcl_Channel) csPtr->writePtr; inStatePtr = csPtr->readPtr->state; outStatePtr = csPtr->writePtr->state; @@ -10184,12 +10049,12 @@ StopCopy( csPtr->writeFlags & (CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED); if (csPtr->cmdPtr) { - Tcl_DeleteChannelHandler((Tcl_Channel) csPtr->readPtr, CopyEventProc, - csPtr); - if (csPtr->readPtr != csPtr->writePtr) { - Tcl_DeleteChannelHandler((Tcl_Channel) csPtr->writePtr, - CopyEventProc, csPtr); + Tcl_DeleteChannelHandler(inChan, CopyEventProc, csPtr); + if (inChan != outChan) { + Tcl_DeleteChannelHandler(outChan, CopyEventProc, csPtr); } + Tcl_DeleteChannelHandler(inChan, MBEvent, csPtr); + Tcl_DeleteChannelHandler(outChan, MBEvent, csPtr); TclDecrRefCount(csPtr->cmdPtr); } inStatePtr->csPtrR = NULL; @@ -10223,12 +10088,15 @@ StackSetBlockMode( { int result = 0; Tcl_DriverBlockModeProc *blockModeProc; + ChannelState *statePtr = chanPtr->state; /* * Start at the top of the channel stack + * TODO: Examine what can go wrong when blockModeProc calls + * disturb the stacking state of the channel. */ - chanPtr = chanPtr->state->topChanPtr; + chanPtr = statePtr->topChanPtr; while (chanPtr != NULL) { blockModeProc = Tcl_ChannelBlockModeProc(chanPtr->typePtr); if (blockModeProc != NULL) { @@ -11330,126 +11198,11 @@ DupChannelIntRep( register Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not * currently have an internal rep.*/ { - ChannelState *statePtr = GET_CHANNELSTATE(srcPtr); - Interp *interpPtr = GET_CHANNELINTERP(srcPtr); - - SET_CHANNELSTATE(copyPtr, statePtr); - SET_CHANNELINTERP(copyPtr, interpPtr); - Tcl_Preserve(statePtr); - copyPtr->typePtr = &tclChannelType; -} - -/* - *---------------------------------------------------------------------- - * - * SetChannelFromAny -- - * - * Create an internal representation of type "Channel" for an object. - * - * Results: - * This operation always succeeds and returns TCL_OK. - * - * Side effects: - * Any old internal reputation for objPtr is freed and the internal - * representation is set to "Channel". - * - *---------------------------------------------------------------------- - */ - -static int -SetChannelFromAny( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr) /* The object to convert. */ -{ - ChannelState *statePtr; - Interp *interpPtr; - - if (interp == NULL) { - return TCL_ERROR; - } - if (objPtr->typePtr == &tclChannelType) { - /* - * The channel is valid until any call to DetachChannel occurs. - * Ensure consistency checks are done. - */ - - statePtr = GET_CHANNELSTATE(objPtr); - interpPtr = GET_CHANNELINTERP(objPtr); - if (GotFlag(statePtr, CHANNEL_TAINTED|CHANNEL_CLOSED)) { - ResetFlag(statePtr, CHANNEL_TAINTED); - Tcl_Release(statePtr); - UpdateStringOfChannel(objPtr); - objPtr->typePtr = NULL; - } else if (interpPtr != (Interp*) interp) { - Tcl_Release(statePtr); - UpdateStringOfChannel(objPtr); - objPtr->typePtr = NULL; - } - } - if (objPtr->typePtr != &tclChannelType) { - Tcl_Channel chan; - - /* - * We need a valid string with which to check for a valid channel, but - * make sure not to free internal rep until validated. [Bug 1847044] - */ - - if ((objPtr->typePtr != NULL) && (objPtr->bytes == NULL)) { - objPtr->typePtr->updateStringProc(objPtr); - } - - chan = Tcl_GetChannel(interp, objPtr->bytes, NULL); - if (chan == NULL) { - return TCL_ERROR; - } + ResolvedChanName *resPtr = srcPtr->internalRep.twoPtrValue.ptr1; - TclFreeIntRep(objPtr); - statePtr = ((Channel *) chan)->state; - Tcl_Preserve(statePtr); - SET_CHANNELSTATE(objPtr, statePtr); - SET_CHANNELINTERP(objPtr, interp); - objPtr->typePtr = &tclChannelType; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * UpdateStringOfChannel -- - * - * Update the string representation for an object whose internal - * representation is "Channel". - * - * Results: - * None. - * - * Side effects: - * The object's string may be set by converting its Unicode represention - * to UTF format. - * - *---------------------------------------------------------------------- - */ - -static void -UpdateStringOfChannel( - Tcl_Obj *objPtr) /* Object with string rep to update. */ -{ - if (objPtr->bytes == NULL) { - ChannelState *statePtr = GET_CHANNELSTATE(objPtr); - const char *name = statePtr->channelName; - - if (name) { - size_t len = strlen(name); - - objPtr->bytes = ckalloc(len + 1); - objPtr->length = len; - memcpy(objPtr->bytes, name, len); - } else { - objPtr->bytes = tclEmptyStringRep; - objPtr->length = 0; - } - } + resPtr->refCount++; + copyPtr->internalRep.twoPtrValue.ptr1 = resPtr; + copyPtr->typePtr = srcPtr->typePtr; } /* @@ -11472,8 +11225,14 @@ static void FreeChannelIntRep( Tcl_Obj *objPtr) /* Object with internal rep to free. */ { - Tcl_Release(GET_CHANNELSTATE(objPtr)); + ResolvedChanName *resPtr = objPtr->internalRep.twoPtrValue.ptr1; + objPtr->typePtr = NULL; + if (resPtr->refCount-- > 1) { + return; + } + Tcl_Release(resPtr->statePtr); + ckfree(resPtr); } #if 0 @@ -11497,20 +11256,14 @@ DumpFlags( ChanFlag('n', CHANNEL_NONBLOCKING); ChanFlag('l', CHANNEL_LINEBUFFERED); ChanFlag('u', CHANNEL_UNBUFFERED); - ChanFlag('R', BUFFER_READY); ChanFlag('F', BG_FLUSH_SCHEDULED); ChanFlag('c', CHANNEL_CLOSED); ChanFlag('E', CHANNEL_EOF); ChanFlag('S', CHANNEL_STICKY_EOF); ChanFlag('B', CHANNEL_BLOCKED); ChanFlag('/', INPUT_SAW_CR); - ChanFlag('*', INPUT_NEED_NL); ChanFlag('D', CHANNEL_DEAD); ChanFlag('R', CHANNEL_RAW_MODE); -#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING - ChanFlag('T', CHANNEL_TIMER_FEV); - ChanFlag('H', CHANNEL_HAS_MORE_DATA); -#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ ChanFlag('x', CHANNEL_INCLOSE); buf[i] ='\0'; diff --git a/generic/tclIO.h b/generic/tclIO.h index e84f300..07c54fa 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -36,6 +36,7 @@ */ typedef struct ChannelBuffer { + int refCount; /* Current uses count */ int nextAdded; /* The next position into which a character * will be put in the buffer. */ int nextRemoved; /* Position of next byte to be removed from @@ -111,6 +112,8 @@ typedef struct Channel { ChannelBuffer *inQueueHead; /* Points at first buffer in input queue. */ ChannelBuffer *inQueueTail; /* Points at last buffer in input queue. */ + + int refCount; } Channel; /* @@ -123,7 +126,7 @@ typedef struct Channel { */ typedef struct ChannelState { - const char *channelName; /* The name of the channel instance in Tcl + 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 @@ -211,6 +214,8 @@ typedef struct ChannelState { * because it happened in the background. The * value is the chanMg, if any. #219's * companion to 'unreportedError'. */ + size_t epoch; /* Used to test validity of stored channelname + * lookup results. */ } ChannelState; /* @@ -226,11 +231,6 @@ typedef struct ChannelState { * flushed after every newline. */ #define CHANNEL_UNBUFFERED (1<<5) /* Output to the channel must always * be flushed immediately. */ -#define BUFFER_READY (1<<6) /* Current output buffer (the - * curOutPtr field in the channel - * structure) should be output as soon - * as possible even though it may not - * be full. */ #define BG_FLUSH_SCHEDULED (1<<7) /* A background flush of the queued * output buffers has been * scheduled. */ @@ -252,9 +252,6 @@ typedef struct ChannelState { #define INPUT_SAW_CR (1<<12) /* Channel is in CRLF eol input * translation mode and the last byte * seen was a "\r". */ -#define INPUT_NEED_NL (1<<15) /* Saw a '\r' at end of last buffer, - * and there should be a '\n' at - * beginning of next buffer. */ #define CHANNEL_DEAD (1<<13) /* The channel has been closed by the * exit handler (on exit) but not * deallocated. When any IO operation @@ -274,39 +271,12 @@ typedef struct ChannelState { * changes. */ #define CHANNEL_RAW_MODE (1<<16) /* When set, notes that the Raw API is * being used. */ -#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING -#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) */ -#define CHANNEL_HAS_MORE_DATA (1<<18) /* Set by NotifyChannel for a channel - * if and only if the channel is - * configured non-blocking, the driver - * for said channel has no - * blockmodeproc, and data has arrived - * for reading at the OS level). A - * GetInput will pass reading from the - * driver if the channel is - * non-blocking, without blockmode - * proc and the flag has not been set. - * A read will be performed if the - * flag is set. This will reset the - * flag as well. */ -#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ #define CHANNEL_INCLOSE (1<<19) /* Channel is currently being closed. * Its structures are still live and * usable, but it may not be closed * again from within the close * handler. */ -#define CHANNEL_TAINTED (1<<20) /* Channel stack structure has changed. - * Used by Channel Tcl_Obj type to - * determine if we have to revalidate - * the channel. */ #define CHANNEL_CLOSEDWRITE (1<<21) /* Channel write side has been closed. * No further Tcl-level write IO on * the channel is allowed. */ diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 1673bce..87bf415 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -16,7 +16,7 @@ */ typedef struct AcceptCallback { - char *script; /* Script to invoke. */ + Tcl_Obj *script; /* Script to invoke. */ Tcl_Interp *interp; /* Interpreter in which to run it. */ } AcceptCallback; @@ -25,7 +25,7 @@ typedef struct AcceptCallback { * It must be per-thread because of std channel limitations. */ -typedef struct ThreadSpecificData { +typedef struct { int initialized; /* Set to 1 when the module is initialized. */ Tcl_Obj *stdoutObjPtr; /* Cached stdout channel Tcl_Obj */ } ThreadSpecificData; @@ -37,8 +37,7 @@ static Tcl_ThreadDataKey dataKey; */ static void FinalizeIOCmdTSD(ClientData clientData); -static void AcceptCallbackProc(ClientData callbackData, - Tcl_Channel chan, char *address, int port); +static Tcl_TcpAcceptProc AcceptCallbackProc; static int ChanPendingObjCmd(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -114,7 +113,6 @@ Tcl_PutsObjCmd( int newline; /* Add a newline at end? */ int result; /* Result of puts operation. */ int mode; /* Mode in which channel is opened. */ - ThreadSpecificData *tsdPtr; switch (objc) { case 2: /* [puts $x] */ @@ -139,7 +137,7 @@ Tcl_PutsObjCmd( chanObjPtr = objv[2]; string = objv[3]; break; -#if TCL_MAJOR_VERSION < 9 +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 } else if (strcmp(TclGetString(objv[3]), "nonewline") == 0) { /* * The code below provides backwards compatibility with an old @@ -161,7 +159,7 @@ Tcl_PutsObjCmd( } if (chanObjPtr == NULL) { - tsdPtr = TCL_TSD_INIT(&dataKey); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!tsdPtr->initialized) { tsdPtr->initialized = 1; @@ -181,6 +179,7 @@ Tcl_PutsObjCmd( return TCL_ERROR; } + TclChannelPreserve(chan); result = Tcl_WriteObj(chan, string); if (result < 0) { goto error; @@ -191,6 +190,7 @@ Tcl_PutsObjCmd( goto error; } } + TclChannelRelease(chan); return TCL_OK; /* @@ -205,6 +205,7 @@ Tcl_PutsObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf("error writing \"%s\": %s", TclGetString(chanObjPtr), Tcl_PosixError(interp))); } + TclChannelRelease(chan); return TCL_ERROR; } @@ -252,6 +253,7 @@ Tcl_FlushObjCmd( return TCL_ERROR; } + TclChannelPreserve(chan); if (Tcl_Flush(chan) != TCL_OK) { /* * TIP #219. @@ -265,8 +267,10 @@ Tcl_FlushObjCmd( "error flushing \"%s\": %s", TclGetString(chanObjPtr), Tcl_PosixError(interp))); } + TclChannelRelease(chan); return TCL_ERROR; } + TclChannelRelease(chan); return TCL_OK; } @@ -299,6 +303,7 @@ Tcl_GetsObjCmd( int lineLen; /* Length of line just read. */ int mode; /* Mode in which channel is opened. */ Tcl_Obj *linePtr, *chanObjPtr; + int code = TCL_OK; if ((objc != 2) && (objc != 3)) { Tcl_WrongNumArgs(interp, 1, objv, "channelId ?varName?"); @@ -315,6 +320,7 @@ Tcl_GetsObjCmd( return TCL_ERROR; } + TclChannelPreserve(chan); linePtr = Tcl_NewObj(); lineLen = Tcl_GetsObj(chan, linePtr); if (lineLen < 0) { @@ -333,20 +339,24 @@ Tcl_GetsObjCmd( "error reading \"%s\": %s", TclGetString(chanObjPtr), Tcl_PosixError(interp))); } - return TCL_ERROR; + code = TCL_ERROR; + goto done; } lineLen = -1; } if (objc == 3) { if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr, TCL_LEAVE_ERR_MSG) == NULL) { - return TCL_ERROR; + code = TCL_ERROR; + goto done; } Tcl_SetObjResult(interp, Tcl_NewIntObj(lineLen)); } else { Tcl_SetObjResult(interp, linePtr); } - return TCL_OK; + done: + TclChannelRelease(chan); + return code; } /* @@ -429,7 +439,7 @@ Tcl_ReadObjCmd( if (i < objc) { if ((TclGetIntFromObj(interp, objv[i], &toRead) != TCL_OK) || (toRead < 0)) { -#if TCL_MAJOR_VERSION < 9 +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 /* * The code below provides backwards compatibility with an old * form of the command that is no longer recommended or @@ -444,7 +454,7 @@ Tcl_ReadObjCmd( TclGetString(objv[i]))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL); return TCL_ERROR; -#if TCL_MAJOR_VERSION < 9 +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 } newline = 1; #endif @@ -453,6 +463,7 @@ Tcl_ReadObjCmd( resultPtr = Tcl_NewObj(); Tcl_IncrRefCount(resultPtr); + TclChannelPreserve(chan); charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0); if (charactersRead < 0) { /* @@ -467,6 +478,7 @@ Tcl_ReadObjCmd( "error reading \"%s\": %s", TclGetString(chanObjPtr), Tcl_PosixError(interp))); } + TclChannelRelease(chan); Tcl_DecrRefCount(resultPtr); return TCL_ERROR; } @@ -485,6 +497,7 @@ Tcl_ReadObjCmd( } } Tcl_SetObjResult(interp, resultPtr); + TclChannelRelease(chan); Tcl_DecrRefCount(resultPtr); return TCL_OK; } @@ -544,6 +557,7 @@ Tcl_SeekObjCmd( mode = modeArray[optionIndex]; } + TclChannelPreserve(chan); result = Tcl_Seek(chan, offset, mode); if (result == Tcl_LongAsWide(-1)) { /* @@ -558,8 +572,10 @@ Tcl_SeekObjCmd( "error during seek on \"%s\": %s", TclGetString(objv[1]), Tcl_PosixError(interp))); } + TclChannelRelease(chan); return TCL_ERROR; } + TclChannelRelease(chan); return TCL_OK; } @@ -590,6 +606,7 @@ Tcl_TellObjCmd( { Tcl_Channel chan; /* The channel to tell on. */ Tcl_WideInt newLoc; + int code; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "channelId"); @@ -605,6 +622,7 @@ Tcl_TellObjCmd( return TCL_ERROR; } + TclChannelPreserve(chan); newLoc = Tcl_Tell(chan); /* @@ -613,7 +631,10 @@ Tcl_TellObjCmd( * them into the regular interpreter result. */ - if (TclChanCaughtErrorBypass(interp, chan)) { + + code = TclChanCaughtErrorBypass(interp, chan); + TclChannelRelease(chan); + if (code) { return TCL_ERROR; } @@ -896,7 +917,7 @@ Tcl_ExecObjCmd( if (string[0] != '-') { break; } - if (Tcl_GetIndexFromObj(interp, objv[skip], options, "switch", + if (Tcl_GetIndexFromObj(interp, objv[skip], options, "option", TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } @@ -910,7 +931,7 @@ Tcl_ExecObjCmd( } } if (objc <= skip) { - Tcl_WrongNumArgs(interp, 1, objv, "?-switch ...? arg ?arg ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "?-option ...? arg ?arg ...?"); return TCL_ERROR; } @@ -1350,15 +1371,22 @@ AcceptCallbackProc( */ if (acceptCallbackPtr->interp != NULL) { - char portBuf[TCL_INTEGER_SPACE]; - char *script = acceptCallbackPtr->script; Tcl_Interp *interp = acceptCallbackPtr->interp; - int result; + Tcl_Obj *script, *objv[2]; + int result = TCL_OK; - Tcl_Preserve(script); - Tcl_Preserve(interp); + objv[0] = acceptCallbackPtr->script; + objv[1] = Tcl_NewListObj(3, NULL); + Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewStringObj( + Tcl_GetChannelName(chan), -1)); + Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewStringObj(address, -1)); + Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewIntObj(port)); + + script = Tcl_ConcatObj(2, objv); + Tcl_IncrRefCount(script); + Tcl_DecrRefCount(objv[1]); - TclFormatInt(portBuf, port); + Tcl_Preserve(interp); Tcl_RegisterChannel(interp, chan); /* @@ -1368,8 +1396,9 @@ AcceptCallbackProc( Tcl_RegisterChannel(NULL, chan); - result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan), - " ", address, " ", portBuf, NULL); + result = Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT|TCL_EVAL_GLOBAL); + Tcl_DecrRefCount(script); + if (result != TCL_OK) { Tcl_BackgroundException(interp, result); Tcl_UnregisterChannel(interp, chan); @@ -1383,7 +1412,6 @@ AcceptCallbackProc( Tcl_UnregisterChannel(NULL, chan); Tcl_Release(interp); - Tcl_Release(script); } else { /* * The interpreter has been deleted, so there is no useful way to use @@ -1427,7 +1455,7 @@ TcpServerCloseProc( UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp, acceptCallbackPtr); } - Tcl_EventuallyFree(acceptCallbackPtr->script, TCL_DYNAMIC); + Tcl_DecrRefCount(acceptCallbackPtr->script); ckfree(acceptCallbackPtr); } @@ -1456,13 +1484,18 @@ Tcl_SocketObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { static const char *const socketOptions[] = { - "-async", "-myaddr", "-myport", "-server", NULL + "-async", "-myaddr", "-myport", "-reuseaddr", "-reuseport", "-server", + NULL }; enum socketOptions { - SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER + SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_REUSEADDR, SKT_REUSEPORT, + SKT_SERVER }; - int optionIndex, a, server = 0, port, myport = 0, async = 0; - const char *host, *script = NULL, *myaddr = NULL; + int optionIndex, a, server = 0, myport = 0, async = 0, reusep = -1, + reusea = -1; + unsigned int flags = 0; + const char *host, *port, *myaddr = NULL; + Tcl_Obj *script = NULL; Tcl_Channel chan; if (TclpHasSockets(interp) != TCL_OK) { @@ -1525,7 +1558,29 @@ Tcl_SocketObjCmd( "no argument given for -server option", -1)); return TCL_ERROR; } - script = TclGetString(objv[a]); + script = objv[a]; + break; + case SKT_REUSEADDR: + a++; + if (a >= objc) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "no argument given for -reuseaddr option", -1)); + return TCL_ERROR; + } + if (Tcl_GetBooleanFromObj(interp, objv[a], &reusea) != TCL_OK) { + return TCL_ERROR; + } + break; + case SKT_REUSEPORT: + a++; + if (a >= objc) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "no argument given for -reuseport option", -1)); + return TCL_ERROR; + } + if (Tcl_GetBooleanFromObj(interp, objv[a], &reusep) != TCL_OK) { + return TCL_ERROR; + } break; default: Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions"); @@ -1550,32 +1605,63 @@ Tcl_SocketObjCmd( "?-myaddr addr? ?-myport myport? ?-async? host port"); iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS; Tcl_WrongNumArgs(interp, 1, objv, - "-server command ?-myaddr addr? port"); + "-server command ?-reuseaddr boolean? ?-reuseport boolean? " + "?-myaddr addr? port"); return TCL_ERROR; } - if (a == objc-1) { - if (TclSockGetPort(interp, TclGetString(objv[a]), "tcp", - &port) != TCL_OK) { - return TCL_ERROR; - } - } else { + if (!server && (reusea != -1 || reusep != -1)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "options -reuseaddr and -reuseport are only valid for servers", + -1)); + return TCL_ERROR; + } + + /* + * Set the options to their default value if the user didn't override + * their value. + */ + + if (reusep == -1) { + reusep = 0; + } + if (reusea == -1) { + reusea = 1; + } + + /* + * Build the bitset with the flags values. + */ + + if (reusea) { + flags |= TCL_TCPSERVER_REUSEADDR; + } + if (reusep) { + flags |= TCL_TCPSERVER_REUSEPORT; + } + + /* + * All the arguments should have been parsed by now, 'a' points to the + * last one, the port number. + */ + + if (a != objc-1) { goto wrongNumArgs; } + port = TclGetString(objv[a]); + if (server) { - AcceptCallback *acceptCallbackPtr = - ckalloc(sizeof(AcceptCallback)); - unsigned len = strlen(script) + 1; - char *copyScript = ckalloc(len); + AcceptCallback *acceptCallbackPtr = ckalloc(sizeof(AcceptCallback)); - memcpy(copyScript, script, len); - acceptCallbackPtr->script = copyScript; + Tcl_IncrRefCount(script); + acceptCallbackPtr->script = script; acceptCallbackPtr->interp = interp; - chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc, - acceptCallbackPtr); + + chan = Tcl_OpenTcpServerEx(interp, port, host, flags, + AcceptCallbackProc, acceptCallbackPtr); if (chan == NULL) { - ckfree(copyScript); + Tcl_DecrRefCount(script); ckfree(acceptCallbackPtr); return TCL_ERROR; } @@ -1597,7 +1683,13 @@ Tcl_SocketObjCmd( Tcl_CreateCloseHandler(chan, TcpServerCloseProc, acceptCallbackPtr); } else { - chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async); + int portNum; + + if (TclSockGetPort(interp, port, "tcp", &portNum) != TCL_OK) { + return TCL_ERROR; + } + + chan = Tcl_OpenTcpClient(interp, portNum, host, myaddr, myport, async); if (chan == NULL) { return TCL_ERROR; } @@ -1673,7 +1765,7 @@ Tcl_FcopyObjCmd( toRead = -1; cmdPtr = NULL; for (i = 3; i < objc; i += 2) { - if (Tcl_GetIndexFromObj(interp, objv[i], switches, "switch", 0, + if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c index bfe6a10..c1e8c44 100644 --- a/generic/tclIOGT.c +++ b/generic/tclIOGT.c @@ -187,6 +187,7 @@ struct TransformChannelData { Tcl_Channel self; /* Our own Channel handle. */ int readIsFlushed; /* Flag to note whether in.flushProc was * called or not. */ + int eofPending; /* Flag: EOF seen down, not raised up */ int flags; /* Currently CHANNEL_ASYNC or zero. */ int watchMask; /* Current watch/event/interest mask. */ int mode; /* Mode of parent channel, OR'ed combination @@ -210,7 +211,27 @@ struct TransformChannelData { * a transformation of incoming data. Also * serves as buffer of all data not yet * consumed by the reader. */ + size_t refCount; }; + +static void +PreserveData( + TransformChannelData *dataPtr) +{ + dataPtr->refCount++; +} + +static void +ReleaseData( + TransformChannelData *dataPtr) +{ + if (dataPtr->refCount-- > 1) { + return; + } + ResultClear(&dataPtr->result); + Tcl_DecrRefCount(dataPtr->command); + ckfree(dataPtr); +} /* *---------------------------------------------------------------------- @@ -240,6 +261,7 @@ TclChannelTransform( Channel *chanPtr; /* The actual channel. */ ChannelState *statePtr; /* State info for channel. */ int mode; /* Read/write mode of the channel. */ + int objc; TransformChannelData *dataPtr; Tcl_DString ds; @@ -247,6 +269,12 @@ TclChannelTransform( return TCL_ERROR; } + if (TCL_OK != Tcl_ListObjLength(interp, cmdObjPtr, &objc)) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("-command value is not a list", -1)); + return TCL_ERROR; + } + chanPtr = (Channel *) chan; statePtr = chanPtr->state; chanPtr = statePtr->topChanPtr; @@ -261,16 +289,17 @@ TclChannelTransform( dataPtr = ckalloc(sizeof(TransformChannelData)); + dataPtr->refCount = 1; Tcl_DStringInit(&ds); Tcl_GetChannelOption(interp, chan, "-blocking", &ds); dataPtr->readIsFlushed = 0; + dataPtr->eofPending = 0; dataPtr->flags = 0; if (ds.string[0] == '0') { dataPtr->flags |= CHANNEL_ASYNC; } Tcl_DStringFree(&ds); - dataPtr->self = chan; dataPtr->watchMask = 0; dataPtr->mode = mode; dataPtr->timer = NULL; @@ -286,19 +315,20 @@ TclChannelTransform( if (dataPtr->self == NULL) { Tcl_AppendPrintfToObj(Tcl_GetObjResult(interp), "\nfailed to stack channel \"%s\"", Tcl_GetChannelName(chan)); - Tcl_DecrRefCount(dataPtr->command); - ResultClear(&dataPtr->result); - ckfree(dataPtr); + ReleaseData(dataPtr); return TCL_ERROR; } + Tcl_Preserve(dataPtr->self); /* * At last initialize the transformation at the script level. */ + PreserveData(dataPtr); if ((dataPtr->mode & TCL_WRITABLE) && ExecuteCallback(dataPtr, NULL, A_CREATE_WRITE, NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE) != TCL_OK){ Tcl_UnstackChannel(interp, chan); + ReleaseData(dataPtr); return TCL_ERROR; } @@ -307,9 +337,11 @@ TclChannelTransform( ExecuteCallback(dataPtr, NULL, A_DELETE_WRITE, NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE); Tcl_UnstackChannel(interp, chan); + ReleaseData(dataPtr); return TCL_ERROR; } + ReleaseData(dataPtr); return TCL_OK; } @@ -350,7 +382,10 @@ ExecuteCallback( unsigned char *resBuf; Tcl_InterpState state = NULL; int res = TCL_OK; - Tcl_Obj *command = Tcl_DuplicateObj(dataPtr->command); + Tcl_Obj *command = TclListObjCopy(NULL, dataPtr->command); + Tcl_Interp *eval = dataPtr->interp; + + Tcl_Preserve(eval); /* * Step 1, create the complete command to execute. Do this by appending @@ -361,26 +396,18 @@ ExecuteCallback( */ if (preserve == P_PRESERVE) { - state = Tcl_SaveInterpState(dataPtr->interp, res); + state = Tcl_SaveInterpState(eval, res); } Tcl_IncrRefCount(command); - res = Tcl_ListObjAppendElement(dataPtr->interp, command, - Tcl_NewStringObj((char *) op, -1)); - if (res != TCL_OK) { - goto cleanup; - } + Tcl_ListObjAppendElement(NULL, command, Tcl_NewStringObj((char *) op, -1)); /* * Use a byte-array to prevent the misinterpretation of binary data coming * through as UTF while at the tcl level. */ - res = Tcl_ListObjAppendElement(dataPtr->interp, command, - Tcl_NewByteArrayObj(buf, bufLen)); - if (res != TCL_OK) { - goto cleanup; - } + Tcl_ListObjAppendElement(NULL, command, Tcl_NewByteArrayObj(buf, bufLen)); /* * Step 2, execute the command at the global level of the interpreter used @@ -390,13 +417,14 @@ ExecuteCallback( * current interpreter. Don't copy if in preservation mode. */ - res = Tcl_EvalObjEx(dataPtr->interp, command, TCL_EVAL_GLOBAL); + res = Tcl_EvalObjEx(eval, command, TCL_EVAL_GLOBAL); Tcl_DecrRefCount(command); command = NULL; - if ((res != TCL_OK) && (interp != NULL) && (dataPtr->interp != interp) + if ((res != TCL_OK) && (interp != NULL) && (eval != interp) && (preserve == P_NO_PRESERVE)) { - Tcl_SetObjResult(interp, Tcl_GetObjResult(dataPtr->interp)); + Tcl_SetObjResult(interp, Tcl_GetObjResult(eval)); + Tcl_Release(eval); return res; } @@ -411,20 +439,26 @@ ExecuteCallback( break; case TRANSMIT_DOWN: - resObj = Tcl_GetObjResult(dataPtr->interp); + if (dataPtr->self == NULL) { + break; + } + resObj = Tcl_GetObjResult(eval); resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen); Tcl_WriteRaw(Tcl_GetStackedChannel(dataPtr->self), (char *) resBuf, resLen); break; case TRANSMIT_SELF: - resObj = Tcl_GetObjResult(dataPtr->interp); + if (dataPtr->self == NULL) { + break; + } + resObj = Tcl_GetObjResult(eval); resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen); Tcl_WriteRaw(dataPtr->self, (char *) resBuf, resLen); break; case TRANSMIT_IBUF: - resObj = Tcl_GetObjResult(dataPtr->interp); + resObj = Tcl_GetObjResult(eval); resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen); ResultAdd(&dataPtr->result, resBuf, resLen); break; @@ -434,24 +468,16 @@ ExecuteCallback( * Interpret result as integer number. */ - resObj = Tcl_GetObjResult(dataPtr->interp); - TclGetIntFromObj(dataPtr->interp, resObj, &dataPtr->maxRead); + resObj = Tcl_GetObjResult(eval); + TclGetIntFromObj(eval, resObj, &dataPtr->maxRead); break; } - Tcl_ResetResult(dataPtr->interp); - if (preserve == P_PRESERVE) { - (void) Tcl_RestoreInterpState(dataPtr->interp, state); - } - return res; - - cleanup: + Tcl_ResetResult(eval); if (preserve == P_PRESERVE) { - (void) Tcl_RestoreInterpState(dataPtr->interp, state); - } - if (command != NULL) { - Tcl_DecrRefCount(command); + (void) Tcl_RestoreInterpState(eval, state); } + Tcl_Release(eval); return res; } @@ -535,6 +561,7 @@ TransformCloseProc( * system rely on (f.e. signaling the close to interested parties). */ + PreserveData(dataPtr); if (dataPtr->mode & TCL_WRITABLE) { ExecuteCallback(dataPtr, interp, A_FLUSH_WRITE, NULL, 0, TRANSMIT_DOWN, P_PRESERVE); @@ -554,14 +581,15 @@ TransformCloseProc( ExecuteCallback(dataPtr, interp, A_DELETE_READ, NULL, 0, TRANSMIT_DONT, P_PRESERVE); } + ReleaseData(dataPtr); /* * General cleanup. */ - ResultClear(&dataPtr->result); - Tcl_DecrRefCount(dataPtr->command); - ckfree(dataPtr); + Tcl_Release(dataPtr->self); + dataPtr->self = NULL; + ReleaseData(dataPtr); return TCL_OK; } @@ -596,9 +624,9 @@ TransformInputProc( * Should assert(dataPtr->mode & TCL_READABLE); */ - if (toRead == 0) { + if (toRead == 0 || dataPtr->self == NULL) { /* - * Catch a no-op. + * Catch a no-op. TODO: Is this a panic()? */ return 0; } @@ -606,6 +634,7 @@ TransformInputProc( gotBytes = 0; downChan = Tcl_GetStackedChannel(dataPtr->self); + PreserveData(dataPtr); while (toRead > 0) { /* * Loop until the request is satisfied (or no data is available from @@ -623,7 +652,7 @@ TransformInputProc( * break out of the loop and return to the caller. */ - return gotBytes; + break; } /* @@ -647,7 +676,18 @@ TransformInputProc( } } /* else: 'maxRead < 0' == Accept the current value of toRead. */ if (toRead <= 0) { - return gotBytes; + break; + } + if (dataPtr->eofPending) { + /* + * Already saw EOF from downChan; don't ask again. + * NOTE: Could move this up to avoid the last maxRead + * execution. Believe this would still be correct behavior, + * but the test suite tests the whole command callback + * sequence, so leave it unchanged for now. + */ + + break; } /* @@ -656,45 +696,35 @@ TransformInputProc( read = Tcl_ReadRaw(downChan, buf, toRead); if (read < 0) { - /* - * Report errors to caller. EAGAIN is a special situation. If we - * had some data before we report that instead of the request to - * re-try. - */ + if (Tcl_InputBlocked(downChan) && (gotBytes > 0)) { + /* + * Zero bytes available from downChan because blocked. + * But nonzero bytes already copied, so total is a + * valid blocked short read. Return to caller. + */ - if ((Tcl_GetErrno() == EAGAIN) && (gotBytes > 0)) { - return gotBytes; + break; } - *errorCodePtr = Tcl_GetErrno(); - return -1; - } else if (read == 0) { /* - * Check wether we hit on EOF in the underlying channel or not. If - * not differentiate between blocking and non-blocking modes. In - * non-blocking mode we ran temporarily out of data. Signal this - * to the caller via EWOULDBLOCK and error return (-1). In the - * other cases we simply return what we got and let the caller - * wait for more. On the other hand, if we got an EOF we have to - * convert and flush all waiting partial data. + * Either downChan is not blocked (there's a real error). + * or it is and there are no bytes copied yet. In either + * case we want to pass the "error" along to the caller, + * either to report an error, or to signal to the caller + * that zero bytes are available because blocked. */ - if (!Tcl_Eof(downChan)) { - if ((gotBytes == 0) && (dataPtr->flags & CHANNEL_ASYNC)) { - *errorCodePtr = EWOULDBLOCK; - return -1; - } - return gotBytes; - } - - if (dataPtr->readIsFlushed) { - /* - * Already flushed, nothing to do anymore. - */ + *errorCodePtr = Tcl_GetErrno(); + gotBytes = -1; + break; + } else if (read == 0) { - return gotBytes; - } + /* + * Zero returned from Tcl_ReadRaw() always indicates EOF + * on the down channel. + */ + dataPtr->eofPending = 1; dataPtr->readIsFlushed = 1; ExecuteCallback(dataPtr, NULL, A_FLUSH_READ, NULL, 0, TRANSMIT_IBUF, P_PRESERVE); @@ -704,7 +734,7 @@ TransformInputProc( * We had nothing to flush. */ - return gotBytes; + break; } continue; /* at: while (toRead > 0) */ @@ -718,10 +748,15 @@ TransformInputProc( if (ExecuteCallback(dataPtr, NULL, A_READ, UCHARP(buf), read, TRANSMIT_IBUF, P_PRESERVE) != TCL_OK) { *errorCodePtr = EINVAL; - return -1; + gotBytes = -1; + break; } } /* while toRead > 0 */ + if (gotBytes == 0) { + dataPtr->eofPending = 0; + } + ReleaseData(dataPtr); return gotBytes; } @@ -762,11 +797,13 @@ TransformOutputProc( return 0; } + PreserveData(dataPtr); if (ExecuteCallback(dataPtr, NULL, A_WRITE, UCHARP(buf), toWrite, TRANSMIT_DOWN, P_NO_PRESERVE) != TCL_OK) { *errorCodePtr = EINVAL; - return -1; + toWrite = -1; } + ReleaseData(dataPtr); return toWrite; } @@ -819,6 +856,7 @@ TransformSeekProc( * request down, unchanged. */ + PreserveData(dataPtr); if (dataPtr->mode & TCL_WRITABLE) { ExecuteCallback(dataPtr, NULL, A_FLUSH_WRITE, NULL, 0, TRANSMIT_DOWN, P_NO_PRESERVE); @@ -829,7 +867,9 @@ TransformSeekProc( P_NO_PRESERVE); ResultClear(&dataPtr->result); dataPtr->readIsFlushed = 0; + dataPtr->eofPending = 0; } + ReleaseData(dataPtr); return parentSeekProc(Tcl_GetChannelInstanceData(parent), offset, mode, errorCodePtr); @@ -890,6 +930,7 @@ TransformWideSeekProc( * request down, unchanged. */ + PreserveData(dataPtr); if (dataPtr->mode & TCL_WRITABLE) { ExecuteCallback(dataPtr, NULL, A_FLUSH_WRITE, NULL, 0, TRANSMIT_DOWN, P_NO_PRESERVE); @@ -900,7 +941,9 @@ TransformWideSeekProc( P_NO_PRESERVE); ResultClear(&dataPtr->result); dataPtr->readIsFlushed = 0; + dataPtr->eofPending = 0; } + ReleaseData(dataPtr); /* * If we have a wide seek capability, we should stick with that. @@ -1055,6 +1098,9 @@ TransformWatchProc( * unchanged. */ + if (dataPtr->self == NULL) { + return; + } downChan = Tcl_GetStackedChannel(dataPtr->self); Tcl_GetChannelType(downChan)->watchProc( diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index cb0282a..354f1fb 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -39,8 +39,10 @@ static int ReflectOutput(ClientData clientData, const char *buf, int toWrite, int *errorCodePtr); static void ReflectWatch(ClientData clientData, int mask); static int ReflectBlock(ClientData clientData, int mode); -#ifdef TCL_THREADS +#if TCL_THREADS static void ReflectThread(ClientData clientData, int action); +static int ReflectEventRun(Tcl_Event *ev, int flags); +static int ReflectEventDelete(Tcl_Event *ev, ClientData cd); #endif static Tcl_WideInt ReflectSeekWide(ClientData clientData, Tcl_WideInt offset, int mode, int *errorCodePtr); @@ -74,7 +76,7 @@ static const Tcl_ChannelType tclRChannelType = { NULL, /* Flush channel. Not used by core. NULL'able */ NULL, /* Handle events. NULL'able */ ReflectSeekWide, /* Move access point (64 bit). NULL'able */ -#ifdef TCL_THREADS +#if TCL_THREADS ReflectThread, /* thread action, tracking owner */ #else NULL, /* thread action */ @@ -95,35 +97,13 @@ typedef struct { * interpreter/thread containing its Tcl * command is gone. */ -#ifdef TCL_THREADS +#if TCL_THREADS Tcl_ThreadId thread; /* Thread the 'interp' belongs to. == Handler thread */ Tcl_ThreadId owner; /* Thread owning the structure. == Channel thread */ #endif - - /* See [==] as well. - * Storage for the command prefix and the additional words required for - * the invocation of methods in the command handler. - * - * argv [0] ... [.] | [argc-2] [argc-1] | [argc] [argc+2] - * cmd ... pfx | method chan | detail1 detail2 - * ~~~~ CT ~~~ ~~ CT ~~ - * - * CT = Belongs to the 'Command handler Thread'. - */ - - int argc; /* Number of preallocated words - 2 */ - Tcl_Obj **argv; /* Preallocated array for calling the handler. - * args[0] is placeholder for cmd word. - * Followed by the arguments in the prefix, - * plus 4 placeholders for method, channel, - * and at most two varying (method specific) - * words. */ - int methods; /* Bitmask of supported methods */ - - /* - * NOTE (9): Should we have predefined shared literals for the method - * names? - */ + Tcl_Obj *cmd; /* Callback command prefix */ + Tcl_Obj *methods; /* Methods to append to command prefix */ + Tcl_Obj *name; /* Name of the channel as created */ int mode; /* Mask of R/W mode */ int interest; /* Mask of events the channel is interested @@ -221,7 +201,7 @@ typedef enum { #define NEGIMPL(a,b) #define HAS(x,f) (x & FLAG(f)) -#ifdef TCL_THREADS +#if TCL_THREADS /* * Thread specific types and structures. * @@ -256,7 +236,7 @@ typedef enum { * sharing problems. */ -typedef struct ForwardParamBase { +typedef struct { int code; /* O: Ok/Fail of the cmd handler */ char *msgStr; /* O: Error message for handler failure */ int mustFree; /* O: True if msgStr is allocated, false if @@ -331,7 +311,7 @@ typedef struct ForwardingResult ForwardingResult; * General event structure, with reference to operation specific data. */ -typedef struct ForwardingEvent { +typedef struct { Tcl_Event event; /* Basic event data, has to be first item */ ForwardingResult *resultPtr; ForwardedOperation op; /* Forwarded driver operation */ @@ -368,7 +348,7 @@ struct ForwardingResult { * results. */ }; -typedef struct ThreadSpecificData { +typedef struct { /* * Table of all reflected channels owned by this thread. This is the * per-thread version of the per-interpreter map. @@ -450,15 +430,15 @@ static ReflectedChannel * NewReflectedChannel(Tcl_Interp *interp, Tcl_Obj *cmdpfxObj, int mode, Tcl_Obj *handleObj); static Tcl_Obj * NextHandle(void); static void FreeReflectedChannel(ReflectedChannel *rcPtr); -static void FreeReflectedChannelArgs(ReflectedChannel *rcPtr); static int InvokeTclMethod(ReflectedChannel *rcPtr, - const char *method, Tcl_Obj *argOneObj, + MethodName method, Tcl_Obj *argOneObj, Tcl_Obj *argTwoObj, Tcl_Obj **resultObjPtr); static ReflectedChannelMap * GetReflectedChannelMap(Tcl_Interp *interp); static void DeleteReflectedChannelMap(ClientData clientData, Tcl_Interp *interp); static int ErrnoReturn(ReflectedChannel *rcPtr, Tcl_Obj *resObj); +static void MarkDead(ReflectedChannel *rcPtr); /* * Global constant strings (messages). ================== @@ -467,16 +447,14 @@ static int ErrnoReturn(ReflectedChannel *rcPtr, Tcl_Obj *resObj); * list-quoting to keep the words of the message together. See also [x]. */ -static const char *msg_read_unsup = "{read not supported by Tcl driver}"; static const char *msg_read_toomuch = "{read delivered more than requested}"; -static const char *msg_write_unsup = "{write not supported by Tcl driver}"; static const char *msg_write_toomuch = "{write wrote more than requested}"; static const char *msg_write_nothing = "{write wrote nothing}"; static const char *msg_seek_beforestart = "{Tried to seek before origin}"; -#ifdef TCL_THREADS +#if TCL_THREADS static const char *msg_send_originlost = "{Channel thread lost}"; -static const char *msg_send_dstlost = "{Owner lost}"; #endif /* TCL_THREADS */ +static const char *msg_send_dstlost = "{Owner lost}"; static const char *msg_dstlost = "-code 1 -level 0 -errorcode NONE -errorinfo {} -errorline 1 {Owner lost}"; /* @@ -583,10 +561,6 @@ TclChanCreateObjCmd( rcId = NextHandle(); rcPtr = NewReflectedChannel(interp, cmdObj, mode, rcId); - chan = Tcl_CreateChannel(&tclRChannelType, TclGetString(rcId), rcPtr, - mode); - rcPtr->chan = chan; - chanPtr = (Channel *) chan; /* * Invoke 'initialize' and validate that the handler is present and ok. @@ -600,7 +574,7 @@ TclChanCreateObjCmd( modeObj = DecodeEventMask(mode); /* assert modeObj.refCount == 1 */ - result = InvokeTclMethod(rcPtr, "initialize", modeObj, NULL, &resObj); + result = InvokeTclMethod(rcPtr, METH_INIT, modeObj, NULL, &resObj); Tcl_DecrRefCount(modeObj); if (result != TCL_OK) { @@ -619,7 +593,7 @@ TclChanCreateObjCmd( if (Tcl_ListObjGetElements(NULL, resObj, &listc, &listv) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s initialize\" returned non-list: %s", - Tcl_GetString(cmdObj), Tcl_GetString(resObj))); + TclGetString(cmdObj), TclGetString(resObj))); Tcl_DecrRefCount(resObj); goto error; } @@ -645,35 +619,35 @@ TclChanCreateObjCmd( if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" does not support all required methods", - Tcl_GetString(cmdObj))); + TclGetString(cmdObj))); goto error; } if ((mode & TCL_READABLE) && !HAS(methods, METH_READ)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" lacks a \"read\" method", - Tcl_GetString(cmdObj))); + TclGetString(cmdObj))); goto error; } if ((mode & TCL_WRITABLE) && !HAS(methods, METH_WRITE)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" lacks a \"write\" method", - Tcl_GetString(cmdObj))); + TclGetString(cmdObj))); goto error; } if (!IMPLIES(HAS(methods, METH_CGET), HAS(methods, METH_CGETALL))) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" supports \"cget\" but not \"cgetall\"", - Tcl_GetString(cmdObj))); + TclGetString(cmdObj))); goto error; } if (!IMPLIES(HAS(methods, METH_CGETALL), HAS(methods, METH_CGET))) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" supports \"cgetall\" but not \"cget\"", - Tcl_GetString(cmdObj))); + TclGetString(cmdObj))); goto error; } @@ -683,7 +657,11 @@ TclChanCreateObjCmd( * Everything is fine now. */ - rcPtr->methods = methods; + chan = Tcl_CreateChannel(&tclRChannelType, TclGetString(rcId), rcPtr, + mode); + rcPtr->chan = chan; + TclChannelPreserve(chan); + chanPtr = (Channel *) chan; if ((methods & NULLABLE_METHODS) != NULLABLE_METHODS) { /* @@ -728,7 +706,7 @@ TclChanCreateObjCmd( Tcl_Panic("TclChanCreateObjCmd: duplicate channel names"); } Tcl_SetHashValue(hPtr, chan); -#ifdef TCL_THREADS +#if TCL_THREADS rcmPtr = GetThreadReflectedChannelMap(); hPtr = Tcl_CreateHashEntry(&rcmPtr->map, chanPtr->state->channelName, &isNew); @@ -744,12 +722,10 @@ TclChanCreateObjCmd( return TCL_OK; error: - /* - * Signal to ReflectClose to not call 'finalize'. - */ - - rcPtr->methods = 0; - Tcl_Close(interp, chan); + Tcl_DecrRefCount(rcPtr->name); + Tcl_DecrRefCount(rcPtr->methods); + Tcl_DecrRefCount(rcPtr->cmd); + ckfree(rcPtr); return TCL_ERROR; #undef MODE @@ -774,7 +750,8 @@ TclChanCreateObjCmd( *---------------------------------------------------------------------- */ -typedef struct ReflectEvent { +#if TCL_THREADS +typedef struct { Tcl_Event header; ReflectedChannel *rcPtr; int events; @@ -817,6 +794,7 @@ ReflectEventDelete( } return 1; } +#endif int TclChanPostEventObjCmd( @@ -877,11 +855,12 @@ TclChanPostEventObjCmd( } /* - * Note that the search above subsumes several of the older checks, namely: + * Note that the search above subsumes several of the older checks, + * namely: * - * (1) Does the channel handle refer to a reflected channel ? + * (1) Does the channel handle refer to a reflected channel? * (2) Is the post event issued from the interpreter holding the handler - * of the reflected channel ? + * of the reflected channel? * * A successful search answers yes to both. Because the map holds only * handles of reflected channels, and only of such whose handler is @@ -938,11 +917,11 @@ TclChanPostEventObjCmd( * We have the channel and the events to post. */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rcPtr->owner == rcPtr->thread) { #endif Tcl_NotifyChannel(chan, events); -#ifdef TCL_THREADS +#if TCL_THREADS } else { ReflectEvent *ev = ckalloc(sizeof(ReflectEvent)); @@ -965,7 +944,8 @@ TclChanPostEventObjCmd( (void) GetThreadReflectedChannelMap(); - /* XXX Race condition !! + /* + * XXX Race condition !! * XXX The destination thread may not exist anymore already. * XXX (Delayed postevent executed after channel got removed). * XXX Can we detect this ? (check the validity of the owner threadid ?) @@ -1138,6 +1118,7 @@ ReflectClose( ReflectedChannelMap *rcmPtr;/* Map of reflected channels with handlers in * this interp */ Tcl_HashEntry *hPtr; /* Entry in the above map */ + const Tcl_ChannelType *tctPtr; if (TclInThreadExit()) { /* @@ -1156,7 +1137,7 @@ ReflectClose( * if lost? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -1175,18 +1156,11 @@ ReflectClose( } #endif - Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); - return EOK; - } - - /* - * -- No -- ASSERT rcPtr->methods & FLAG(METH_FINAL) - * - * A cleaned method mask here implies that the channel creation was - * aborted, and "finalize" must not be called. - */ - - if (rcPtr->methods == 0) { + tctPtr = ((Channel *)rcPtr->chan)->typePtr; + if (tctPtr && tctPtr != &tclRChannelType) { + ckfree(tctPtr); + ((Channel *)rcPtr->chan)->typePtr = NULL; + } Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); return EOK; } @@ -1195,7 +1169,7 @@ ReflectClose( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -1208,14 +1182,12 @@ ReflectClose( Tcl_DeleteEvents(ReflectEventDelete, rcPtr); - Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); - if (result != TCL_OK) { PassReceivedErrorInterp(interp, &p); } } else { #endif - result = InvokeTclMethod(rcPtr, "finalize", NULL, NULL, &resObj); + result = InvokeTclMethod(rcPtr, METH_FINAL, NULL, NULL, &resObj); if ((result != TCL_OK) && (interp != NULL)) { Tcl_SetChannelErrorInterp(interp, resObj); } @@ -1244,19 +1216,21 @@ ReflectClose( Tcl_DeleteHashEntry(hPtr); } } -#ifdef TCL_THREADS +#if TCL_THREADS rcmPtr = GetThreadReflectedChannelMap(); hPtr = Tcl_FindHashEntry(&rcmPtr->map, Tcl_GetChannelName(rcPtr->chan)); if (hPtr) { Tcl_DeleteHashEntry(hPtr); } -#endif - - Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); -#ifdef TCL_THREADS } #endif + tctPtr = ((Channel *)rcPtr->chan)->typePtr; + if (tctPtr && tctPtr != &tclRChannelType) { + ckfree(tctPtr); + ((Channel *)rcPtr->chan)->typePtr = NULL; + } + Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); return (result == TCL_OK) ? EOK : EINVAL; } @@ -1290,22 +1264,10 @@ ReflectInput( Tcl_Obj *resObj; /* Result data for 'read' */ /* - * The following check can be done before thread redirection, because we - * are reading from an item which is readonly, i.e. will never change - * during the lifetime of the channel. - */ - - if (!(rcPtr->methods & FLAG(METH_READ))) { - SetChannelErrorStr(rcPtr->chan, msg_read_unsup); - *errorCodePtr = EINVAL; - return -1; - } - - /* * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -1316,7 +1278,10 @@ ReflectInput( if (p.base.code != TCL_OK) { if (p.base.code < 0) { - /* No error message, this is an errno signal. */ + /* + * No error message, this is an errno signal. + */ + *errorCodePtr = -p.base.code; } else { PassReceivedError(rcPtr->chan, &p); @@ -1339,7 +1304,7 @@ ReflectInput( toReadObj = Tcl_NewIntObj(toRead); Tcl_IncrRefCount(toReadObj); - if (InvokeTclMethod(rcPtr, "read", toReadObj, NULL, &resObj)!=TCL_OK) { + if (InvokeTclMethod(rcPtr, METH_READ, toReadObj, NULL, &resObj)!=TCL_OK) { int code = ErrnoReturn(rcPtr, resObj); if (code < 0) { @@ -1405,22 +1370,10 @@ ReflectOutput( int written; /* - * The following check can be done before thread redirection, because we - * are reading from an item which is readonly, i.e. will never change - * during the lifetime of the channel. - */ - - if (!(rcPtr->methods & FLAG(METH_WRITE))) { - SetChannelErrorStr(rcPtr->chan, msg_write_unsup); - *errorCodePtr = EINVAL; - return -1; - } - - /* * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -1431,7 +1384,10 @@ ReflectOutput( if (p.base.code != TCL_OK) { if (p.base.code < 0) { - /* No error message, this is an errno signal. */ + /* + * No error message, this is an errno signal. + */ + *errorCodePtr = -p.base.code; } else { PassReceivedError(rcPtr->chan, &p); @@ -1450,11 +1406,12 @@ ReflectOutput( /* ASSERT: rcPtr->mode & TCL_WRITABLE */ Tcl_Preserve(rcPtr); + Tcl_Preserve(rcPtr->interp); bufObj = Tcl_NewByteArrayObj((unsigned char *) buf, toWrite); Tcl_IncrRefCount(bufObj); - if (InvokeTclMethod(rcPtr, "write", bufObj, NULL, &resObj) != TCL_OK) { + if (InvokeTclMethod(rcPtr, METH_WRITE, bufObj, NULL, &resObj) != TCL_OK) { int code = ErrnoReturn(rcPtr, resObj); if (code < 0) { @@ -1466,6 +1423,14 @@ ReflectOutput( goto invalid; } + if (Tcl_InterpDeleted(rcPtr->interp)) { + /* + * The interp was destroyed during InvokeTclMethod(). + */ + + SetChannelErrorStr(rcPtr->chan, msg_send_dstlost); + goto invalid; + } if (Tcl_GetIntFromObj(rcPtr->interp, resObj, &written) != TCL_OK) { Tcl_SetChannelError(rcPtr->chan, MarshallError(rcPtr->interp)); goto invalid; @@ -1473,8 +1438,8 @@ ReflectOutput( if ((written == 0) && (toWrite > 0)) { /* - * The handler claims to have written nothing of what it was - * given. That is bad. + * The handler claims to have written nothing of what it was given. + * That is bad. */ SetChannelErrorStr(rcPtr->chan, msg_write_nothing); @@ -1495,6 +1460,7 @@ ReflectOutput( stop: Tcl_DecrRefCount(bufObj); Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ + Tcl_Release(rcPtr->interp); Tcl_Release(rcPtr); return written; invalid: @@ -1536,7 +1502,7 @@ ReflectSeekWide( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -1568,7 +1534,7 @@ ReflectSeekWide( Tcl_IncrRefCount(offObj); Tcl_IncrRefCount(baseObj); - if (InvokeTclMethod(rcPtr, "seek", offObj, baseObj, &resObj) != TCL_OK) { + if (InvokeTclMethod(rcPtr, METH_SEEK, offObj, baseObj, &resObj)!=TCL_OK) { Tcl_SetChannelError(rcPtr->chan, resObj); goto invalid; } @@ -1639,8 +1605,6 @@ ReflectWatch( ReflectedChannel *rcPtr = clientData; Tcl_Obj *maskObj; - /* ASSERT rcPtr->methods & FLAG(METH_WATCH) */ - /* * We restrict the interest to what the channel can support. IOW there * will never be write events for a channel which is not writable. @@ -1657,13 +1621,11 @@ ReflectWatch( return; } - rcPtr->interest = mask; - /* * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -1681,9 +1643,10 @@ ReflectWatch( Tcl_Preserve(rcPtr); + rcPtr->interest = mask; maskObj = DecodeEventMask(mask); /* assert maskObj.refCount == 1 */ - (void) InvokeTclMethod(rcPtr, "watch", maskObj, NULL, NULL); + (void) InvokeTclMethod(rcPtr, METH_WATCH, maskObj, NULL, NULL); Tcl_DecrRefCount(maskObj); Tcl_Release(rcPtr); @@ -1720,7 +1683,7 @@ ReflectBlock( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -1742,7 +1705,7 @@ ReflectBlock( Tcl_Preserve(rcPtr); - if (InvokeTclMethod(rcPtr, "blocking", blockObj, NULL, &resObj)!=TCL_OK) { + if (InvokeTclMethod(rcPtr,METH_BLOCKING,blockObj,NULL,&resObj)!=TCL_OK) { Tcl_SetChannelError(rcPtr->chan, resObj); errorNum = EINVAL; } else { @@ -1756,7 +1719,7 @@ ReflectBlock( return errorNum; } -#ifdef TCL_THREADS +#if TCL_THREADS /* *---------------------------------------------------------------------- * @@ -1826,7 +1789,7 @@ ReflectSetOption( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -1854,7 +1817,7 @@ ReflectSetOption( Tcl_IncrRefCount(optionObj); Tcl_IncrRefCount(valueObj); - result = InvokeTclMethod(rcPtr, "configure",optionObj,valueObj, &resObj); + result = InvokeTclMethod(rcPtr, METH_CONFIGURE,optionObj,valueObj, &resObj); if (result != TCL_OK) { UnmarshallErrorResult(interp, resObj); } @@ -1899,13 +1862,13 @@ ReflectGetOption( Tcl_Obj *resObj; /* Result data for 'configure' */ int listc, result = TCL_OK; Tcl_Obj **listv; - const char *method; + MethodName method; /* * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { int opcode; ForwardParam p; @@ -1938,14 +1901,14 @@ ReflectGetOption( * Retrieve all options. */ - method = "cgetall"; + method = METH_CGETALL; optionObj = NULL; } else { /* * Retrieve the value of one option. */ - method = "cget"; + method = METH_CGET; optionObj = Tcl_NewStringObj(optionName, -1); Tcl_IncrRefCount(optionObj); } @@ -1995,7 +1958,7 @@ ReflectGetOption( goto error; } else { int len; - const char *str = Tcl_GetStringFromObj(resObj, &len); + const char *str = TclGetStringFromObj(resObj, &len); if (len) { TclDStringAppendLiteral(dsPtr, " "); @@ -2159,72 +2122,32 @@ NewReflectedChannel( Tcl_Obj *handleObj) { ReflectedChannel *rcPtr; - int i, listc; - Tcl_Obj **listv; + MethodName mn = METH_BLOCKING; rcPtr = ckalloc(sizeof(ReflectedChannel)); /* rcPtr->chan: Assigned by caller. Dummy data here. */ - /* rcPtr->methods: Assigned by caller. Dummy data here. */ rcPtr->chan = NULL; - rcPtr->methods = 0; rcPtr->interp = interp; rcPtr->dead = 0; -#ifdef TCL_THREADS +#if TCL_THREADS rcPtr->thread = Tcl_GetCurrentThread(); #endif rcPtr->mode = mode; rcPtr->interest = 0; /* Initially no interest registered */ - /* - * Method placeholder. - */ - /* ASSERT: cmdpfxObj is a Tcl List */ - - Tcl_ListObjGetElements(interp, cmdpfxObj, &listc, &listv); - - /* - * See [==] as well. - * Storage for the command prefix and the additional words required for - * the invocation of methods in the command handler. - * - * listv [0] [listc-1] | [listc] [listc+1] | - * argv [0] ... [.] | [argc-2] [argc-1] | [argc] [argc+2] - * cmd ... pfx | method chan | detail1 detail2 - */ - - rcPtr->argc = listc + 2; - rcPtr->argv = ckalloc(sizeof(Tcl_Obj *) * (listc+4)); - - /* - * Duplicate object references. - */ - - for (i=0; i<listc ; i++) { - Tcl_Obj *word = rcPtr->argv[i] = listv[i]; - - Tcl_IncrRefCount(word); - } - - i++; /* Skip placeholder for method */ - - /* - * [Bug 1667990]: See [x] in FreeReflectedChannel for release - */ - - rcPtr->argv[i] = handleObj; - Tcl_IncrRefCount(handleObj); - - /* - * The next two objects are kept empty, varying arguments. - */ - - /* - * Initialization complete. - */ - + rcPtr->cmd = TclListObjCopy(NULL, cmdpfxObj); + Tcl_IncrRefCount(rcPtr->cmd); + rcPtr->methods = Tcl_NewListObj(METH_WRITE + 1, NULL); + while (mn <= METH_WRITE) { + Tcl_ListObjAppendElement(NULL, rcPtr->methods, + Tcl_NewStringObj(methodNames[mn++], -1)); + } + Tcl_IncrRefCount(rcPtr->methods); + rcPtr->name = handleObj; + Tcl_IncrRefCount(rcPtr->name); return rcPtr; } @@ -2271,45 +2194,21 @@ NextHandle(void) } static void -FreeReflectedChannelArgs( - ReflectedChannel *rcPtr) -{ - int i, n = rcPtr->argc - 2; - - if (n < 0) { - return; - } - for (i=0; i<n; i++) { - Tcl_DecrRefCount(rcPtr->argv[i]); - } - - /* - * [Bug 1667990]: See [x] in NewReflectedChannel for lock. n+1 = argc-1. - */ - - Tcl_DecrRefCount(rcPtr->argv[n+1]); - - rcPtr->argc = 1; -} - -static void FreeReflectedChannel( ReflectedChannel *rcPtr) { Channel *chanPtr = (Channel *) rcPtr->chan; - if (chanPtr->typePtr != &tclRChannelType) { - /* - * Delete a cloned ChannelType structure. - */ - - ckfree(chanPtr->typePtr); - chanPtr->typePtr = NULL; + TclChannelRelease((Tcl_Channel)chanPtr); + if (rcPtr->name) { + Tcl_DecrRefCount(rcPtr->name); + } + if (rcPtr->methods) { + Tcl_DecrRefCount(rcPtr->methods); + } + if (rcPtr->cmd) { + Tcl_DecrRefCount(rcPtr->cmd); } - - FreeReflectedChannelArgs(rcPtr); - - ckfree(rcPtr->argv); ckfree(rcPtr); } @@ -2340,16 +2239,16 @@ FreeReflectedChannel( static int InvokeTclMethod( ReflectedChannel *rcPtr, - const char *method, + MethodName method, Tcl_Obj *argOneObj, /* NULL'able */ Tcl_Obj *argTwoObj, /* NULL'able */ Tcl_Obj **resultObjPtr) /* NULL'able */ { - int cmdc; /* #words in constructed command */ Tcl_Obj *methObj = NULL; /* Method name in object form */ Tcl_InterpState sr; /* State of handler interp */ int result; /* Result code of method invokation */ Tcl_Obj *resObj = NULL; /* Result of method invokation. */ + Tcl_Obj *cmd; if (rcPtr->dead) { /* @@ -2372,19 +2271,15 @@ InvokeTclMethod( } /* - * NOTE (5): Decide impl. issue: Cache objects with method names? Needs - * TSD data as reflections can be created in many different threads. - * NO: Caching of command resolutions means storage per channel. - */ - - /* - * Insert method into the pre-allocated area, after the command prefix, + * Insert method into the callback command, after the command prefix, * before the channel id. */ - methObj = Tcl_NewStringObj(method, -1); - Tcl_IncrRefCount(methObj); - rcPtr->argv[rcPtr->argc - 2] = methObj; + cmd = TclListObjCopy(NULL, rcPtr->cmd); + + Tcl_ListObjIndex(NULL, rcPtr->methods, method, &methObj); + Tcl_ListObjAppendElement(NULL, cmd, methObj); + Tcl_ListObjAppendElement(NULL, cmd, rcPtr->name); /* * Append the additional argument containing method specific details @@ -2394,13 +2289,10 @@ InvokeTclMethod( * The objects will survive the Tcl_EvalObjv without change. */ - cmdc = rcPtr->argc; if (argOneObj) { - rcPtr->argv[cmdc] = argOneObj; - cmdc++; + Tcl_ListObjAppendElement(NULL, cmd, argOneObj); if (argTwoObj) { - rcPtr->argv[cmdc] = argTwoObj; - cmdc++; + Tcl_ListObjAppendElement(NULL, cmd, argTwoObj); } } @@ -2409,9 +2301,10 @@ InvokeTclMethod( * existing state intact. */ + Tcl_IncrRefCount(cmd); sr = Tcl_SaveInterpState(rcPtr->interp, 0 /* Dummy */); Tcl_Preserve(rcPtr->interp); - result = Tcl_EvalObjv(rcPtr->interp, cmdc, rcPtr->argv, TCL_EVAL_GLOBAL); + result = Tcl_EvalObjEx(rcPtr->interp, cmd, TCL_EVAL_GLOBAL); /* * We do not try to extract the result information if the caller has no @@ -2437,9 +2330,8 @@ InvokeTclMethod( */ if (result != TCL_ERROR) { - Tcl_Obj *cmd = Tcl_NewListObj(cmdc, rcPtr->argv); int cmdLen; - const char *cmdString = Tcl_GetStringFromObj(cmd, &cmdLen); + const char *cmdString = TclGetStringFromObj(cmd, &cmdLen); Tcl_IncrRefCount(cmd); Tcl_ResetResult(rcPtr->interp); @@ -2451,25 +2343,17 @@ InvokeTclMethod( result = TCL_ERROR; } Tcl_AppendObjToErrorInfo(rcPtr->interp, Tcl_ObjPrintf( - "\n (chan handler subcommand \"%s\")", method)); + "\n (chan handler subcommand \"%s\")", + methodNames[method])); resObj = MarshallError(rcPtr->interp); } Tcl_IncrRefCount(resObj); } + Tcl_DecrRefCount(cmd); Tcl_RestoreInterpState(rcPtr->interp, sr); Tcl_Release(rcPtr->interp); /* - * Cleanup of the dynamic parts of the command. - * - * The detail objects survived the Tcl_EvalObjv without change because of - * the contract. Therefore there is no need to decrement the refcounts. Only - * the internal method object has to be disposed of. - */ - - Tcl_DecrRefCount(methObj); - - /* * The resObj has a ref count of 1 at this location. This means that the * caller of InvokeTclMethod has to dispose of it (but only if it was * returned to it). @@ -2501,8 +2385,8 @@ InvokeTclMethod( * None. * * Users: - * ReflectInput/Output(), to enable the signaling of EAGAIN - * on 0-sized short reads/writes. + * ReflectInput/Output(), to enable the signaling of EAGAIN on 0-sized + * short reads/writes. * *---------------------------------------------------------------------- */ @@ -2526,7 +2410,7 @@ ErrnoReturn( if (((Tcl_GetIntFromObj(rcPtr->interp, resObj, &code) != TCL_OK) || (code >= 0))) { - if (strcmp("EAGAIN", Tcl_GetString(resObj)) == 0) { + if (strcmp("EAGAIN", TclGetString(resObj)) == 0) { code = -EAGAIN; } else { code = 0; @@ -2590,6 +2474,28 @@ GetReflectedChannelMap( */ static void +MarkDead( + ReflectedChannel *rcPtr) +{ + if (rcPtr->dead) { + return; + } + if (rcPtr->name) { + Tcl_DecrRefCount(rcPtr->name); + rcPtr->name = NULL; + } + if (rcPtr->methods) { + Tcl_DecrRefCount(rcPtr->methods); + rcPtr->methods = NULL; + } + if (rcPtr->cmd) { + Tcl_DecrRefCount(rcPtr->cmd); + rcPtr->cmd = NULL; + } + rcPtr->dead = 1; +} + +static void DeleteReflectedChannelMap( ClientData clientData, /* The per-interpreter data structure. */ Tcl_Interp *interp) /* The interpreter being deleted. */ @@ -2600,7 +2506,7 @@ DeleteReflectedChannelMap( Tcl_HashEntry *hPtr; /* Search variable. */ ReflectedChannel *rcPtr; Tcl_Channel chan; -#ifdef TCL_THREADS +#if TCL_THREADS ForwardingResult *resultPtr; ForwardingEvent *evPtr; ForwardParam *paramPtr; @@ -2624,13 +2530,13 @@ DeleteReflectedChannelMap( chan = Tcl_GetHashValue(hPtr); rcPtr = Tcl_GetChannelInstanceData(chan); - rcPtr->dead = 1; + MarkDead(rcPtr); Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(&rcmPtr->map); ckfree(&rcmPtr->map); -#ifdef TCL_THREADS +#if TCL_THREADS /* * The origin interpreter for one or more reflected channels is gone. */ @@ -2657,15 +2563,26 @@ DeleteReflectedChannelMap( /* * The receiver for the event exited, before processing the event. We * detach the result now, wake the originator up and signal failure. + * + * Attention: Results may have been detached already, by either the + * receiver, or this thread, as part of other parts in the thread + * teardown. Such results are ignored. See ticket [b47b176adf] for the + * identical race condition in Tcl 8.6 IORTrans. */ evPtr = resultPtr->evPtr; - /* Basic crash safety until this routine can get revised [3411310] */ + /* + * Basic crash safety until this routine can get revised [3411310] + */ + if (evPtr == NULL) { continue; } paramPtr = evPtr->param; + if (!evPtr) { + continue; + } evPtr->resultPtr = NULL; resultPtr->evPtr = NULL; @@ -2699,14 +2616,13 @@ DeleteReflectedChannelMap( continue; } - rcPtr->dead = 1; - FreeReflectedChannelArgs(rcPtr); + MarkDead(rcPtr); Tcl_DeleteHashEntry(hPtr); } #endif } -#ifdef TCL_THREADS +#if TCL_THREADS /* *---------------------------------------------------------------------- * @@ -2774,8 +2690,8 @@ DeleteThreadReflectedChannelMap( /* * Go through the list of pending results and cancel all whose events were - * destined for this thread. While this is in progress we block any - * other access to the list of pending results. + * destined for this thread. While this is in progress we block any other + * access to the list of pending results. */ Tcl_MutexLock(&rcForwardMutex); @@ -2797,15 +2713,26 @@ DeleteThreadReflectedChannelMap( /* * The receiver for the event exited, before processing the event. We * detach the result now, wake the originator up and signal failure. + * + * Attention: Results may have been detached already, by either the + * receiver, or this thread, as part of other parts in the thread + * teardown. Such results are ignored. See ticket [b47b176adf] for the + * identical race condition in Tcl 8.6 IORTrans. */ evPtr = resultPtr->evPtr; - /* Basic crash safety until this routine can get revised [3411310] */ + /* + * Basic crash safety until this routine can get revised [3411310] + */ + if (evPtr == NULL ) { continue; } paramPtr = evPtr->param; + if (!evPtr) { + continue; + } evPtr->resultPtr = NULL; resultPtr->evPtr = NULL; @@ -2839,8 +2766,7 @@ DeleteThreadReflectedChannelMap( Tcl_Channel chan = Tcl_GetHashValue(hPtr); ReflectedChannel *rcPtr = Tcl_GetChannelInstanceData(chan); - rcPtr->dead = 1; - FreeReflectedChannelArgs(rcPtr); + MarkDead(rcPtr); Tcl_DeleteHashEntry(hPtr); } ckfree(rcmPtr); @@ -2853,8 +2779,8 @@ ForwardOpToHandlerThread( const void *param) /* Arguments */ { /* - * Core of the communication from OWNER to HANDLER thread. - * The receiver is ForwardProc() below. + * Core of the communication from OWNER to HANDLER thread. The receiver is + * ForwardProc() below. */ Tcl_ThreadId dst = rcPtr->thread; @@ -2904,7 +2830,10 @@ ForwardOpToHandlerThread( */ TclSpliceIn(resultPtr, forwardList); - /* Do not unlock here. That is done by the ConditionWait */ + + /* + * Do not unlock here. That is done by the ConditionWait. + */ /* * Ensure cleanup of the event if the origin thread exits while this event @@ -2980,7 +2909,7 @@ ForwardProc( * Notes regarding access to the referenced data. * * In principle the data belongs to the originating thread (see - * evPtr->src), however this thread is currently blocked at (*), i.e. + * evPtr->src), however this thread is currently blocked at (*), i.e., * quiescent. Because of this we can treat the data as belonging to us, * without fear of race conditions. I.e. we can read and write as we like. * @@ -3018,17 +2947,17 @@ ForwardProc( * call upon for the driver. */ - case ForwardedClose: + case ForwardedClose: { /* * No parameters/results. */ - if (InvokeTclMethod(rcPtr, "finalize", NULL, NULL, &resObj)!=TCL_OK) { + if (InvokeTclMethod(rcPtr, METH_FINAL, NULL, NULL, &resObj)!=TCL_OK) { ForwardSetObjError(paramPtr, resObj); } /* - * Freeing is done here, in the origin thread, because the argv[] + * Freeing is done here, in the origin thread, callback command * objects belong to this thread. Deallocating them in a different * thread is not allowed * @@ -3046,16 +2975,16 @@ ForwardProc( hPtr = Tcl_FindHashEntry(&rcmPtr->map, Tcl_GetChannelName(rcPtr->chan)); Tcl_DeleteHashEntry(hPtr); - - FreeReflectedChannelArgs(rcPtr); + MarkDead(rcPtr); break; + } case ForwardedInput: { Tcl_Obj *toReadObj = Tcl_NewIntObj(paramPtr->input.toRead); Tcl_IncrRefCount(toReadObj); Tcl_Preserve(rcPtr); - if (InvokeTclMethod(rcPtr, "read", toReadObj, NULL, &resObj)!=TCL_OK){ + if (InvokeTclMethod(rcPtr, METH_READ, toReadObj, NULL, &resObj)!=TCL_OK){ int code = ErrnoReturn(rcPtr, resObj); if (code < 0) { @@ -3095,7 +3024,7 @@ ForwardProc( Tcl_IncrRefCount(bufObj); Tcl_Preserve(rcPtr); - if (InvokeTclMethod(rcPtr, "write", bufObj, NULL, &resObj) != TCL_OK) { + if (InvokeTclMethod(rcPtr, METH_WRITE, bufObj, NULL, &resObj) != TCL_OK) { int code = ErrnoReturn(rcPtr, resObj); if (code < 0) { @@ -3138,7 +3067,7 @@ ForwardProc( Tcl_IncrRefCount(baseObj); Tcl_Preserve(rcPtr); - if (InvokeTclMethod(rcPtr, "seek", offObj, baseObj, &resObj)!=TCL_OK){ + if (InvokeTclMethod(rcPtr, METH_SEEK, offObj, baseObj, &resObj)!=TCL_OK){ ForwardSetObjError(paramPtr, resObj); paramPtr->seek.offset = -1; } else { @@ -3174,7 +3103,8 @@ ForwardProc( /* assert maskObj.refCount == 1 */ Tcl_Preserve(rcPtr); - (void) InvokeTclMethod(rcPtr, "watch", maskObj, NULL, NULL); + rcPtr->interest = paramPtr->watch.mask; + (void) InvokeTclMethod(rcPtr, METH_WATCH, maskObj, NULL, NULL); Tcl_DecrRefCount(maskObj); Tcl_Release(rcPtr); break; @@ -3185,7 +3115,7 @@ ForwardProc( Tcl_IncrRefCount(blockObj); Tcl_Preserve(rcPtr); - if (InvokeTclMethod(rcPtr, "blocking", blockObj, NULL, + if (InvokeTclMethod(rcPtr, METH_BLOCKING, blockObj, NULL, &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); } @@ -3201,7 +3131,7 @@ ForwardProc( Tcl_IncrRefCount(optionObj); Tcl_IncrRefCount(valueObj); Tcl_Preserve(rcPtr); - if (InvokeTclMethod(rcPtr, "configure", optionObj, valueObj, + if (InvokeTclMethod(rcPtr, METH_CONFIGURE, optionObj, valueObj, &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); } @@ -3220,7 +3150,7 @@ ForwardProc( Tcl_IncrRefCount(optionObj); Tcl_Preserve(rcPtr); - if (InvokeTclMethod(rcPtr, "cget", optionObj, NULL, &resObj)!=TCL_OK){ + if (InvokeTclMethod(rcPtr, METH_CGET, optionObj, NULL, &resObj)!=TCL_OK){ ForwardSetObjError(paramPtr, resObj); } else { TclDStringAppendObj(paramPtr->getOpt.value, resObj); @@ -3236,7 +3166,7 @@ ForwardProc( */ Tcl_Preserve(rcPtr); - if (InvokeTclMethod(rcPtr, "cgetall", NULL, NULL, &resObj) != TCL_OK){ + if (InvokeTclMethod(rcPtr, METH_CGETALL, NULL, NULL, &resObj) != TCL_OK){ ForwardSetObjError(paramPtr, resObj); } else { /* @@ -3265,7 +3195,7 @@ ForwardProc( ForwardSetDynamicError(paramPtr, buf); } else { int len; - const char *str = Tcl_GetStringFromObj(resObj, &len); + const char *str = TclGetStringFromObj(resObj, &len); if (len) { TclDStringAppendLiteral(paramPtr->getOpt.value, " "); @@ -3364,7 +3294,7 @@ ForwardSetObjError( Tcl_Obj *obj) { int len; - const char *msgStr = Tcl_GetStringFromObj(obj, &len); + const char *msgStr = TclGetStringFromObj(obj, &len); len++; ForwardSetDynamicError(paramPtr, ckalloc(len)); diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index 1de635f..1a7b940 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -87,7 +87,7 @@ static const Tcl_ChannelType tclRTransformType = { * layers upon reading from the channel, plus the functions to manage such. */ -typedef struct _ResultBuffer_ { +typedef struct { unsigned char *buf; /* Reference to the buffer area. */ int allocated; /* Allocated size of the buffer area. */ int used; /* Number of bytes in the buffer, @@ -127,7 +127,7 @@ typedef struct { * in the argv, see below. The separate field * gives us direct access, needed when working * with the reflection maps. */ -#ifdef TCL_THREADS +#if TCL_THREADS Tcl_ThreadId thread; /* Thread the 'interp' belongs to. */ #endif @@ -161,6 +161,7 @@ typedef struct { int mode; /* Mask of R/W mode */ int nonblocking; /* Flag: Channel is blocking or not. */ int readIsDrained; /* Flag: Read buffers are flushed. */ + int eofPending; /* Flag: EOF seen down, but not raised up */ int dead; /* Boolean signal that some operations * should no longer be attempted. */ ResultBuffer result; @@ -219,7 +220,7 @@ typedef enum { #define NEGIMPL(a,b) #define HAS(x,f) (x & FLAG(f)) -#ifdef TCL_THREADS +#if TCL_THREADS /* * Thread specific types and structures. * @@ -252,7 +253,7 @@ typedef enum { * sharing problems. */ -typedef struct ForwardParamBase { +typedef struct { int code; /* O: Ok/Fail of the cmd handler */ char *msgStr; /* O: Error message for handler failure */ int mustFree; /* O: True if msgStr is allocated, false if @@ -297,7 +298,7 @@ typedef struct ForwardingResult ForwardingResult; * General event structure, with reference to operation specific data. */ -typedef struct ForwardingEvent { +typedef struct { Tcl_Event event; /* Basic event data, has to be first item */ ForwardingResult *resultPtr; ForwardedOperation op; /* Forwarded driver operation */ @@ -328,7 +329,7 @@ struct ForwardingResult { * results. */ }; -typedef struct ThreadSpecificData { +typedef struct { /* * Table of all reflected transformations owned by this thread. */ @@ -437,7 +438,7 @@ static void DeleteReflectedTransformMap(ClientData clientData, static const char *msg_read_unsup = "{read not supported by Tcl driver}"; static const char *msg_write_unsup = "{write not supported by Tcl driver}"; -#ifdef TCL_THREADS +#if TCL_THREADS static const char *msg_send_originlost = "{Channel thread lost}"; static const char *msg_send_dstlost = "{Owner lost}"; #endif /* TCL_THREADS */ @@ -457,8 +458,7 @@ static void TimerKill(ReflectedTransform *rtPtr); static void TimerSetup(ReflectedTransform *rtPtr); static void TimerRun(ClientData clientData); static int TransformRead(ReflectedTransform *rtPtr, - int *errorCodePtr, unsigned char *buf, - int toRead); + int *errorCodePtr, Tcl_Obj *bufObj); static int TransformWrite(ReflectedTransform *rtPtr, int *errorCodePtr, unsigned char *buf, int toWrite); @@ -554,7 +554,7 @@ TclChanPushObjCmd( */ chanObj = objv[CHAN]; - parentChan = Tcl_GetChannel(interp, Tcl_GetString(chanObj), &mode); + parentChan = Tcl_GetChannel(interp, TclGetString(chanObj), &mode); if (parentChan == NULL) { return TCL_ERROR; } @@ -608,7 +608,7 @@ TclChanPushObjCmd( if (Tcl_ListObjGetElements(NULL, resObj, &listc, &listv) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s initialize\" returned non-list: %s", - Tcl_GetString(cmdObj), Tcl_GetString(resObj))); + TclGetString(cmdObj), TclGetString(resObj))); Tcl_DecrRefCount(resObj); goto error; } @@ -619,7 +619,7 @@ TclChanPushObjCmd( "method", TCL_EXACT, &methIndex) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s initialize\" returned %s", - Tcl_GetString(cmdObj), + TclGetString(cmdObj), Tcl_GetString(Tcl_GetObjResult(interp)))); Tcl_DecrRefCount(resObj); goto error; @@ -633,7 +633,7 @@ TclChanPushObjCmd( if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" does not support all required methods", - Tcl_GetString(cmdObj))); + TclGetString(cmdObj))); goto error; } @@ -655,7 +655,7 @@ TclChanPushObjCmd( if (!mode) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" makes the channel inaccessible", - Tcl_GetString(cmdObj))); + TclGetString(cmdObj))); goto error; } @@ -666,14 +666,14 @@ TclChanPushObjCmd( if (!IMPLIES(HAS(methods, METH_DRAIN), HAS(methods, METH_READ))) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" supports \"drain\" but not \"read\"", - Tcl_GetString(cmdObj))); + TclGetString(cmdObj))); goto error; } if (!IMPLIES(HAS(methods, METH_FLUSH), HAS(methods, METH_WRITE))) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" supports \"flush\" but not \"write\"", - Tcl_GetString(cmdObj))); + TclGetString(cmdObj))); goto error; } @@ -694,14 +694,14 @@ TclChanPushObjCmd( */ rtmPtr = GetReflectedTransformMap(interp); - hPtr = Tcl_CreateHashEntry(&rtmPtr->map, Tcl_GetString(rtId), &isNew); + hPtr = Tcl_CreateHashEntry(&rtmPtr->map, TclGetString(rtId), &isNew); if (!isNew && rtPtr != Tcl_GetHashValue(hPtr)) { Tcl_Panic("TclChanPushObjCmd: duplicate transformation handle"); } Tcl_SetHashValue(hPtr, rtPtr); -#ifdef TCL_THREADS +#if TCL_THREADS rtmPtr = GetThreadReflectedTransformMap(); - hPtr = Tcl_CreateHashEntry(&rtmPtr->map, Tcl_GetString(rtId), &isNew); + hPtr = Tcl_CreateHashEntry(&rtmPtr->map, TclGetString(rtId), &isNew); Tcl_SetHashValue(hPtr, rtPtr); #endif /* TCL_THREADS */ @@ -911,7 +911,7 @@ ReflectClose( * if lost? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -938,12 +938,12 @@ ReflectClose( if (HAS(rtPtr->methods, METH_DRAIN) && !rtPtr->readIsDrained) { if (!TransformDrain(rtPtr, &errorCode)) { -#ifdef TCL_THREADS +#if TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); return errorCode; - } + } #endif /* TCL_THREADS */ errorCodeSet = 1; goto cleanup; @@ -952,12 +952,12 @@ ReflectClose( if (HAS(rtPtr->methods, METH_FLUSH)) { if (!TransformFlush(rtPtr, &errorCode, FLUSH_WRITE)) { -#ifdef TCL_THREADS +#if TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); return errorCode; - } + } #endif /* TCL_THREADS */ errorCodeSet = 1; goto cleanup; @@ -968,7 +968,7 @@ ReflectClose( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -1025,9 +1025,9 @@ ReflectClose( * under a channel by deleting the owning thread. */ -#ifdef TCL_THREADS +#if TCL_THREADS rtmPtr = GetThreadReflectedTransformMap(); - hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle)); + hPtr = Tcl_FindHashEntry(&rtmPtr->map, TclGetString(rtPtr->handle)); if (hPtr) { Tcl_DeleteHashEntry(hPtr); } @@ -1063,6 +1063,7 @@ ReflectInput( { ReflectedTransform *rtPtr = clientData; int gotBytes, copied, readBytes; + Tcl_Obj *bufObj; /* * The following check can be done before thread redirection, because we @@ -1078,7 +1079,14 @@ ReflectInput( Tcl_Preserve(rtPtr); + /* TODO: Consider a more appropriate buffer size. */ + bufObj = Tcl_NewByteArrayObj(NULL, toRead); + Tcl_IncrRefCount(bufObj); gotBytes = 0; + if (rtPtr->eofPending) { + goto stop; + } + rtPtr->readIsDrained = 0; while (toRead > 0) { /* * Loop until the request is satisfied (or no data available from @@ -1094,6 +1102,11 @@ ReflectInput( goto stop; } + if (rtPtr->eofPending) { + goto stop; + } + + /* * The buffer is exhausted, but the caller wants even more. We now * have to go to the underlying channel, get more bytes and then @@ -1129,55 +1142,41 @@ ReflectInput( goto stop; } - readBytes = Tcl_ReadRaw(rtPtr->parent, buf, toRead); + + readBytes = Tcl_ReadRaw(rtPtr->parent, + (char *) Tcl_SetByteArrayLength(bufObj, toRead), toRead); if (readBytes < 0) { - /* - * Report errors to caller. The state of the seek system is - * unchanged! - */ + if (Tcl_InputBlocked(rtPtr->parent) && (gotBytes > 0)) { - if ((Tcl_GetErrno() == EAGAIN) && (gotBytes > 0)) { /* - * EAGAIN is a special situation. If we had some data before - * we report that instead of the request to re-try. + * Down channel is blocked and offers zero additional bytes. + * The nonzero gotBytes already returned makes the total + * operation a valid short read. Return to caller. */ goto stop; } + /* + * Either the down channel is not blocked (a real error) + * or it is and there are gotBytes==0 byte copied so far. + * In either case, pass up the error, so we either report + * any real error, or do not mistakenly signal EOF by + * returning 0 to the caller. + */ + *errorCodePtr = Tcl_GetErrno(); goto error; } if (readBytes == 0) { + /* - * Check wether we hit on EOF in 'parent' or not. If not - * differentiate between blocking and non-blocking modes. In - * non-blocking mode we ran temporarily out of data. Signal this - * to the caller via EWOULDBLOCK and error return (-1). In the - * other cases we simply return what we got and let the caller - * wait for more. On the other hand, if we got an EOF we have to - * convert and flush all waiting partial data. + * Zero returned from Tcl_ReadRaw() always indicates EOF + * on the down channel. */ - if (!Tcl_Eof(rtPtr->parent)) { - /* - * The state of the seek system is unchanged! - */ - - if ((gotBytes == 0) && rtPtr->nonblocking) { - *errorCodePtr = EWOULDBLOCK; - goto error; - } - goto stop; - } else { - /* - * Eof in parent. - */ - - if (rtPtr->readIsDrained) { - goto stop; - } + rtPtr->eofPending = 1; /* * Now this is a bit different. The partial data waiting is @@ -1198,13 +1197,7 @@ ReflectInput( goto stop; } - /* - * Reset eof, force caller to drain result buffer. - */ - - ((Channel *) rtPtr->parent)->state->flags &= ~CHANNEL_EOF; continue; /* at: while (toRead > 0) */ - } } /* readBytes == 0 */ /* @@ -1213,12 +1206,23 @@ ReflectInput( * iteration will put it into the result. */ - if (!TransformRead(rtPtr, errorCodePtr, UCHARP(buf), readBytes)) { + Tcl_SetByteArrayLength(bufObj, readBytes); + if (!TransformRead(rtPtr, errorCodePtr, bufObj)) { goto error; } + if (Tcl_IsShared(bufObj)) { + Tcl_DecrRefCount(bufObj); + bufObj = Tcl_NewObj(); + Tcl_IncrRefCount(bufObj); + } + Tcl_SetByteArrayLength(bufObj, 0); } /* while toRead > 0 */ stop: + if (gotBytes == 0) { + rtPtr->eofPending = 0; + } + Tcl_DecrRefCount(bufObj); Tcl_Release(rtPtr); return gotBytes; @@ -1763,7 +1767,7 @@ NewReflectedTransform( rtPtr->chan = NULL; rtPtr->methods = 0; -#ifdef TCL_THREADS +#if TCL_THREADS rtPtr->thread = Tcl_GetCurrentThread(); #endif rtPtr->parent = parentChan; @@ -1773,6 +1777,7 @@ NewReflectedTransform( rtPtr->timer = NULL; rtPtr->mode = 0; rtPtr->readIsDrained = 0; + rtPtr->eofPending = 0; rtPtr->nonblocking = (((Channel *) parentChan)->state->flags & CHANNEL_NONBLOCKING); rtPtr->dead = 0; @@ -2010,6 +2015,7 @@ InvokeTclMethod( sr = Tcl_SaveInterpState(rtPtr->interp, 0 /* Dummy */); Tcl_Preserve(rtPtr); + Tcl_Preserve(rtPtr->interp); result = Tcl_EvalObjv(rtPtr->interp, cmdc, rtPtr->argv, TCL_EVAL_GLOBAL); /* @@ -2037,7 +2043,7 @@ InvokeTclMethod( if (result != TCL_ERROR) { Tcl_Obj *cmd = Tcl_NewListObj(cmdc, rtPtr->argv); int cmdLen; - const char *cmdString = Tcl_GetStringFromObj(cmd, &cmdLen); + const char *cmdString = TclGetStringFromObj(cmd, &cmdLen); Tcl_IncrRefCount(cmd); Tcl_ResetResult(rtPtr->interp); @@ -2054,6 +2060,7 @@ InvokeTclMethod( Tcl_IncrRefCount(resObj); } Tcl_RestoreInterpState(rtPtr->interp, sr); + Tcl_Release(rtPtr->interp); Tcl_Release(rtPtr); /* @@ -2145,7 +2152,7 @@ DeleteReflectedTransformMap( Tcl_HashSearch hSearch; /* Search variable. */ Tcl_HashEntry *hPtr; /* Search variable. */ ReflectedTransform *rtPtr; -#ifdef TCL_THREADS +#if TCL_THREADS ForwardingResult *resultPtr; ForwardingEvent *evPtr; ForwardParam *paramPtr; @@ -2175,7 +2182,7 @@ DeleteReflectedTransformMap( Tcl_DeleteHashTable(&rtmPtr->map); ckfree(&rtmPtr->map); -#ifdef TCL_THREADS +#if TCL_THREADS /* * The origin interpreter for one or more reflected channels is gone. */ @@ -2230,6 +2237,9 @@ DeleteReflectedTransformMap( */ evPtr = resultPtr->evPtr; + if (evPtr == NULL) { + continue; + } paramPtr = evPtr->param; evPtr->resultPtr = NULL; @@ -2244,7 +2254,7 @@ DeleteReflectedTransformMap( #endif /* TCL_THREADS */ } -#ifdef TCL_THREADS +#if TCL_THREADS /* *---------------------------------------------------------------------- * @@ -2355,6 +2365,9 @@ DeleteThreadReflectedTransformMap( */ evPtr = resultPtr->evPtr; + if (evPtr == NULL) { + continue; + } paramPtr = evPtr->param; evPtr->resultPtr = NULL; @@ -2555,7 +2568,7 @@ ForwardProc( */ rtmPtr = GetReflectedTransformMap(interp); - hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle)); + hPtr = Tcl_FindHashEntry(&rtmPtr->map, TclGetString(rtPtr->handle)); Tcl_DeleteHashEntry(hPtr); /* @@ -2565,7 +2578,7 @@ ForwardProc( */ rtmPtr = GetThreadReflectedTransformMap(); - hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle)); + hPtr = Tcl_FindHashEntry(&rtmPtr->map, TclGetString(rtPtr->handle)); Tcl_DeleteHashEntry(hPtr); FreeReflectedTransformArgs(rtPtr); @@ -2794,7 +2807,7 @@ ForwardSetObjError( Tcl_Obj *obj) { int len; - const char *msgStr = Tcl_GetStringFromObj(obj, &len); + const char *msgStr = TclGetStringFromObj(obj, &len); len++; ForwardSetDynamicError(paramPtr, ckalloc(len)); @@ -2942,7 +2955,7 @@ ResultClear( return; } - ckfree((char *) rPtr->buf); + ckfree(rPtr->buf); rPtr->buf = NULL; rPtr->allocated = 0; } @@ -3065,10 +3078,8 @@ static int TransformRead( ReflectedTransform *rtPtr, int *errorCodePtr, - unsigned char *buf, - int toRead) + Tcl_Obj *bufObj) { - Tcl_Obj *bufObj; Tcl_Obj *resObj; int bytec; /* Number of returned bytes */ unsigned char *bytev; /* Array of returned bytes */ @@ -3077,12 +3088,12 @@ TransformRead( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; - p.transform.buf = (char *) buf; - p.transform.size = toRead; + p.transform.buf = (char *) Tcl_GetByteArrayFromObj(bufObj, + &(p.transform.size)); ForwardOpToOwnerThread(rtPtr, ForwardedInput, &p); @@ -3102,12 +3113,8 @@ TransformRead( /* ASSERT: rtPtr->method & FLAG(METH_READ) */ /* ASSERT: rtPtr->mode & TCL_READABLE */ - bufObj = Tcl_NewByteArrayObj((unsigned char *) buf, toRead); - Tcl_IncrRefCount(bufObj); - if (InvokeTclMethod(rtPtr, "read", bufObj, NULL, &resObj) != TCL_OK) { Tcl_SetChannelError(rtPtr->chan, resObj); - Tcl_DecrRefCount(bufObj); Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ *errorCodePtr = EINVAL; return 0; @@ -3116,7 +3123,6 @@ TransformRead( bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); ResultAdd(&rtPtr->result, bytev, bytec); - Tcl_DecrRefCount(bufObj); Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ return 1; } @@ -3138,7 +3144,7 @@ TransformWrite( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -3184,7 +3190,7 @@ TransformWrite( } if (res < 0) { - *errorCodePtr = EINVAL; + *errorCodePtr = Tcl_GetErrno(); return 0; } @@ -3204,7 +3210,7 @@ TransformDrain( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -3254,7 +3260,7 @@ TransformFlush( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -3294,7 +3300,7 @@ TransformFlush( } if (res < 0) { - *errorCodePtr = EINVAL; + *errorCodePtr = Tcl_GetErrno(); return 0; } @@ -3309,7 +3315,7 @@ TransformClear( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -3324,6 +3330,7 @@ TransformClear( (void) InvokeTclMethod(rtPtr, "clear", NULL, NULL, NULL); rtPtr->readIsDrained = 0; + rtPtr->eofPending = 0; ResultClear(&rtPtr->result); } @@ -3340,7 +3347,7 @@ TransformLimit( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index 7d6c462..12e2900 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.c @@ -11,10 +11,32 @@ #include "tclInt.h" -#if defined(_WIN32) && defined(UNICODE) -/* On Windows, we always need the ASCII version. */ -# undef gai_strerror -# define gai_strerror gai_strerrorA +#if defined(_WIN32) +/* + * On Windows, we need to do proper Unicode->UTF-8 conversion. + */ + +typedef struct { + int initialized; + Tcl_DString errorMsg; /* UTF-8 encoded error-message */ +} ThreadSpecificData; +static Tcl_ThreadDataKey dataKey; + +#undef gai_strerror +static const char * +gai_strerror( + int code) +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + if (tsdPtr->initialized) { + Tcl_DStringFree(&tsdPtr->errorMsg); + } else { + tsdPtr->initialized = 1; + } + Tcl_WinTCharToUtf(gai_strerrorW(code), -1, &tsdPtr->errorMsg); + return Tcl_DStringValue(&tsdPtr->errorMsg); +} #endif /* @@ -39,8 +61,8 @@ int TclSockGetPort( Tcl_Interp *interp, - const char *string, /* Integer or service name */ - const char *proto, /* "tcp" or "udp", typically */ + const char *string, /* Integer or service name */ + const char *proto, /* "tcp" or "udp", typically */ int *portPtr) /* Return port number */ { struct servent *sp; /* Protocol info for named services */ @@ -109,7 +131,7 @@ TclSockMinimumBuffers( } len = sizeof(int); getsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_RCVBUF, - (char *) ¤t, &len); + (char *) ¤t, &len); if (current < size) { len = sizeof(int); setsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_RCVBUF, @@ -137,15 +159,15 @@ TclSockMinimumBuffers( int TclCreateSocketAddress( - Tcl_Interp *interp, /* Interpreter for querying - * the desired socket family */ - void **addrlist, /* Socket address list */ - const char *host, /* Host. NULL implies INADDR_ANY */ - int port, /* Port number */ - int willBind, /* Is this an address to bind() to or - * to connect() to? */ - const char **errorMsgPtr) /* Place to store the error message - * detail, if available. */ + Tcl_Interp *interp, /* Interpreter for querying the desired socket + * family */ + struct addrinfo **addrlist, /* Socket address list */ + const char *host, /* Host. NULL implies INADDR_ANY */ + int port, /* Port number */ + int willBind, /* Is this an address to bind() to or to + * connect() to? */ + const char **errorMsgPtr) /* Place to store the error message detail, if + * available. */ { struct addrinfo hints; struct addrinfo *p; @@ -154,7 +176,7 @@ TclCreateSocketAddress( char *native = NULL, portbuf[TCL_INTEGER_SPACE], *portstring; const char *family = NULL; Tcl_DString ds; - int result, i; + int result; if (host != NULL) { native = Tcl_UtfToExternalDString(NULL, host, -1, &ds); @@ -164,30 +186,31 @@ TclCreateSocketAddress( * Workaround for OSX's apparent inability to resolve "localhost", "0" * when the loopback device is the only available network interface. */ + if (host != NULL && port == 0) { - portstring = NULL; + portstring = NULL; } else { - TclFormatInt(portbuf, port); - portstring = portbuf; + TclFormatInt(portbuf, port); + portstring = portbuf; } - + (void) memset(&hints, 0, sizeof(hints)); hints.ai_family = AF_UNSPEC; - /* - * Magic variable to enforce a certain address family - to be superseded - * by a TIP that adds explicit switches to [socket] + /* + * Magic variable to enforce a certain address family; to be superseded + * by a TIP that adds explicit switches to [socket]. */ if (interp != NULL) { - family = Tcl_GetVar(interp, "::tcl::unsupported::socketAF", 0); - if (family != NULL) { - if (strcmp(family, "inet") == 0) { - hints.ai_family = AF_INET; - } else if (strcmp(family, "inet6") == 0) { - hints.ai_family = AF_INET6; - } - } + family = Tcl_GetVar2(interp, "::tcl::unsupported::socketAF", NULL, 0); + if (family != NULL) { + if (strcmp(family, "inet") == 0) { + hints.ai_family = AF_INET; + } else if (strcmp(family, "inet6") == 0) { + hints.ai_family = AF_INET6; + } + } } hints.ai_socktype = SOCK_STREAM; @@ -197,7 +220,7 @@ TclCreateSocketAddress( * We found some problems when using AI_ADDRCONFIG, e.g. on systems that * have no networking besides the loopback interface and want to resolve * localhost. See [Bugs 3385024, 3382419, 3382431]. As the advantage of - * using AI_ADDRCONFIG in situations where it works, is probably low, + * using AI_ADDRCONFIG is probably low even in situations where it works, * we'll leave it out for now. After all, it is just an optimisation. * * Missing on: OpenBSD, NetBSD. @@ -211,9 +234,9 @@ TclCreateSocketAddress( if (willBind) { hints.ai_flags |= AI_PASSIVE; - } + } - result = getaddrinfo(native, portstring, &hints, (struct addrinfo **) addrlist); + result = getaddrinfo(native, portstring, &hints, addrlist); if (host != NULL) { Tcl_DStringFree(&ds); @@ -234,6 +257,7 @@ TclCreateSocketAddress( * * There might be more elegant/efficient ways to do this. */ + if (willBind) { for (p = *addrlist; p != NULL; p = p->ai_next) { if (p->ai_family == AF_INET) { @@ -262,15 +286,42 @@ TclCreateSocketAddress( *addrlist = v4head; } } - i = 0; - for (p = *addrlist; p != NULL; p = p->ai_next) { - i++; - } - return 1; } /* + *---------------------------------------------------------------------- + * + * Tcl_OpenTcpServer -- + * + * Opens a TCP server socket and creates a channel around it. + * + * Results: + * The channel or NULL if failed. If an error occurred, an error message + * is left in the interp's result if interp is not NULL. + * + * Side effects: + * Opens a server socket and creates a new channel. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_OpenTcpServer( + Tcl_Interp *interp, + int port, + const char *host, + Tcl_TcpAcceptProc *acceptProc, + ClientData callbackData) +{ + char portbuf[TCL_INTEGER_SPACE]; + + TclFormatInt(portbuf, port); + return Tcl_OpenTcpServerEx(interp, portbuf, host, TCL_TCPSERVER_REUSEADDR, + acceptProc, callbackData); +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 6259216..3132cae 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -19,11 +19,17 @@ */ #include "tclInt.h" -#ifdef __WIN32__ +#ifdef _WIN32 # include "tclWinInt.h" #endif #include "tclFileSystem.h" +#ifdef TCL_TEMPLOAD_NO_UNLINK +#ifndef NO_FSTATFS +#include <sys/statfs.h> +#endif +#endif + /* * struct FilesystemRecord -- * @@ -51,22 +57,21 @@ typedef struct FilesystemRecord { * this information each time the corresponding epoch counter changes. */ -typedef struct ThreadSpecificData { +typedef struct { int initialized; - int cwdPathEpoch; - int filesystemEpoch; + size_t cwdPathEpoch; + size_t filesystemEpoch; Tcl_Obj *cwdPathPtr; ClientData cwdClientData; FilesystemRecord *filesystemList; - int claims; + size_t claims; } ThreadSpecificData; /* * Prototypes for functions defined later in this file. */ -static int EvalFileCallback(ClientData data[], - Tcl_Interp *interp, int result); +static Tcl_NRPostProc EvalFileCallback; static FilesystemRecord*FsGetFirstFilesystem(void); static void FsThrExitProc(ClientData cd); static Tcl_Obj * FsListMounts(Tcl_Obj *pathPtr, const char *pattern); @@ -134,7 +139,6 @@ Tcl_FSRenameFileProc TclpObjRenameFile; Tcl_FSCreateDirectoryProc TclpObjCreateDirectory; Tcl_FSCopyDirectoryProc TclpObjCopyDirectory; Tcl_FSRemoveDirectoryProc TclpObjRemoveDirectory; -Tcl_FSUnloadFileProc TclpUnloadFile; Tcl_FSLinkProc TclpObjLink; Tcl_FSListVolumesProc TclpObjListVolumes; @@ -209,7 +213,7 @@ static FilesystemRecord nativeFilesystemRecord = { * trigger cache cleanup in all threads. */ -static int theFilesystemEpoch = 1; +static size_t theFilesystemEpoch = 1; /* * Stores the linked list of filesystems. A 1:1 copy of this list is also @@ -225,7 +229,7 @@ TCL_DECLARE_MUTEX(filesystemMutex) */ static Tcl_Obj *cwdPathPtr = NULL; -static int cwdPathEpoch = 0; +static size_t cwdPathEpoch = 0; static ClientData cwdClientData = NULL; TCL_DECLARE_MUTEX(cwdMutex) @@ -240,7 +244,7 @@ static Tcl_ThreadDataKey fsDataKey; * code. */ -typedef struct FsDivertLoad { +typedef struct { Tcl_LoadHandle loadHandle; Tcl_FSUnloadFileProc *unloadProcPtr; Tcl_Obj *divertedFile; @@ -407,7 +411,6 @@ Tcl_GetCwd( return Tcl_DStringValue(cwdPtr); } -/* Obsolete */ int Tcl_EvalFile( Tcl_Interp *interp, /* Interpreter in which to process file. */ @@ -539,8 +542,8 @@ TclFSCwdPointerEquals( int len1, len2; const char *str1, *str2; - str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1); - str2 = Tcl_GetStringFromObj(*pathPtrPtr, &len2); + str1 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1); + str2 = TclGetStringFromObj(*pathPtrPtr, &len2); if ((len1 == len2) && !memcmp(str1, str2, len1)) { /* * They are equal, but different objects. Update so they will be @@ -606,6 +609,7 @@ FsRecacheFilesystemList(void) while (toFree) { FilesystemRecord *next = toFree->nextPtr; + toFree->fsPtr = NULL; ckfree(toFree); toFree = next; @@ -633,13 +637,13 @@ FsGetFirstFilesystem(void) } /* - * The epoch can be changed both by filesystems being added or removed and by - * env(HOME) changing. + * The epoch can be changed by filesystems being added or removed, by changing + * the "system encoding" and by env(HOME) changing. */ int TclFSEpochOk( - int filesystemEpoch) + size_t filesystemEpoch) { return (filesystemEpoch == 0 || filesystemEpoch == theFilesystemEpoch); } @@ -660,14 +664,13 @@ Disclaim(void) tsdPtr->claims--; } -int +size_t TclFSEpoch(void) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); return tsdPtr->filesystemEpoch; } - /* * If non-NULL, clientData is owned by us and must be freed later. @@ -683,7 +686,7 @@ FsUpdateCwd( ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); if (cwdObj != NULL) { - str = Tcl_GetStringFromObj(cwdObj, &len); + str = TclGetStringFromObj(cwdObj, &len); } Tcl_MutexLock(&cwdMutex); @@ -707,7 +710,9 @@ FsUpdateCwd( cwdClientData = TclNativeDupInternalRep(clientData); } - cwdPathEpoch++; + if (++cwdPathEpoch == 0) { + ++cwdPathEpoch; + } tsdPtr->cwdPathEpoch = cwdPathEpoch; Tcl_MutexUnlock(&cwdMutex); @@ -777,14 +782,18 @@ TclFinalizeFilesystem(void) while (fsRecPtr != NULL) { FilesystemRecord *tmpFsRecPtr = fsRecPtr->nextPtr; - /* The native filesystem is static, so we don't free it. */ + /* + * The native filesystem is static, so we don't free it. + */ if (fsRecPtr != &nativeFilesystemRecord) { ckfree(fsRecPtr); } fsRecPtr = tmpFsRecPtr; } - theFilesystemEpoch++; + if (++theFilesystemEpoch == 0) { + ++theFilesystemEpoch; + } filesystemList = NULL; /* @@ -792,7 +801,7 @@ TclFinalizeFilesystem(void) * filesystem is likely to fail. */ -#ifdef __WIN32__ +#ifdef _WIN32 TclWinEncodingsCleanup(); #endif } @@ -817,16 +826,9 @@ void TclResetFilesystem(void) { filesystemList = &nativeFilesystemRecord; - theFilesystemEpoch++; - -#ifdef __WIN32__ - /* - * Cleans up the win32 API filesystem proc lookup table. This must happen - * very late in finalization so that deleting of copied dlls can occur. - */ - - TclWinResetInterfaces(); -#endif + if (++theFilesystemEpoch == 0) { + ++theFilesystemEpoch; + } } /* @@ -902,7 +904,9 @@ Tcl_FSRegister( * conceivably now belong to different filesystems. */ - theFilesystemEpoch++; + if (++theFilesystemEpoch == 0) { + ++theFilesystemEpoch; + } Tcl_MutexUnlock(&filesystemMutex); return TCL_OK; @@ -934,7 +938,7 @@ Tcl_FSRegister( int Tcl_FSUnregister( - const Tcl_Filesystem *fsPtr) /* The filesystem record to remove. */ + const Tcl_Filesystem *fsPtr)/* The filesystem record to remove. */ { int retVal = TCL_ERROR; FilesystemRecord *fsRecPtr; @@ -967,7 +971,9 @@ Tcl_FSUnregister( * (which would of course lead to memory exceptions). */ - theFilesystemEpoch++; + if (++theFilesystemEpoch == 0) { + ++theFilesystemEpoch; + } ckfree(fsRecPtr); @@ -1209,8 +1215,8 @@ FsAddMountsToGlobResult( if (norm != NULL) { const char *path, *mount; - mount = Tcl_GetStringFromObj(mElt, &mlen); - path = Tcl_GetStringFromObj(norm, &len); + mount = TclGetStringFromObj(mElt, &mlen); + path = TclGetStringFromObj(norm, &len); if (path[len-1] == '/') { /* * Deal with the root of the volume. @@ -1218,7 +1224,7 @@ FsAddMountsToGlobResult( len--; } - len++; /* account for '/' in the mElt [Bug 1602539] */ + len++; /* account for '/' in the mElt [Bug 1602539] */ mElt = TclNewFSPathObj(pathPtr, mount + len, mlen - len); Tcl_ListObjAppendElement(NULL, resultPtr, mElt); } @@ -1298,7 +1304,9 @@ Tcl_FSMountsChanged( */ Tcl_MutexLock(&filesystemMutex); - theFilesystemEpoch++; + if (++theFilesystemEpoch == 0) { + ++theFilesystemEpoch; + } Tcl_MutexUnlock(&filesystemMutex); } @@ -1386,7 +1394,7 @@ TclFSNormalizeToUniquePath( * 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). + * native filesystem (i.e., '/' on unix is native). */ firstFsRecPtr = FsGetFirstFilesystem(); @@ -1508,7 +1516,7 @@ TclGetOpenModeEx( #define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR) /* - * Check for the simpler fopen-like access modes (e.g. "r"). They are + * Check for the simpler fopen-like access modes (e.g., "r"). They are * distinguished from the POSIX access modes by the presence of a * lower-case first letter. */ @@ -1745,7 +1753,7 @@ Tcl_FSEvalFileEx( * this cross-platform to allow for scripted documents. [Bug: 2040] */ - Tcl_SetChannelOption(interp, chan, "-eofchar", "\32"); + Tcl_SetChannelOption(interp, chan, "-eofchar", "\32 {}"); /* * If the encoding is specified, set it for the channel. Else don't touch @@ -1799,7 +1807,7 @@ Tcl_FSEvalFileEx( oldScriptFile = iPtr->scriptFile; iPtr->scriptFile = pathPtr; Tcl_IncrRefCount(iPtr->scriptFile); - string = Tcl_GetStringFromObj(objPtr, &length); + string = TclGetStringFromObj(objPtr, &length); /* * TIP #280 Force the evaluator to open a frame for a sourced file. @@ -1826,7 +1834,7 @@ Tcl_FSEvalFileEx( * Record information telling where the error occurred. */ - const char *pathString = Tcl_GetStringFromObj(pathPtr, &length); + const char *pathString = TclGetStringFromObj(pathPtr, &length); int limit = 150; int overflow = (length > limit); @@ -1873,13 +1881,14 @@ TclNREvalFile( Tcl_GetString(pathPtr), Tcl_PosixError(interp))); return TCL_ERROR; } + TclPkgFileSeen(interp, Tcl_GetString(pathPtr)); /* * The eofchar is \32 (^Z). This is the usual on Windows, but we effect * this cross-platform to allow for scripted documents. [Bug: 2040] */ - Tcl_SetChannelOption(interp, chan, "-eofchar", "\32"); + Tcl_SetChannelOption(interp, chan, "-eofchar", "\32 {}"); /* * If the encoding is specified, set it for the channel. Else don't touch @@ -1977,7 +1986,7 @@ EvalFileCallback( */ int length; - const char *pathString = Tcl_GetStringFromObj(pathPtr, &length); + const char *pathString = TclGetStringFromObj(pathPtr, &length); const int limit = 150; int overflow = (length > limit); @@ -2653,6 +2662,7 @@ Tcl_FSGetCwd( fsRecPtr = fsRecPtr->nextPtr) { ClientData retCd; TclFSGetCwdProc2 *proc2; + if (fsRecPtr->fsPtr->getCwdProc == NULL) { continue; } @@ -2829,8 +2839,8 @@ Tcl_FSGetCwd( int len1, len2; const char *str1, *str2; - str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1); - str2 = Tcl_GetStringFromObj(norm, &len2); + str1 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1); + str2 = TclGetStringFromObj(norm, &len2); if ((len1 == len2) && (strcmp(str1, str2) == 0)) { /* * If the paths were equal, we can be more efficient and @@ -2884,9 +2894,13 @@ int Tcl_FSChdir( Tcl_Obj *pathPtr) { - const Tcl_Filesystem *fsPtr; + const Tcl_Filesystem *fsPtr, *oldFsPtr = NULL; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); int retVal = -1; + if (tsdPtr->cwdPathPtr != NULL) { + oldFsPtr = Tcl_FSGetFileSystemForPath(tsdPtr->cwdPathPtr); + } if (Tcl_FSGetNormalizedPath(NULL, pathPtr) == NULL) { Tcl_SetErrno(ENOENT); return retVal; @@ -2986,7 +3000,6 @@ Tcl_FSChdir( * instead. This should be examined by someone on Unix. */ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); ClientData cd; ClientData oldcd = tsdPtr->cwdClientData; @@ -3003,6 +3016,14 @@ Tcl_FSChdir( } else { FsUpdateCwd(normDirName, NULL); } + + /* + * If the filesystem changed between old and new cwd + * force filesystem refresh on path objects. + */ + if (oldFsPtr != NULL && fsPtr != oldFsPtr) { + Tcl_FSMountsChanged(NULL); + } } return retVal; @@ -3110,6 +3131,87 @@ Tcl_FSLoadFile( *---------------------------------------------------------------------- */ +/* + * Workaround for issue with modern HPUX which do allow the unlink (no ETXTBSY + * error) yet somehow trash some internal data structures which prevents the + * second and further shared libraries from getting properly loaded. Only the + * first is ok. We try to get around the issue by not unlinking, i.e., + * emulating the behaviour of the older HPUX which denied removal. + * + * Doing the unlink is also an issue within docker containers, whose AUFS + * bungles this as well, see + * https://github.com/dotcloud/docker/issues/1911 + * + * For these situations the change below makes the execution of the unlink + * semi-controllable at runtime. + * + * An AUFS filesystem (if it can be detected) will force avoidance of + * unlink. The env variable TCL_TEMPLOAD_NO_UNLINK allows detection of a + * users general request (unlink and not. + * + * By default the unlink is done (if not in AUFS). However if the variable is + * present and set to true (any integer > 0) then the unlink is skipped. + */ + +static int +skipUnlink( + Tcl_Obj *shlibFile) +{ + /* + * Order of testing: + * 1. On hpux we generally want to skip unlink in general + * + * Outside of hpux then: + * 2. For a general user request (TCL_TEMPLOAD_NO_UNLINK present, + * non-empty, => int) + * 3. For general AUFS environment (statfs, if available). + * + * Ad 2: This variable can disable/override the AUFS detection, i.e. for + * testing if a newer AUFS does not have the bug any more. + * + * Ad 3: This is conditionally compiled in. Condition currently must be + * set manually. This part needs proper tests in the configure(.in). + */ + +#ifdef hpux + return 1; +#else + char *skipstr = getenv("TCL_TEMPLOAD_NO_UNLINK"); + + if (skipstr && (skipstr[0] != '\0')) { + return atoi(skipstr); + } + +#ifdef TCL_TEMPLOAD_NO_UNLINK +#ifndef NO_FSTATFS + { + struct statfs fs; + /* + * Have fstatfs. May not have the AUFS super magic ... Indeed our build + * box is too old to have it directly in the headers. Define taken from + * http://mooon.googlecode.com/svn/trunk/linux_include/linux/aufs_type.h + * http://aufs.sourceforge.net/ + * Better reference will be gladly taken. + */ +#ifndef AUFS_SUPER_MAGIC +#define AUFS_SUPER_MAGIC ('a' << 24 | 'u' << 16 | 'f' << 8 | 's') +#endif /* AUFS_SUPER_MAGIC */ + if ((statfs(Tcl_GetString(shlibFile), &fs) == 0) + && (fs.f_type == AUFS_SUPER_MAGIC)) { + return 1; + } + } +#endif /* ... NO_FSTATFS */ +#endif /* ... TCL_TEMPLOAD_NO_UNLINK */ + + /* + * Fallback: !hpux, no EV override, no AUFS (detection, nor detected): + * Don't skip + */ + return 0; +#endif /* hpux */ +} + int Tcl_LoadFile( Tcl_Interp *interp, /* Used for error reporting. */ @@ -3149,7 +3251,9 @@ Tcl_LoadFile( if (*handlePtr == NULL) { return TCL_ERROR; } - Tcl_ResetResult(interp); + if (interp) { + Tcl_ResetResult(interp); + } goto resolveSymbols; } if (Tcl_GetErrno() != EXDEV) { @@ -3165,9 +3269,11 @@ Tcl_LoadFile( */ if (Tcl_FSAccess(pathPtr, R_OK) != 0) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't load library \"%s\": %s", - Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't load library \"%s\": %s", + Tcl_GetString(pathPtr), Tcl_PosixError(interp))); + } return TCL_ERROR; } @@ -3216,7 +3322,9 @@ Tcl_LoadFile( } mustCopyToTempAnyway: - Tcl_ResetResult(interp); + if (interp) { + Tcl_ResetResult(interp); + } #endif /* TCL_LOAD_FROM_MEMORY */ /* @@ -3240,8 +3348,10 @@ Tcl_LoadFile( Tcl_FSDeleteFile(copyToPtr); Tcl_DecrRefCount(copyToPtr); - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "couldn't load from current filesystem", -1)); + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "couldn't load from current filesystem", -1)); + } return TCL_ERROR; } @@ -3255,7 +3365,7 @@ Tcl_LoadFile( return TCL_ERROR; } -#ifndef __WIN32__ +#ifndef _WIN32 /* * Do we need to set appropriate permissions on the file? This may be * required on some systems. On Unix we could loop over the file @@ -3281,7 +3391,9 @@ Tcl_LoadFile( * have stored the number of bytes in the result. */ - Tcl_ResetResult(interp); + if (interp) { + Tcl_ResetResult(interp); + } retVal = Tcl_LoadFile(interp, copyToPtr, symbols, flags, procPtrs, &newLoadHandle); @@ -3300,7 +3412,8 @@ Tcl_LoadFile( * avoids any worries about leaving the copy laying around on exit. */ - if (Tcl_FSDeleteFile(copyToPtr) == TCL_OK) { + if (!skipUnlink(copyToPtr) && + (Tcl_FSDeleteFile(copyToPtr) == TCL_OK)) { Tcl_DecrRefCount(copyToPtr); /* @@ -3311,7 +3424,9 @@ Tcl_LoadFile( */ *handlePtr = newLoadHandle; - Tcl_ResetResult(interp); + if (interp) { + Tcl_ResetResult(interp); + } return TCL_OK; } @@ -3372,11 +3487,13 @@ Tcl_LoadFile( divertedLoadHandle->unloadFileProcPtr = DivertUnloadFile; *handlePtr = divertedLoadHandle; - Tcl_ResetResult(interp); + if (interp) { + Tcl_ResetResult(interp); + } return retVal; resolveSymbols: - /* + /* * At this point, *handlePtr is already set up to the handle for the * loaded library. We now try to resolve the symbols. */ @@ -3385,7 +3502,7 @@ Tcl_LoadFile( for (i=0 ; symbols[i] != NULL; i++) { procPtrs[i] = Tcl_FindSymbol(interp, *handlePtr, symbols[i]); if (procPtrs[i] == NULL) { - /* + /* * At least one symbol in the list was not found. Unload the * file, and report the problem back to the caller. * (Tcl_FindSymbol should already have left an appropriate @@ -3405,7 +3522,7 @@ Tcl_LoadFile( *---------------------------------------------------------------------- * * DivertFindSymbol -- - * + * * Find a symbol in a shared library loaded by copy-from-VFS. * *---------------------------------------------------------------------- @@ -3564,30 +3681,10 @@ Tcl_FSUnloadFile( } return TCL_ERROR; } - TclpUnloadFile(handle); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclpUnloadFile -- - * - * Unloads a library given its handle - * - * This function was once filesystem-specific, but has been made portable by - * having TclpDlopen return a structure that includes procedure pointers. - * - *---------------------------------------------------------------------- - */ - -void -TclpUnloadFile( - Tcl_LoadHandle handle) -{ if (handle->unloadFileProcPtr != NULL) { handle->unloadFileProcPtr(handle); } + return TCL_OK; } /* @@ -3995,7 +4092,7 @@ TclGetPathType( * caller. */ { int pathLen; - const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen); + const char *path = TclGetStringFromObj(pathPtr, &pathLen); Tcl_PathType type; type = TclFSNonnativePathType(path, pathLen, filesystemPtrPtr, @@ -4107,7 +4204,7 @@ TclFSNonnativePathType( numVolumes--; Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol); - strVol = Tcl_GetStringFromObj(vol,&len); + strVol = TclGetStringFromObj(vol,&len); if (pathLen < len) { continue; } @@ -4454,8 +4551,8 @@ Tcl_FSRemoveDirectory( Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr); if (normPath != NULL) { - normPathStr = Tcl_GetStringFromObj(normPath, &normLen); - cwdStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen); + normPathStr = TclGetStringFromObj(normPath, &normLen); + cwdStr = TclGetStringFromObj(cwdPtr, &cwdLen); if ((cwdLen >= normLen) && (strncmp(normPathStr, cwdStr, (size_t) normLen) == 0)) { /* diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index ce8b9fb..eeed0e5 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -101,6 +101,7 @@ typedef struct { *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_GetIndexFromObj int Tcl_GetIndexFromObj( @@ -114,14 +115,13 @@ Tcl_GetIndexFromObj( int flags, /* 0 or TCL_EXACT */ int *indexPtr) /* Place to store resulting integer index. */ { - /* * See if there is a valid cached result from a previous lookup (doing the * check here saves the overhead of calling Tcl_GetIndexFromObjStruct in * the common case where the result is cached). */ - if (objPtr->typePtr == &indexType) { + if (!(flags & INDEX_TEMP_TABLE) && objPtr->typePtr == &indexType) { IndexRep *indexRep = objPtr->internalRep.twoPtrValue.ptr1; /* @@ -138,6 +138,7 @@ Tcl_GetIndexFromObj( return Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, sizeof(char *), msg, flags, indexPtr); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -211,13 +212,8 @@ GetIndexFromObjList( tablePtr[objc] = NULL; result = Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, - sizeof(char *), msg, flags, indexPtr); + sizeof(char *), msg, flags | INDEX_TEMP_TABLE, indexPtr); - /* - * The internal rep must be cleared since tablePtr will go away. - */ - - TclFreeIntRep(objPtr); ckfree(tablePtr); return result; @@ -279,7 +275,7 @@ Tcl_GetIndexFromObjStruct( * See if there is a valid cached result from a previous lookup. */ - if (objPtr->typePtr == &indexType) { + if (!(flags & INDEX_TEMP_TABLE) && objPtr->typePtr == &indexType) { indexRep = objPtr->internalRep.twoPtrValue.ptr1; if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) { *indexPtr = indexRep->index; @@ -340,17 +336,19 @@ Tcl_GetIndexFromObjStruct( * operation. */ - if (objPtr->typePtr == &indexType) { - indexRep = objPtr->internalRep.twoPtrValue.ptr1; - } else { - TclFreeIntRep(objPtr); - indexRep = ckalloc(sizeof(IndexRep)); - objPtr->internalRep.twoPtrValue.ptr1 = indexRep; - objPtr->typePtr = &indexType; + if (!(flags & INDEX_TEMP_TABLE)) { + if (objPtr->typePtr == &indexType) { + indexRep = objPtr->internalRep.twoPtrValue.ptr1; + } else { + TclFreeIntRep(objPtr); + indexRep = ckalloc(sizeof(IndexRep)); + objPtr->internalRep.twoPtrValue.ptr1 = indexRep; + objPtr->typePtr = &indexType; + } + indexRep->tablePtr = (void *) tablePtr; + indexRep->offset = offset; + indexRep->index = index; } - indexRep->tablePtr = (void *) tablePtr; - indexRep->offset = offset; - indexRep->index = index; *indexPtr = index; return TCL_OK; @@ -712,10 +710,10 @@ PrefixAllObjCmd( return result; } resultPtr = Tcl_NewListObj(0, NULL); - string = Tcl_GetStringFromObj(objv[2], &length); + string = TclGetStringFromObj(objv[2], &length); for (t = 0; t < tableObjc; t++) { - elemString = Tcl_GetStringFromObj(tableObjv[t], &elemLength); + elemString = TclGetStringFromObj(tableObjv[t], &elemLength); /* * A prefix cannot match if it is longest. @@ -768,13 +766,13 @@ PrefixLongestObjCmd( if (result != TCL_OK) { return result; } - string = Tcl_GetStringFromObj(objv[2], &length); + string = TclGetStringFromObj(objv[2], &length); resultString = NULL; resultLength = 0; for (t = 0; t < tableObjc; t++) { - elemString = Tcl_GetStringFromObj(tableObjv[t], &elemLength); + elemString = TclGetStringFromObj(tableObjv[t], &elemLength); /* * First check if the prefix string matches the element. A prefix @@ -878,7 +876,8 @@ Tcl_WrongNumArgs( * NULL. */ { Tcl_Obj *objPtr; - int i, len, elemLen, flags; + int i, len, elemLen; + char flags; Interp *iPtr = (Interp *) interp; const char *elementStr; @@ -925,6 +924,14 @@ Tcl_WrongNumArgs( Tcl_Obj *const *origObjv = iPtr->ensembleRewrite.sourceObjs; /* + * Check for spelling fixes, and substitute the fixed values. + */ + + if (origObjv[0] == NULL) { + origObjv = (Tcl_Obj *const *)origObjv[2]; + } + + /* * We only know how to do rewriting if all the replaced objects are * actually arguments (in objv) to this function. Otherwise it just * gets too complicated and we'd be better off just giving a slightly @@ -957,12 +964,6 @@ Tcl_WrongNumArgs( elementStr = EXPAND_OF(indexRep); elemLen = strlen(elementStr); - } else if (origObjv[i]->typePtr == &tclEnsembleCmdType) { - register EnsembleCmdRep *ecrPtr = - origObjv[i]->internalRep.twoPtrValue.ptr1; - - elementStr = ecrPtr->fullSubcmdName; - elemLen = strlen(elementStr); } else { elementStr = TclGetStringFromObj(origObjv[i], &elemLen); } @@ -1011,11 +1012,6 @@ Tcl_WrongNumArgs( register IndexRep *indexRep = objv[i]->internalRep.twoPtrValue.ptr1; Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), NULL); - } else if (objv[i]->typePtr == &tclEnsembleCmdType) { - register EnsembleCmdRep *ecrPtr = - objv[i]->internalRep.twoPtrValue.ptr1; - - Tcl_AppendStringsToObj(objPtr, ecrPtr->fullSubcmdName, NULL); } else { /* * Quote the argument if it contains spaces (Bug 942757). @@ -1151,7 +1147,7 @@ Tcl_ParseArgsObjv( curArg = objv[srcIndex]; srcIndex++; objc--; - str = Tcl_GetStringFromObj(curArg, &length); + str = TclGetStringFromObj(curArg, &length); if (length > 0) { c = str[1]; } else { diff --git a/generic/tclInt.decls b/generic/tclInt.decls index f0e907f..4c08fca 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -2,9 +2,8 @@ # # This file contains the declarations for all unsupported # functions that are exported by the Tcl library. This file -# is used to generate the tclIntDecls.h, tclIntPlatDecls.h, -# tclIntStub.c, tclPlatStub.c, tclCompileDecls.h and tclCompileStub.c -# files +# is used to generate the tclIntDecls.h, tclIntPlatDecls.h +# and tclStubInit.c files # # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. @@ -51,7 +50,7 @@ declare 6 { declare 7 { int TclCopyAndCollapse(int count, const char *src, char *dst) } -declare 8 { +declare 8 {deprecated {}} { int TclCopyChannelOld(Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr) } @@ -74,7 +73,7 @@ declare 11 { declare 12 { void TclDeleteVars(Interp *iPtr, TclVarHashTable *tablePtr) } -# Removed in 8.5 +# Removed in 8.5: #declare 13 { # int TclDoGlob(Tcl_Interp *interp, char *separators, # Tcl_DString *headPtr, char *tail, Tcl_GlobTypeData *types) @@ -89,7 +88,7 @@ declare 14 { declare 16 { void TclExprFloatError(Tcl_Interp *interp, double value) } -# Removed in 8.4 +# Removed in 8.4: #declare 17 { # int TclFileAttrsCmd(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) #} @@ -115,7 +114,7 @@ declare 23 { } # Replaced with macro (see tclInt.h) in Tcl 8.5.0, restored in 8.5.10 declare 24 { - int TclFormatInt(char *buffer, long n) + int TclFormatInt(char *buffer, Tcl_WideInt n) } declare 25 { void TclFreePackageInfo(Interp *iPtr) @@ -124,7 +123,7 @@ declare 25 { # declare 26 { # char *TclGetCwd(Tcl_Interp *interp) # } -# Removed in 8.5 +# Removed in 8.5: #declare 27 { # int TclGetDate(char *p, unsigned long now, long zone, # unsigned long *timePtr) @@ -148,7 +147,7 @@ declare 32 { int TclGetFrame(Tcl_Interp *interp, const char *str, CallFrame **framePtrPtr) } -# Removed in Tcl 8.5 +# Removed in 8.5: #declare 33 { # TclCmdProcType TclGetInterpProc(void) #} @@ -161,7 +160,7 @@ declare 34 { # Tcl_Obj *TclGetIndexedScalar(Tcl_Interp *interp, int localIndex, # int flags) #} -# Removed in 8.6a2 +# Removed in 8.6a2: #declare 36 { # int TclGetLong(Tcl_Interp *interp, const char *str, long *longPtr) #} @@ -186,9 +185,9 @@ declare 41 { declare 42 { CONST86 char *TclpGetUserHome(const char *name, Tcl_DString *bufferPtr) } -# Removed in Tcl 8.5a2 +# Removed in 8.5a2: #declare 43 { -# int TclGlobalInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv, +# int TclGlobalInvoke(Tcl_Interp *interp, int argc, const char **argv, # int flags) #} declare 44 { @@ -221,14 +220,14 @@ declare 50 { declare 51 { int TclInterpInit(Tcl_Interp *interp) } -# Removed in Tcl 8.5a2 +# Removed in 8.5a2: #declare 52 { -# int TclInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv, +# int TclInvoke(Tcl_Interp *interp, int argc, const char **argv, # int flags) #} declare 53 { int TclInvokeObjectCommand(ClientData clientData, Tcl_Interp *interp, - int argc, CONST84 char **argv) + int argc, const char **argv) } declare 54 { int TclInvokeStringCommand(ClientData clientData, Tcl_Interp *interp, @@ -274,7 +273,7 @@ declare 64 { int TclObjInvoke(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags) } -# Removed in Tcl 8.5a2 +# Removed in 8.5a2: #declare 65 { # int TclObjInvokeGlobal(Tcl_Interp *interp, int objc, # Tcl_Obj *const objv[], int flags) @@ -314,9 +313,7 @@ declare 75 { declare 76 { unsigned long TclpGetSeconds(void) } - -# deprecated -declare 77 { +declare 77 {deprecated {}} { void TclpGetTime(Tcl_Time *time) } # Removed in 8.6: @@ -358,7 +355,7 @@ declare 81 { # declare 87 { # void TclPlatformInit(Tcl_Interp *interp) # } -declare 88 { +declare 88 {deprecated {}} { char *TclPrecTraceProc(ClientData clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags) } @@ -381,7 +378,7 @@ declare 92 { declare 93 { void TclProcDeleteProc(ClientData clientData) } -# Removed in Tcl 8.5: +# Removed in 8.5: #declare 94 { # int TclProcInterpProc(ClientData clientData, Tcl_Interp *interp, # int argc, const char **argv) @@ -420,7 +417,7 @@ declare 103 { int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto, int *portPtr) } -declare 104 { +declare 104 {deprecated {}} { int TclSockMinimumBuffersOld(int sock, int size) } # Replaced by Tcl_FSStat in 8.4: @@ -456,26 +453,26 @@ declare 111 { Tcl_ResolveCompiledVarProc *compiledVarProc) } declare 112 { - int Tcl_AppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + int TclAppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr) } declare 113 { - Tcl_Namespace *Tcl_CreateNamespace(Tcl_Interp *interp, const char *name, + Tcl_Namespace *TclCreateNamespace(Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc) } declare 114 { - void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr) + void TclDeleteNamespace(Tcl_Namespace *nsPtr) } declare 115 { - int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + int TclExport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst) } declare 116 { - Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name, + Tcl_Command TclFindCommand(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags) } declare 117 { - Tcl_Namespace *Tcl_FindNamespace(Tcl_Interp *interp, const char *name, + Tcl_Namespace *TclFindNamespace(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags) } declare 118 { @@ -491,28 +488,28 @@ declare 120 { Tcl_Namespace *contextNsPtr, int flags) } declare 121 { - int Tcl_ForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + int TclForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern) } declare 122 { - Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr) + Tcl_Command TclGetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr) } declare 123 { - void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command, + void TclGetCommandFullName(Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr) } declare 124 { - Tcl_Namespace *Tcl_GetCurrentNamespace(Tcl_Interp *interp) + Tcl_Namespace *TclGetCurrentNamespace_(Tcl_Interp *interp) } declare 125 { - Tcl_Namespace *Tcl_GetGlobalNamespace(Tcl_Interp *interp) + Tcl_Namespace *TclGetGlobalNamespace_(Tcl_Interp *interp) } declare 126 { void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr) } declare 127 { - int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + int TclImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite) } declare 128 { @@ -533,7 +530,7 @@ declare 131 { declare 132 { int TclpHasSockets(Tcl_Interp *interp) } -declare 133 { +declare 133 {deprecated {}} { struct tm *TclpGetDate(const time_t *time, int useGMT) } # Removed in 8.5 @@ -551,7 +548,7 @@ declare 133 { # int TclpChdir(const char *dirName) #} declare 138 { - CONST84_RETURN char *TclGetEnv(const char *name, Tcl_DString *valuePtr) + const char *TclGetEnv(const char *name, Tcl_DString *valuePtr) } #declare 139 { # int TclpLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, @@ -563,7 +560,7 @@ declare 138 { #} # This is used by TclX, but should otherwise be considered private declare 141 { - CONST84_RETURN char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr) + const char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr) } declare 142 { int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr, @@ -626,12 +623,10 @@ declare 156 { declare 157 { Var *TclVarTraceExists(Tcl_Interp *interp, const char *varName) } -# REMOVED (except from stub table) - use public Tcl_SetStartupScript() -declare 158 { +declare 158 {deprecated {use public Tcl_SetStartupScript()}} { void TclSetStartupScriptFileName(const char *filename) } -# REMOVED (except from stub table) - use public Tcl_GetStartupScript() -declare 159 { +declare 159 {deprecated {use public Tcl_GetStartupScript()}} { const char *TclGetStartupScriptFileName(void) } #declare 160 { @@ -677,13 +672,10 @@ declare 166 { int index, Tcl_Obj *valuePtr) } -# VFS-aware versions of Tcl*StartupScriptFileName (158 and 159 above) -# REMOVED (except from stub table) - use public Tcl_SetStartupScript() -declare 167 { +declare 167 {deprecated {use public Tcl_SetStartupScript()}} { void TclSetStartupScriptPath(Tcl_Obj *pathPtr) } -# REMOVED (except from stub table) - use public Tcl_GetStartupScript() -declare 168 { +declare 168 {deprecated {use public Tcl_GetStartupScript()}} { Tcl_Obj *TclGetStartupScriptPath(void) } # variant of Tcl_UtfNCmp that takes n as bytes, not chars @@ -731,12 +723,11 @@ declare 177 { void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason) } -# TIP 338 made these public - now declared in tcl.h too declare 178 { - void Tcl_SetStartupScript(Tcl_Obj *pathPtr, const char *encodingName) + void TclSetStartupScript(Tcl_Obj *pathPtr, const char *encodingName) } declare 179 { - Tcl_Obj *Tcl_GetStartupScript(const char **encodingNamePtr) + Tcl_Obj *TclGetStartupScript(const char **encodingNamePtr) } # REMOVED @@ -749,12 +740,10 @@ declare 179 { # const char *file, int line) #} -# TclpGmtime and TclpLocaltime promoted to the generic interface from unix - -declare 182 { +declare 182 {deprecated {}} { struct tm *TclpLocaltime(const time_t *clock) } -declare 183 { +declare 183 {deprecated {}} { struct tm *TclpGmtime(const time_t *clock) } @@ -938,10 +927,7 @@ declare 234 { declare 235 { void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr) } - - -# TIP 337 made this one public -declare 236 { +declare 236 {deprecated {use Tcl_BackgroundException}} { void TclBackgroundException(Tcl_Interp *interp, int code) } @@ -1006,6 +992,38 @@ declare 249 { declare 250 { void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags, int force) } + +# Allow extensions for optimization +declare 251 { + int TclRegisterLiteral(void *envPtr, + const char *bytes, int length, int flags) +} + +# Exporting of the internal API to variables. + +declare 252 { + Tcl_Obj *TclPtrGetVar(Tcl_Interp *interp, Tcl_Var varPtr, + Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, + const int flags) +} +declare 253 { + Tcl_Obj *TclPtrSetVar(Tcl_Interp *interp, Tcl_Var varPtr, + Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, + Tcl_Obj *newValuePtr, const int flags) +} +declare 254 { + Tcl_Obj *TclPtrIncrObjVar(Tcl_Interp *interp, Tcl_Var varPtr, + Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, + Tcl_Obj *incrPtr, const int flags) +} +declare 255 { + int TclPtrObjMakeUpvar(Tcl_Interp *interp, Tcl_Var otherPtr, + Tcl_Obj *myNamePtr, int myFlags) +} +declare 256 { + int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, + Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags) +} ############################################################################## @@ -1057,9 +1075,9 @@ declare 9 win { } # new for 8.4.20+/8.5.12+ Cygwin only declare 10 win { - Tcl_DirEntry *TclpReaddir(DIR *dir) + Tcl_DirEntry *TclpReaddir(TclDIR *dir) } -# Removed in 8.3.1 (for Win32s only) +# Removed in 8.3.1 (for Win32s only): #declare 10 win { # int TclWinSynchSpawn(void *args, int type, void **trans, Tcl_Pid *pidPtr) #} @@ -1109,7 +1127,6 @@ declare 19 win { declare 20 win { void TclWinAddProcess(HANDLE hProcess, DWORD id) } -# new for 8.4.20+/8.5.12+ declare 21 win { char *TclpInetNtoa(struct in_addr addr) } @@ -1195,7 +1212,7 @@ declare 9 unix { # Added in 8.4: declare 10 unix { - Tcl_DirEntry *TclpReaddir(DIR *dir) + Tcl_DirEntry *TclpReaddir(TclDIR *dir) } # Slots 11 and 12 are forwarders for functions that were promoted to # generic Stubs @@ -1241,7 +1258,7 @@ declare 19 macosx { } declare 29 {win unix} { - int TclWinCPUID(unsigned int index, unsigned int *regs) + int TclWinCPUID(int index, int *regs) } # Added in 8.6; core of TclpOpenTemporaryFile declare 30 {win unix} { diff --git a/generic/tclInt.h b/generic/tclInt.h index 08a18a1..e9af967 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -26,6 +26,36 @@ #undef ACCEPT_NAN /* + * In Tcl 8.7, stop supporting special hacks for legacy Itcl 3. + * Itcl 4 doesn't need them. Itcl 3 can be updated to not need them + * using the Tcl(Init|Reset)RewriteEnsemble() routines in all Tcl 8.6+ + * releases. Perhaps Tcl 8.7 will add even better public interfaces + * supporting all the re-invocation mechanisms extensions like Itcl 3 + * need. As an absolute last resort, folks who must make Itcl 3 work + * unchanged with Tcl 8.7 can remove this line to regain the migration + * support. Tcl 9 will no longer offer even that option. + */ + +#define AVOID_HACKS_FOR_ITCL 1 + + +/* + * Used to tag functions that are only to be visible within the module being + * built and not outside it (where this is supported by the linker). + * Also used in the platform-specific *Port.h files. + */ + +#ifndef MODULE_SCOPE +# ifdef __cplusplus +# define MODULE_SCOPE extern "C" +# else +# define MODULE_SCOPE extern +# endif +#endif + + + +/* * Common include files needed by most of the Tcl source files are included * here, so that system-dependent personalizations for the include files only * have to be made in once place. This results in a few extra includes, but @@ -48,7 +78,8 @@ #else #include <string.h> #endif -#ifdef STDC_HEADERS +#if defined(STDC_HEADERS) || defined(__STDC__) || defined(__C99__FUNC__) \ + || defined(__cplusplus) || defined(_MSC_VER) #include <stddef.h> #else typedef int ptrdiff_t; @@ -81,19 +112,6 @@ typedef int ptrdiff_t; #endif /* - * Used to tag functions that are only to be visible within the module being - * built and not outside it (where this is supported by the linker). - */ - -#ifndef MODULE_SCOPE -# ifdef __cplusplus -# define MODULE_SCOPE extern "C" -# else -# define MODULE_SCOPE extern -# endif -#endif - -/* * Macros used to cast between pointers and integers (e.g. when storing an int * in ClientData), on 64-bit architectures they avoid gcc warning about "cast * to/from pointer from/to integer of different size". @@ -122,6 +140,26 @@ typedef int ptrdiff_t; # define vsnprintf _vsnprintf #endif +#if !defined(TCL_THREADS) +# define TCL_THREADS 1 +#endif +#if !TCL_THREADS +# undef TCL_DECLARE_MUTEX +# define TCL_DECLARE_MUTEX(name) +# undef Tcl_MutexLock +# define Tcl_MutexLock(mutexPtr) +# undef Tcl_MutexUnlock +# define Tcl_MutexUnlock(mutexPtr) +# undef Tcl_MutexFinalize +# define Tcl_MutexFinalize(mutexPtr) +# undef Tcl_ConditionNotify +# define Tcl_ConditionNotify(condPtr) +# undef Tcl_ConditionWait +# define Tcl_ConditionWait(condPtr, mutexPtr, timePtr) +# undef Tcl_ConditionFinalize +# define Tcl_ConditionFinalize(condPtr) +#endif + /* * The following procedures allow namespaces to be customized to support * special name resolution rules for commands/variables. @@ -146,13 +184,13 @@ typedef struct Tcl_ResolvedVarInfo { } Tcl_ResolvedVarInfo; typedef int (Tcl_ResolveCompiledVarProc)(Tcl_Interp *interp, - CONST84 char *name, int length, Tcl_Namespace *context, + const char *name, int length, Tcl_Namespace *context, Tcl_ResolvedVarInfo **rPtr); -typedef int (Tcl_ResolveVarProc)(Tcl_Interp *interp, CONST84 char *name, +typedef int (Tcl_ResolveVarProc)(Tcl_Interp *interp, const char *name, Tcl_Namespace *context, int flags, Tcl_Var *rPtr); -typedef int (Tcl_ResolveCmdProc)(Tcl_Interp *interp, CONST84 char *name, +typedef int (Tcl_ResolveCmdProc)(Tcl_Interp *interp, const char *name, Tcl_Namespace *context, int flags, Tcl_Command *rPtr); typedef struct Tcl_ResolverInfo { @@ -169,6 +207,21 @@ typedef struct Tcl_ResolverInfo { } Tcl_ResolverInfo; /* + * This flag bit should not interfere with TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY, or TCL_LEAVE_ERR_MSG; it signals that the variable + * lookup is performed for upvar (or similar) purposes, with slightly + * different rules: + * - Bug #696893 - variable is either proc-local or in the current + * namespace; never follow the second (global) resolution path + * - Bug #631741 - do not use special namespace or interp resolvers + * + * It should also not collide with the (deprecated) TCL_PARSE_PART1 flag + * (Bug #835020) + */ + +#define TCL_AVOID_RESOLVERS 0x40000 + +/* *---------------------------------------------------------------- * Data structures related to namespaces. *---------------------------------------------------------------- @@ -236,7 +289,7 @@ typedef struct Namespace { * strings; values have type (Namespace *). If * NULL, there are no children. */ #endif - long nsId; /* Unique id for the namespace. */ + unsigned long nsId; /* Unique id for the namespace. */ Tcl_Interp *interp; /* The interpreter containing this * namespace. */ int flags; /* OR-ed combination of the namespace status @@ -245,7 +298,7 @@ typedef struct Namespace { * frames for this namespace that are on the * Tcl call stack. The namespace won't be * freed until activationCount becomes zero. */ - int refCount; /* Count of references by namespaceName + unsigned int refCount; /* Count of references by namespaceName * objects. The namespace can't be freed until * refCount becomes zero. */ Tcl_HashTable cmdTable; /* Contains all the commands currently @@ -270,12 +323,12 @@ typedef struct Namespace { * registered using "namespace export". */ int maxExportPatterns; /* Mumber of export patterns for which space * is currently allocated. */ - int cmdRefEpoch; /* Incremented if a newly added command + unsigned int cmdRefEpoch; /* Incremented if a newly added command * shadows a command for which this namespace * has already cached a Command* pointer; this * causes all its cached Command* pointers to * be invalidated. */ - int resolverEpoch; /* Incremented whenever (a) the name + unsigned 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 @@ -302,7 +355,7 @@ typedef struct Namespace { * LookupCompiledLocal to resolve variable * references within the namespace at compile * time. */ - int exportLookupEpoch; /* Incremented whenever a command is added to + unsigned int exportLookupEpoch; /* Incremented whenever a command is added to * a namespace, removed from a namespace or * the exports of a namespace are changed. * Allows TIP#112-driven command lists to be @@ -389,27 +442,6 @@ struct NamespacePathEntry { #define TCL_FIND_ONLY_NS 0x1000 /* - * The data cached in an ensemble subcommand's Tcl_Obj rep (reference in - * twoPtrValue.ptr1 field). This structure is not shared between Tcl_Objs - * referring to the same subcommand, even where one is a duplicate of another. - */ - -typedef struct { - Namespace *nsPtr; /* The namespace backing the ensemble which - * this is a subcommand of. */ - int epoch; /* Used to confirm when the data in this - * really structure matches up with the - * ensemble. */ - Tcl_Command token; /* Reference to the comamnd for which this - * structure is a cache of the resolution. */ - char *fullSubcmdName; /* The full (local) name of the subcommand, - * allocated with ckalloc(). */ - Tcl_Obj *realPrefixObj; /* Object containing the prefix words of the - * command that implements this ensemble - * subcommand. */ -} EnsembleCmdRep; - -/* * The client data for an ensemble command. This consists of the table of * commands that are actually exported by the namespace, and an epoch counter * that, combined with the exportLookupEpoch field of the namespace structure, @@ -418,13 +450,13 @@ typedef struct { */ typedef struct EnsembleConfig { - Namespace *nsPtr; /* The namspace backing this ensemble up. */ + Namespace *nsPtr; /* The namespace backing this ensemble up. */ Tcl_Command token; /* The token for the command that provides * ensemble support for the namespace, or NULL * if the command has been deleted (or never * existed; the global namespace never has an * ensemble command.) */ - int epoch; /* The epoch at which this ensemble's table of + unsigned int epoch; /* The epoch at which this ensemble's table of * exported commands is valid. */ char **subcommandArrayPtr; /* Array of ensemble subcommand names. At all * consistent points, this will have the same @@ -537,7 +569,7 @@ typedef struct CommandTrace { struct CommandTrace *nextPtr; /* Next in list of traces associated with a * particular command. */ - int refCount; /* Used to ensure this structure is not + size_t refCount; /* Used to ensure this structure is not * deleted too early. Keeps track of how many * pieces of code have a pointer to this * structure. */ @@ -610,7 +642,7 @@ typedef struct Var { typedef struct VarInHash { Var var; - int refCount; /* Counts number of active uses of this + unsigned int refCount; /* Counts number of active uses of this * variable: 1 for the entry in the hash * table, 1 for each additional variable whose * linkPtr points here, 1 for each nested @@ -942,7 +974,7 @@ typedef struct CompiledLocal { typedef struct Proc { struct Interp *iPtr; /* Interpreter for which this command is * defined. */ - int refCount; /* Reference count: 1 if still present in + unsigned int refCount; /* Reference count: 1 if still present in * command table plus 1 for each call to the * procedure that is currently active. This * structure can be freed when refCount @@ -1059,7 +1091,7 @@ typedef struct AssocData { */ typedef struct LocalCache { - int refCount; + unsigned int refCount; int numVars; Tcl_Obj *varName0; } LocalCache; @@ -1138,6 +1170,10 @@ typedef struct CallFrame { * field contains an Object reference that has * been confirmed to refer to a class. Part of * TIP#257. */ +#define FRAME_IS_PRIVATE_DEFINE 0x10 + /* Marks this frame as being used for private + * declarations with [oo::define]. Usually + * OR'd with FRAME_IS_OO_DEFINE. TIP#500. */ /* * TIP #280 @@ -1177,25 +1213,25 @@ typedef struct CmdFrame { * * Field TEBC EvalEx * ======= ==== ====== - * level yes yes + * level yes yes * type BC/PREBC SRC/EVAL - * line0 yes yes - * framePtr yes yes + * line0 yes yes + * framePtr yes yes * ======= ==== ====== * * ======= ==== ========= union data - * line1 - yes - * line3 - yes - * path - yes + * line1 - yes + * line3 - yes + * path - yes * ------- ---- ------ - * codePtr yes - - * pc yes - + * codePtr yes - + * pc yes - * ======= ==== ====== * * ======= ==== ========= union cmd - * str.cmd yes yes - * str.len yes yes - * ------- ---- ------ + * str.cmd yes yes + * str.len yes yes + * ------- ---- ------ */ union { @@ -1208,10 +1244,9 @@ typedef struct CmdFrame { const char *pc; /* ... and instruction pointer. */ } tebc; } data; + Tcl_Obj *cmdObj; const char *cmd; /* The executed command, if possible... */ int len; /* ... and its length. */ - int numLevels; /* Value of interp's numLevels when the frame - * was pushed. */ const struct CFWordBC *litarg; /* Link to set of literal arguments which have * ben pushed on the lineLABCPtr stack by @@ -1222,7 +1257,7 @@ typedef struct CmdFrame { typedef struct CFWord { CmdFrame *framePtr; /* CmdFrame to access. */ int word; /* Index of the word in the command. */ - int refCount; /* Number of times the word is on the + unsigned int refCount; /* Number of times the word is on the * stack. */ } CFWord; @@ -1350,7 +1385,7 @@ MODULE_SCOPE void TclThreadDataKeySet(Tcl_ThreadDataKey *keyPtr, */ #define TCL_TSD_INIT(keyPtr) \ - (ThreadSpecificData *)Tcl_GetThreadData((keyPtr), sizeof(ThreadSpecificData)) + Tcl_GetThreadData((keyPtr), sizeof(ThreadSpecificData)) /* *---------------------------------------------------------------- @@ -1485,11 +1520,11 @@ typedef struct LiteralEntry { * NULL if end of chain. */ Tcl_Obj *objPtr; /* Points to Tcl object that holds the * literal's bytes and length. */ - int refCount; /* If in an interpreter's global literal + size_t refCount; /* If in an interpreter's global literal * table, the number of ByteCode structures * that share the literal object; the literal * entry can be freed when refCount drops to - * 0. If in a local literal table, -1. */ + * 0. If in a local literal table, (size_t)-1. */ Namespace *nsPtr; /* Namespace in which this literal is used. We * try to avoid sharing literal non-FQ command * names among different namespaces to reduce @@ -1509,7 +1544,7 @@ typedef struct LiteralTable { * table. */ int rebuildSize; /* Enlarge table when numEntries gets to be * this large. */ - int mask; /* Mask value used in hashing function. */ + unsigned int mask; /* Mask value used in hashing function. */ } LiteralTable; /* @@ -1627,12 +1662,12 @@ typedef struct Command { * recreated). */ Namespace *nsPtr; /* Points to the namespace containing this * command. */ - int refCount; /* 1 if in command hashtable plus 1 for each + unsigned int refCount; /* 1 if in command hashtable plus 1 for each * reference from a CmdName Tcl object * representing a command's name in a ByteCode * instruction sequence. This structure can be * freed when refCount becomes zero. */ - int cmdEpoch; /* Incremented to invalidate any references + unsigned int cmdEpoch; /* Incremented to invalidate any references * that point to this command when it is * renamed, deleted, hidden, or exposed. */ CompileProc *compileProc; /* Procedure called to compile command. NULL @@ -1683,10 +1718,13 @@ typedef struct Command { * (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 -#define CMD_COMPILES_EXPANDED 0x8 +#define CMD_IS_DELETED 0x01 +#define CMD_TRACE_ACTIVE 0x02 +#define CMD_HAS_EXEC_TRACES 0x04 +#define CMD_COMPILES_EXPANDED 0x08 +#define CMD_REDEF_IN_PROGRESS 0x10 +#define CMD_VIA_RESOLVER 0x20 + /* *---------------------------------------------------------------- @@ -1741,7 +1779,7 @@ enum PkgPreferOptions { * definition there. * Some macros require knowledge of some fields in the struct in order to * avoid hitting the TSD unnecessarily. In order to facilitate this, a pointer - * to the relevant fields is kept in the objCache field in struct Interp. + * to the relevant fields is kept in the allocCache field in struct Interp. *---------------------------------------------------------------- */ @@ -1810,7 +1848,14 @@ typedef struct Interp { ClientData interpInfo; /* Information used by tclInterp.c to keep * track of master/slave interps on a * per-interp basis. */ - Tcl_HashTable unused2; /* No longer used (was mathFuncTable) */ + union { + void (*optimizer)(void *envPtr); + Tcl_HashTable unused2; /* No longer used (was mathFuncTable). The + * unused space in interp was repurposed for + * pluggable bytecode optimizers. The core + * contains one optimizer, which can be + * selectively overridden by extensions. */ + } extra; /* * Information related to procedures and variables. See tclProc.c and @@ -1845,6 +1890,7 @@ typedef struct Interp { * See Tcl_AppendResult code for details. */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 char *appendResult; /* Storage space for results generated by * Tcl_AppendResult. Ckalloc-ed. NULL means * not yet allocated. */ @@ -1852,6 +1898,11 @@ typedef struct Interp { * partialResult. */ int appendUsed; /* Number of non-null bytes currently stored * at partialResult. */ +#else + char *appendResultDontUse; + int appendAvlDontUse; + int appendUsedDontUse; +#endif /* * Information about packages. Used only in tclPkg.c. @@ -1881,7 +1932,7 @@ typedef struct Interp { * compiled by the interpreter. Indexed by the * string representations of literals. Used to * avoid creating duplicate objects. */ - int compileEpoch; /* Holds the current "compilation epoch" for + unsigned int compileEpoch; /* Holds the current "compilation epoch" for * this interpreter. This is incremented to * invalidate existing ByteCodes when, e.g., a * command with a compile procedure is @@ -1913,8 +1964,14 @@ typedef struct Interp { * string. Returned by Tcl_ObjSetVar2 when * variable traces change a variable in a * gross way. */ - char resultSpace[TCL_RESULT_SIZE+1]; +#if TCL_MAJOR_VERSION < 9 +# if !defined(TCL_NO_DEPRECATED) + char resultSpace[TCL_DSTRING_STATIC_SIZE+1]; /* Static space holding small results. */ +# else + char resultSpaceDontUse[TCL_DSTRING_STATIC_SIZE+1]; +# endif +#endif Tcl_Obj *objResultPtr; /* If the last command returned an object * result, this points to it. Should not be * accessed directly; see comment above. */ @@ -2199,8 +2256,10 @@ typedef struct Interp { * other than these should be turned into errors. */ -#define TCL_ALLOW_EXCEPTIONS 4 -#define TCL_EVAL_FILE 2 +#define TCL_ALLOW_EXCEPTIONS 0x04 +#define TCL_EVAL_FILE 0x02 +#define TCL_EVAL_SOURCE_IN_FRAME 0x10 +#define TCL_EVAL_NORESOLVE 0x20 /* * Flag bits for Interp structures: @@ -2222,7 +2281,7 @@ typedef struct Interp { * use the rand() or srand() functions. * SAFE_INTERP: Non zero means that the current interp is a safe * interp (i.e. it has only the safe commands installed, - * less priviledge than a regular interp). + * less privilege than a regular interp). * INTERP_DEBUG_FRAME: Used for switching on various extra interpreter * debug/info mechanisms (e.g. info frame eval/uplevel * tracing) which are performance intensive. @@ -2355,7 +2414,7 @@ typedef enum TclEolTranslation { */ typedef struct List { - int refCount; + unsigned int refCount; int maxElemCount; /* Total number of element array slots. */ int elemCount; /* Current number of list elements. */ int canonicalFlag; /* Set if the string representation was @@ -2363,7 +2422,7 @@ typedef struct List { * be ignored if there is no string rep at * all.*/ Tcl_Obj *elements; /* First list element; the struct is grown to - * accomodate all elements. */ + * accommodate all elements. */ } List; #define LIST_MAX \ @@ -2416,32 +2475,60 @@ typedef struct List { #define TCL_EACH_COLLECT 1 /* Collect iteration result like [lmap] */ /* - * Macros providing a faster path to integers: Tcl_GetLongFromObj everywhere, - * Tcl_GetIntFromObj and TclGetIntForIndex on platforms where longs are ints. + * Macros providing a faster path to booleans and integers: + * Tcl_GetBooleanFromObj, Tcl_GetLongFromObj, Tcl_GetIntFromObj + * and TclGetIntForIndex. * * WARNING: these macros eval their args more than once. */ +#define TclGetBooleanFromObj(interp, objPtr, boolPtr) \ + (((objPtr)->typePtr == &tclIntType) \ + ? (*(boolPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \ + : ((objPtr)->typePtr == &tclBooleanType) \ + ? (*(boolPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \ + : Tcl_GetBooleanFromObj((interp), (objPtr), (boolPtr))) + +#ifdef TCL_WIDE_INT_IS_LONG #define TclGetLongFromObj(interp, objPtr, longPtr) \ (((objPtr)->typePtr == &tclIntType) \ - ? ((*(longPtr) = (objPtr)->internalRep.longValue), TCL_OK) \ + ? ((*(longPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \ + : Tcl_GetLongFromObj((interp), (objPtr), (longPtr))) +#else +#define TclGetLongFromObj(interp, objPtr, longPtr) \ + (((objPtr)->typePtr == &tclIntType \ + && (objPtr)->internalRep.wideValue >= -(Tcl_WideInt)(ULONG_MAX) \ + && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(ULONG_MAX)) \ + ? ((*(longPtr) = (long)(objPtr)->internalRep.wideValue), TCL_OK) \ : Tcl_GetLongFromObj((interp), (objPtr), (longPtr))) +#endif -#if (LONG_MAX == INT_MAX) #define TclGetIntFromObj(interp, objPtr, intPtr) \ - (((objPtr)->typePtr == &tclIntType) \ - ? ((*(intPtr) = (objPtr)->internalRep.longValue), TCL_OK) \ + (((objPtr)->typePtr == &tclIntType \ + && (objPtr)->internalRep.wideValue >= -(Tcl_WideInt)(UINT_MAX) \ + && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(UINT_MAX)) \ + ? ((*(intPtr) = (int)(objPtr)->internalRep.wideValue), TCL_OK) \ : Tcl_GetIntFromObj((interp), (objPtr), (intPtr))) #define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \ - (((objPtr)->typePtr == &tclIntType) \ - ? ((*(idxPtr) = (objPtr)->internalRep.longValue), TCL_OK) \ + (((objPtr)->typePtr == &tclIntType \ + && (objPtr)->internalRep.wideValue >= INT_MIN \ + && (objPtr)->internalRep.wideValue <= INT_MAX) \ + ? ((*(idxPtr) = (int)(objPtr)->internalRep.wideValue), TCL_OK) \ : TclGetIntForIndex((interp), (objPtr), (endValue), (idxPtr))) -#else -#define TclGetIntFromObj(interp, objPtr, intPtr) \ - Tcl_GetIntFromObj((interp), (objPtr), (intPtr)) -#define TclGetIntForIndexM(interp, objPtr, ignore, idxPtr) \ - TclGetIntForIndex(interp, objPtr, ignore, idxPtr) -#endif + +/* + * Macro used to save a function call for common uses of + * Tcl_GetWideIntFromObj(). The ANSI C "prototype" is: + * + * MODULE_SCOPE int TclGetWideIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, + * Tcl_WideInt *wideIntPtr); + */ + +#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ + (((objPtr)->typePtr == &tclIntType) \ + ? (*(wideIntPtr) = (Tcl_WideInt) \ + ((objPtr)->internalRep.wideValue), TCL_OK) : \ + Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) /* * Flag values for TclTraceDictPath(). @@ -2453,13 +2540,13 @@ typedef struct List { * tip of the path, so duplication of shared objects should be done along the * way. * - * DICT_PATH_EXISTS indicates that we are performing an existance test and a + * DICT_PATH_EXISTS indicates that we are performing an existence test and a * lookup failure should therefore not be an error. If (and only if) this flag * is set, TclTraceDictPath() will return the special value * DICT_PATH_NON_EXISTENT if the path is not traceable. * * DICT_PATH_CREATE (which also requires the DICT_PATH_UPDATE bit to be set) - * indicates that we are to create non-existant dictionaries on the path. + * indicates that we are to create non-existent dictionaries on the path. */ #define DICT_PATH_READ 0 @@ -2507,6 +2594,15 @@ typedef struct TclFileAttrProcs { } TclFileAttrProcs; /* + * Private flag value which controls Tcl_GetIndexFromObj*() routines + * to instruct them not to cache lookups because the table will not + * live long enough to make it worthwhile. Must not clash with public + * flag value TCL_EXACT. + */ + +#define INDEX_TEMP_TABLE 2 + +/* * Opaque handle used in pipeline routines to encapsulate platform-dependent * state. */ @@ -2556,7 +2652,7 @@ typedef Tcl_ObjCmdProc *TclObjCmdProcType; *---------------------------------------------------------------- */ -typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, int *lengthPtr, +typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, unsigned int *lengthPtr, Tcl_Encoding *encodingPtr); /* @@ -2568,9 +2664,9 @@ typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, int *lengthPtr, */ typedef struct ProcessGlobalValue { - int epoch; /* Epoch counter to detect changes in the + unsigned int epoch; /* Epoch counter to detect changes in the * master value. */ - int numBytes; /* Length of the master string. */ + unsigned int numBytes; /* Length of the master string. */ char *value; /* The master string value. */ Tcl_Encoding encoding; /* system encoding when master string was * initialized. */ @@ -2631,6 +2727,8 @@ MODULE_SCOPE char *tclMemDumpFileName; MODULE_SCOPE TclPlatformType tclPlatform; MODULE_SCOPE Tcl_NotifierProcs tclNotifierHooks; +MODULE_SCOPE Tcl_Encoding tclIdentityEncoding; + /* * TIP #233 (Virtualized Time) * Data for the time hooks, if any. @@ -2655,11 +2753,7 @@ MODULE_SCOPE const Tcl_ObjType tclListType; MODULE_SCOPE const Tcl_ObjType tclDictType; MODULE_SCOPE const Tcl_ObjType tclProcBodyType; MODULE_SCOPE const Tcl_ObjType tclStringType; -MODULE_SCOPE const Tcl_ObjType tclArraySearchType; MODULE_SCOPE const Tcl_ObjType tclEnsembleCmdType; -#ifndef TCL_WIDE_INT_IS_LONG -MODULE_SCOPE const Tcl_ObjType tclWideIntType; -#endif MODULE_SCOPE const Tcl_ObjType tclRegexpType; MODULE_SCOPE Tcl_ObjType tclCmdNameType; @@ -2692,9 +2786,12 @@ MODULE_SCOPE long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS]; * shared by all new objects allocated by Tcl_NewObj. */ -MODULE_SCOPE char * tclEmptyStringRep; MODULE_SCOPE char tclEmptyString; +enum CheckEmptyStringResult { + TCL_EMPTYSTRING_UNKNOWN = -1, TCL_EMPTYSTRING_NO, TCL_EMPTYSTRING_YES +}; + /* *---------------------------------------------------------------- * Procedures shared among Tcl modules but not used by the outside world, @@ -2710,6 +2807,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRLmapCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRPackageObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSubstObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSwitchObjCmd; @@ -2725,6 +2823,8 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRInvoke; +MODULE_SCOPE Tcl_NRPostProc TclNRReleaseValues; MODULE_SCOPE void TclSetTailcall(Tcl_Interp *interp, Tcl_Obj *tailcallPtr); MODULE_SCOPE void TclPushTailcallPoint(Tcl_Interp *interp); @@ -2821,20 +2921,24 @@ MODULE_SCOPE void TclArgumentBCRelease(Tcl_Interp *interp, CmdFrame *cfPtr); MODULE_SCOPE void TclArgumentGet(Tcl_Interp *interp, Tcl_Obj *obj, CmdFrame **cfPtrPtr, int *wordPtr); -MODULE_SCOPE int TclArraySet(Tcl_Interp *interp, - Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj); MODULE_SCOPE double TclBignumToDouble(const mp_int *bignum); MODULE_SCOPE int TclByteArrayMatch(const unsigned char *string, int strLen, const unsigned char *pattern, int ptnLen, int flags); MODULE_SCOPE double TclCeil(const mp_int *a); +MODULE_SCOPE void TclChannelPreserve(Tcl_Channel chan); +MODULE_SCOPE void TclChannelRelease(Tcl_Channel chan); +MODULE_SCOPE int TclCheckArrayTraces(Tcl_Interp *interp, Var *varPtr, + Var *arrayPtr, Tcl_Obj *name, int index); MODULE_SCOPE int TclCheckBadOctal(Tcl_Interp *interp, const char *value); +MODULE_SCOPE int TclCheckEmptyString(Tcl_Obj *objPtr); MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp, Tcl_Channel chan); MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd; -MODULE_SCOPE int TclClearRootEnsemble(ClientData data[], - Tcl_Interp *interp, int result); +MODULE_SCOPE Tcl_NRPostProc TclClearRootEnsemble; +MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr, + Tcl_Obj *value2Ptr); MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, int num, int *loc); MODULE_SCOPE void TclContinuationsEnterDerived(Tcl_Obj *objPtr, @@ -2844,8 +2948,19 @@ MODULE_SCOPE void TclContinuationsCopy(Tcl_Obj *objPtr, Tcl_Obj *originObjPtr); MODULE_SCOPE int TclConvertElement(const char *src, int length, char *dst, int flags); +MODULE_SCOPE Tcl_Command TclCreateObjCommandInNs(Tcl_Interp *interp, + const char *cmdName, Tcl_Namespace *nsPtr, + Tcl_ObjCmdProc *proc, ClientData clientData, + Tcl_CmdDeleteProc *deleteProc); +MODULE_SCOPE Tcl_Command TclCreateEnsembleInNs(Tcl_Interp *interp, + const char *name, Tcl_Namespace *nameNamespacePtr, + Tcl_Namespace *ensembleNamespacePtr, int flags); MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr); -/* TIP #280 - Modified token based evulation, with line information. */ +MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp, + const char *dict, int dictLength, + const char **elementPtr, const char **nextPtr, + int *sizePtr, int *literalPtr); +/* TIP #280 - Modified token based evaluation, with line information. */ MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script, int numBytes, int flags, int line, int *clNextOuter, const char *outerScript); @@ -2866,6 +2981,10 @@ MODULE_SCOPE char * TclDStringAppendObj(Tcl_DString *dsPtr, MODULE_SCOPE char * TclDStringAppendDString(Tcl_DString *dsPtr, Tcl_DString *toAppendPtr); MODULE_SCOPE Tcl_Obj * TclDStringToObj(Tcl_DString *dsPtr); +MODULE_SCOPE Tcl_Obj *const *TclFetchEnsembleRoot(Tcl_Interp *interp, + Tcl_Obj *const *objv, int objc, int *objcPtr); +MODULE_SCOPE Tcl_Namespace *TclEnsureNamespace(Tcl_Interp *interp, + Tcl_Namespace *namespacePtr); MODULE_SCOPE void TclFinalizeAllocSubsystem(void); MODULE_SCOPE void TclFinalizeAsync(void); MODULE_SCOPE void TclFinalizeDoubleConversion(void); @@ -2883,13 +3002,20 @@ MODULE_SCOPE void TclFinalizeNotifier(void); MODULE_SCOPE void TclFinalizeObjects(void); MODULE_SCOPE void TclFinalizePreserve(void); MODULE_SCOPE void TclFinalizeSynchronization(void); +MODULE_SCOPE void TclInitThreadAlloc(void); MODULE_SCOPE void TclFinalizeThreadAlloc(void); -MODULE_SCOPE void TclFinalizeThreadData(void); +MODULE_SCOPE void TclFinalizeThreadAllocThread(void); +MODULE_SCOPE void TclFinalizeThreadData(int quick); MODULE_SCOPE void TclFinalizeThreadObjects(void); MODULE_SCOPE double TclFloor(const mp_int *a); MODULE_SCOPE void TclFormatNaN(double value, char *buffer); MODULE_SCOPE int TclFSFileAttrIndex(Tcl_Obj *pathPtr, const char *attributeName, int *indexPtr); +MODULE_SCOPE Tcl_Command TclNRCreateCommandInNs(Tcl_Interp *interp, + const char *cmdName, Tcl_Namespace *nsPtr, + Tcl_ObjCmdProc *proc, Tcl_ObjCmdProc *nreProc, + ClientData clientData, + Tcl_CmdDeleteProc *deleteProc); MODULE_SCOPE int TclNREvalFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *encodingName); MODULE_SCOPE void TclFSUnloadTempFile(Tcl_LoadHandle loadHandle); @@ -2898,7 +3024,8 @@ MODULE_SCOPE Tcl_Obj * TclGetBgErrorHandler(Tcl_Interp *interp); MODULE_SCOPE int TclGetChannelFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Channel *chanPtr, int *modePtr, int flags); -MODULE_SCOPE int TclGetCompletionCodeFromObj(Tcl_Interp *interp, +MODULE_SCOPE CmdFrame * TclGetCmdFrameForProcedure(Proc *procPtr); +MODULE_SCOPE int TclGetCompletionCodeFromObj(Tcl_Interp *interp, Tcl_Obj *value, int *code); MODULE_SCOPE int TclGetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, ClientData *clientDataPtr, @@ -2907,7 +3034,13 @@ MODULE_SCOPE int TclGetOpenModeEx(Tcl_Interp *interp, const char *modeString, int *seekFlagPtr, int *binaryPtr); MODULE_SCOPE Tcl_Obj * TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr); -MODULE_SCOPE const char *TclGetSrcInfoForCmd(Interp *iPtr, int *lenPtr); +MODULE_SCOPE Tcl_Obj * TclGetSourceFromFrame(CmdFrame *cfPtr, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE char * TclGetStringStorage(Tcl_Obj *objPtr, + unsigned int *sizePtr); +MODULE_SCOPE int TclGetLoadedPackagesEx(Tcl_Interp *interp, + const char *targetName, + const char *packageName); MODULE_SCOPE int TclGlob(Tcl_Interp *interp, char *pattern, Tcl_Obj *unquotedPrefix, int globFlags, Tcl_GlobTypeData *types); @@ -2927,6 +3060,9 @@ MODULE_SCOPE int TclInfoLocalsCmd(ClientData dummy, Tcl_Interp *interp, MODULE_SCOPE int TclInfoVarsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE void TclInitAlloc(void); +MODULE_SCOPE void TclInitBignumFromLong(mp_int *, long); +MODULE_SCOPE void TclInitBignumFromWideInt(mp_int *, Tcl_WideInt); +MODULE_SCOPE void TclInitBignumFromWideUInt(mp_int *, Tcl_WideUInt); MODULE_SCOPE void TclInitDbCkalloc(void); MODULE_SCOPE void TclInitDoubleConversion(void); MODULE_SCOPE void TclInitEmbeddedConfigurationInformation( @@ -2939,8 +3075,8 @@ MODULE_SCOPE void TclInitNotifier(void); MODULE_SCOPE void TclInitObjSubsystem(void); MODULE_SCOPE void TclInitSubsystems(void); MODULE_SCOPE int TclInterpReady(Tcl_Interp *interp); -MODULE_SCOPE int TclIsLocalScalar(const char *src, int len); MODULE_SCOPE int TclIsSpaceProc(char byte); +MODULE_SCOPE int TclIsBareword(char byte); MODULE_SCOPE Tcl_Obj * TclJoinPath(int elements, Tcl_Obj * const objv[]); MODULE_SCOPE int TclJoinThread(Tcl_ThreadId id, int *result); MODULE_SCOPE void TclLimitRemoveAllHandlers(Tcl_Interp *interp); @@ -2952,6 +3088,8 @@ MODULE_SCOPE Tcl_Obj * TclLindexFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, MODULE_SCOPE void TclListLines(Tcl_Obj *listObj, int line, int n, int *lines, Tcl_Obj *const *elems); MODULE_SCOPE Tcl_Obj * TclListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr); +MODULE_SCOPE Tcl_Obj * TclListObjRange(Tcl_Obj *listPtr, int fromIdx, + int toIdx); MODULE_SCOPE Tcl_Obj * TclLsetList(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *indexPtr, Tcl_Obj *valuePtr); MODULE_SCOPE Tcl_Obj * TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, @@ -2998,14 +3136,15 @@ MODULE_SCOPE void TclpFinalizeMutex(Tcl_Mutex *mutexPtr); MODULE_SCOPE void TclpFinalizePipes(void); MODULE_SCOPE void TclpFinalizeSockets(void); MODULE_SCOPE int TclCreateSocketAddress(Tcl_Interp *interp, - void **addrlist, const char *host, int port, - int willBind, const char **errorMsgPtr); + struct addrinfo **addrlist, + const char *host, int port, int willBind, + const char **errorMsgPtr); MODULE_SCOPE int TclpThreadCreate(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, ClientData clientData, int stackSize, int flags); MODULE_SCOPE int TclpFindVariable(const char *name, int *lengthPtr); MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr, - int *lengthPtr, Tcl_Encoding *encodingPtr); + unsigned int *lengthPtr, Tcl_Encoding *encodingPtr); MODULE_SCOPE void TclpInitLock(void); MODULE_SCOPE void TclpInitPlatform(void); MODULE_SCOPE void TclpInitUnlock(void); @@ -3033,42 +3172,53 @@ MODULE_SCOPE int TclpObjChdir(Tcl_Obj *pathPtr); MODULE_SCOPE Tcl_Channel TclpOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); +MODULE_SCOPE void TclPkgFileSeen(Tcl_Interp *interp, const char *fileName); +MODULE_SCOPE void *TclInitPkgFiles(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclPathPart(Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_PathPart portion); MODULE_SCOPE char * TclpReadlink(const char *fileName, Tcl_DString *linkPtr); -MODULE_SCOPE void TclpSetInterfaces(void); MODULE_SCOPE void TclpSetVariables(Tcl_Interp *interp); MODULE_SCOPE void * TclThreadStorageKeyGet(Tcl_ThreadDataKey *keyPtr); MODULE_SCOPE void TclThreadStorageKeySet(Tcl_ThreadDataKey *keyPtr, void *data); -MODULE_SCOPE void TclpThreadExit(int status); +MODULE_SCOPE TCL_NORETURN void TclpThreadExit(int status); MODULE_SCOPE void TclRememberCondition(Tcl_Condition *mutex); MODULE_SCOPE void TclRememberJoinableThread(Tcl_ThreadId id); MODULE_SCOPE void TclRememberMutex(Tcl_Mutex *mutex); MODULE_SCOPE void TclRemoveScriptLimitCallbacks(Tcl_Interp *interp); MODULE_SCOPE int TclReToGlob(Tcl_Interp *interp, const char *reStr, - int reStrLen, Tcl_DString *dsPtr, int *flagsPtr); + int reStrLen, Tcl_DString *dsPtr, int *flagsPtr, + int *quantifiersFoundPtr); MODULE_SCOPE int TclScanElement(const char *string, int length, - int *flagPtr); + char *flagPtr); MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp, Tcl_Obj *cmdPrefix); MODULE_SCOPE void TclSetBignumIntRep(Tcl_Obj *objPtr, mp_int *bignumValue); -MODULE_SCOPE int TclSetBooleanFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); +MODULE_SCOPE int TclSetBooleanFromAny(Tcl_Interp *interp, + Tcl_Obj *objPtr); MODULE_SCOPE void TclSetCmdNameObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Command *cmdPtr); MODULE_SCOPE void TclSetDuplicateObj(Tcl_Obj *dupPtr, Tcl_Obj *objPtr); MODULE_SCOPE void TclSetProcessGlobalValue(ProcessGlobalValue *pgvPtr, Tcl_Obj *newValue, Tcl_Encoding encoding); MODULE_SCOPE void TclSignalExitThread(Tcl_ThreadId id, int result); +MODULE_SCOPE void TclSpellFix(Tcl_Interp *interp, + Tcl_Obj *const *objv, int objc, int subIdx, + Tcl_Obj *bad, Tcl_Obj *fix); MODULE_SCOPE void * TclStackRealloc(Tcl_Interp *interp, void *ptr, int numBytes); +typedef int (*memCmpFn_t)(const void*, const void*, size_t); +MODULE_SCOPE int TclStringCmp(Tcl_Obj *value1Ptr, Tcl_Obj *value2Ptr, + int checkEq, int nocase, int reqlength); +MODULE_SCOPE int TclStringCmpOpts(Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[], int *nocase, + int *reqlength); MODULE_SCOPE int TclStringMatch(const char *str, int strLen, const char *pattern, int ptnLen, int flags); MODULE_SCOPE int TclStringMatchObj(Tcl_Obj *stringObj, Tcl_Obj *patternObj, int flags); -MODULE_SCOPE Tcl_Obj * TclStringObjReverse(Tcl_Obj *objPtr); MODULE_SCOPE void TclSubstCompile(Tcl_Interp *interp, const char *bytes, int numBytes, int flags, int line, struct CompileEnv *envPtr); @@ -3080,6 +3230,8 @@ MODULE_SCOPE void TclSubstParse(Tcl_Interp *interp, const char *bytes, MODULE_SCOPE int TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count, int *tokensLeftPtr, int line, int *clNextOuter, const char *outerScript); +MODULE_SCOPE int TclTrim(const char *bytes, int numBytes, + const char *trim, int numTrim, int *trimRight); MODULE_SCOPE int TclTrimLeft(const char *bytes, int numBytes, const char *trim, int numTrim); MODULE_SCOPE int TclTrimRight(const char *bytes, int numBytes, @@ -3088,7 +3240,9 @@ MODULE_SCOPE const char*TclGetCommandTypeName(Tcl_Command command); MODULE_SCOPE void TclRegisterCommandTypeName( Tcl_ObjCmdProc *implementationProc, const char *nameStr); +MODULE_SCOPE int TclUtfCmp(const char *cs, const char *ct); MODULE_SCOPE int TclUtfCasecmp(const char *cs, const char *ct); +MODULE_SCOPE int TclUtfCount(int ch); MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(ClientData clientData); MODULE_SCOPE Tcl_Obj * TclpFilesystemPathType(Tcl_Obj *pathPtr); MODULE_SCOPE int TclpDlopen(Tcl_Interp *interp, Tcl_Obj *pathPtr, @@ -3108,14 +3262,13 @@ MODULE_SCOPE void TclFinalizeThreadStorage(void); MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void); MODULE_SCOPE double TclpWideClicksToNanoseconds(Tcl_WideInt clicks); #endif -MODULE_SCOPE Tcl_Obj * TclDisassembleByteCodeObj(Tcl_Obj *objPtr); MODULE_SCOPE int TclZlibInit(Tcl_Interp *interp); MODULE_SCOPE void * TclpThreadCreateKey(void); MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr); MODULE_SCOPE void TclpThreadSetMasterTSD(void *tsdKeyPtr, void *ptr); MODULE_SCOPE void * TclpThreadGetMasterTSD(void *tsdKeyPtr); - -MODULE_SCOPE void TclErrorStackResetIf(Tcl_Interp *interp, const char *msg, int length); +MODULE_SCOPE void TclErrorStackResetIf(Tcl_Interp *interp, + const char *msg, int length); /* *---------------------------------------------------------------- @@ -3137,9 +3290,11 @@ MODULE_SCOPE Tcl_Command TclInitBinaryCmd(Tcl_Interp *interp); MODULE_SCOPE int Tcl_BreakObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 MODULE_SCOPE int Tcl_CaseObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +#endif MODULE_SCOPE int Tcl_CatchObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -3186,18 +3341,16 @@ MODULE_SCOPE Tcl_Obj * TclDictWithInit(Tcl_Interp *interp, Tcl_Obj *dictPtr, MODULE_SCOPE int Tcl_DisassembleObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); - -/* Assemble command function */ + +/* Assemble command function */ MODULE_SCOPE int Tcl_AssembleObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); + Tcl_Obj *const objv[]); MODULE_SCOPE int TclNRAssembleObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); - -MODULE_SCOPE int Tcl_EncodingObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_Command TclInitEncodingCmd(Tcl_Interp *interp); +MODULE_SCOPE int TclMakeEncodingCommandSafe(Tcl_Interp *interp); MODULE_SCOPE int Tcl_EofObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -3435,6 +3588,15 @@ MODULE_SCOPE int TclCompileBreakCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileCatchCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileClockClicksCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileClockReadingCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileConcatCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileContinueCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); @@ -3534,6 +3696,9 @@ MODULE_SCOPE int TclCompileLassignCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileLindexCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileLinsertCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileListCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); @@ -3558,6 +3723,9 @@ MODULE_SCOPE int TclCompileNamespaceCodeCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileNamespaceCurrentCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileNamespaceOriginCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileNamespaceQualifiersCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); @@ -3573,6 +3741,12 @@ MODULE_SCOPE int TclCompileNamespaceWhichCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileNoOp(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileObjectNextCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileObjectNextToCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileObjectSelfCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); @@ -3588,6 +3762,9 @@ MODULE_SCOPE int TclCompileReturnCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileSetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringCatCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringCmpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); @@ -3600,6 +3777,9 @@ MODULE_SCOPE int TclCompileStringFirstCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileStringIndexCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringIsCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringLastCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); @@ -3615,6 +3795,27 @@ MODULE_SCOPE int TclCompileStringMatchCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileStringRangeCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringReplaceCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringToLowerCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringToTitleCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringToUpperCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringTrimCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringTrimLCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringTrimRCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileSubstCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); @@ -3645,6 +3846,9 @@ MODULE_SCOPE int TclCompileWhileCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileYieldCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileYieldToCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileBasic0ArgCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); @@ -3820,13 +4024,36 @@ MODULE_SCOPE int TclStreqOpCmd(ClientData clientData, MODULE_SCOPE int TclCompileStreqOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); - + MODULE_SCOPE int TclCompileAssembleCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); /* - * Functions defined in generic/tclVar.c and currenttly exported only for use + * Routines that provide the [string] ensemble functionality. Possible + * candidates for public interface. + */ + +MODULE_SCOPE Tcl_Obj * TclStringCat(Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[], int flags); +MODULE_SCOPE int TclStringFirst(Tcl_Obj *needle, Tcl_Obj *haystack, + int start); +MODULE_SCOPE int TclStringLast(Tcl_Obj *needle, Tcl_Obj *haystack, + int last); +MODULE_SCOPE Tcl_Obj * TclStringRepeat(Tcl_Interp *interp, Tcl_Obj *objPtr, + int count, int flags); +MODULE_SCOPE Tcl_Obj * TclStringReplace(Tcl_Interp *interp, Tcl_Obj *objPtr, + int first, int count, Tcl_Obj *insertPtr, + int flags); +MODULE_SCOPE Tcl_Obj * TclStringReverse(Tcl_Obj *objPtr, int flags); + +/* Flag values for the [string] ensemble functions. */ + +#define TCL_STRING_MATCH_NOCASE TCL_MATCH_NOCASE /* (1<<0) in tcl.h */ +#define TCL_STRING_IN_PLACE (1<<1) + +/* + * Functions defined in generic/tclVar.c and currently exported only for use * by the bytecode compiler and engine. Some of these could later be placed in * the public interface. */ @@ -3840,24 +4067,27 @@ MODULE_SCOPE Var * TclLookupArrayElement(Tcl_Interp *interp, const int flags, const char *msg, const int createPart1, const int createPart2, Var *arrayPtr, int index); -MODULE_SCOPE Tcl_Obj * TclPtrGetVar(Tcl_Interp *interp, +MODULE_SCOPE Tcl_Obj * TclPtrGetVarIdx(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags, int index); -MODULE_SCOPE Tcl_Obj * TclPtrSetVar(Tcl_Interp *interp, +MODULE_SCOPE Tcl_Obj * TclPtrSetVarIdx(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, const int flags, int index); -MODULE_SCOPE Tcl_Obj * TclPtrIncrObjVar(Tcl_Interp *interp, +MODULE_SCOPE Tcl_Obj * TclPtrIncrObjVarIdx(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, const int flags, int index); -MODULE_SCOPE int TclPtrObjMakeUpvar(Tcl_Interp *interp, Var *otherPtr, - Tcl_Obj *myNamePtr, int myFlags, int index); -MODULE_SCOPE int TclPtrUnsetVar(Tcl_Interp *interp, Var *varPtr, +MODULE_SCOPE int TclPtrObjMakeUpvarIdx(Tcl_Interp *interp, + Var *otherPtr, Tcl_Obj *myNamePtr, int myFlags, + int index); +MODULE_SCOPE int TclPtrUnsetVarIdx(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags, int index); MODULE_SCOPE void TclInvalidateNsPath(Namespace *nsPtr); +MODULE_SCOPE void TclFindArrayPtrElements(Var *arrayPtr, + Tcl_HashTable *tablePtr); /* * The new extended interface to the variable traces. @@ -3873,7 +4103,7 @@ MODULE_SCOPE int TclObjCallVarTraces(Interp *iPtr, Var *arrayPtr, MODULE_SCOPE int TclCompareObjKeys(void *keyPtr, Tcl_HashEntry *hPtr); MODULE_SCOPE void TclFreeObjEntry(Tcl_HashEntry *hPtr); -MODULE_SCOPE unsigned TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr); +MODULE_SCOPE TCL_HASH_TYPE TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr); MODULE_SCOPE int TclFullFinalizationRequested(void); @@ -3887,6 +4117,46 @@ MODULE_SCOPE Tcl_ObjCmdProc TclSlaveObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclInvokeImportedCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOOPublicObjectCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOOPrivateObjectCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOOMyClassObjCmd; + +/* + * TIP #462. + */ + +/* + * The following enum values give the status of a spawned process. + */ + +typedef enum TclProcessWaitStatus { + TCL_PROCESS_ERROR = -1, /* Error waiting for process to exit */ + TCL_PROCESS_UNCHANGED = 0, /* No change since the last call. */ + TCL_PROCESS_EXITED = 1, /* Process has exited. */ + TCL_PROCESS_SIGNALED = 2, /* Child killed because of a signal. */ + TCL_PROCESS_STOPPED = 3, /* Child suspended because of a signal. */ + TCL_PROCESS_UNKNOWN_STATUS = 4 + /* Child wait status didn't make sense. */ +} TclProcessWaitStatus; + +MODULE_SCOPE Tcl_Command TclInitProcessCmd(Tcl_Interp *interp); +MODULE_SCOPE void TclProcessCreated(Tcl_Pid pid); +MODULE_SCOPE TclProcessWaitStatus TclProcessWait(Tcl_Pid pid, int options, + int *codePtr, Tcl_Obj **msgObjPtr, + Tcl_Obj **errorObjPtr); + +/* + * Utility routines for encoding index values as integers. Used by both + * some of the command compilers and by [lsort] and [lsearch]. + */ + +MODULE_SCOPE int TclIndexEncode(Tcl_Interp *interp, Tcl_Obj *objPtr, + int before, int after, int *indexPtr); +MODULE_SCOPE int TclIndexDecode(int encoded, int endValue); + +/* Constants used in index value encoding routines. */ +#define TCL_INDEX_END (-2) +#define TCL_INDEX_BEFORE (-1) +#define TCL_INDEX_START (0) +#define TCL_INDEX_AFTER (INT_MAX) /* *---------------------------------------------------------------- @@ -3946,7 +4216,7 @@ typedef const char *TclDTraceStr; TclIncrObjsAllocated(); \ TclAllocObjStorage(objPtr); \ (objPtr)->refCount = 0; \ - (objPtr)->bytes = tclEmptyStringRep; \ + (objPtr)->bytes = &tclEmptyString; \ (objPtr)->length = 0; \ (objPtr)->typePtr = NULL; \ TCL_DTRACE_OBJ_CREATE(objPtr) @@ -3959,12 +4229,12 @@ typedef const char *TclDTraceStr; */ # define TclDecrRefCount(objPtr) \ - if (--(objPtr)->refCount > 0) ; else { \ + if ((objPtr)->refCount-- > 1) ; else { \ if (!(objPtr)->typePtr || !(objPtr)->typePtr->freeIntRepProc) { \ TCL_DTRACE_OBJ_FREE(objPtr); \ if ((objPtr)->bytes \ - && ((objPtr)->bytes != tclEmptyStringRep)) { \ - ckfree((char *) (objPtr)->bytes); \ + && ((objPtr)->bytes != &tclEmptyString)) { \ + ckfree((objPtr)->bytes); \ } \ (objPtr)->length = -1; \ TclFreeObjStorage(objPtr); \ @@ -3974,6 +4244,10 @@ typedef const char *TclDTraceStr; } \ } +#if TCL_THREADS && !defined(USE_THREAD_ALLOC) +# define USE_THREAD_ALLOC 1 +#endif + #if defined(PURIFY) /* @@ -3987,11 +4261,11 @@ typedef const char *TclDTraceStr; (objPtr) = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj)) # define TclFreeObjStorageEx(interp, objPtr) \ - ckfree((char *) (objPtr)) + ckfree(objPtr) #undef USE_THREAD_ALLOC #undef USE_TCLALLOC -#elif defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) +#elif TCL_THREADS && defined(USE_THREAD_ALLOC) /* * The TCL_THREADS mode is like the regular mode but allocates Tcl_Obj's from @@ -4005,6 +4279,7 @@ MODULE_SCOPE void TclFreeAllocCache(void *); MODULE_SCOPE void * TclpGetAllocCache(void); MODULE_SCOPE void TclpSetAllocCache(void *); MODULE_SCOPE void TclpFreeAllocMutex(Tcl_Mutex *mutex); +MODULE_SCOPE void TclpInitAllocCache(void); MODULE_SCOPE void TclpFreeAllocCache(void *); /* @@ -4036,7 +4311,8 @@ MODULE_SCOPE void TclpFreeAllocCache(void *); AllocCache *cachePtr; \ if (((interp) == NULL) || \ ((cachePtr = ((Interp *)(interp))->allocCache), \ - (cachePtr->numObjects >= ALLOC_NOBJHIGH))) { \ + ((cachePtr->numObjects == 0) || \ + (cachePtr->numObjects >= ALLOC_NOBJHIGH)))) { \ TclThreadFreeObj(objPtr); \ } else { \ (objPtr)->internalRep.twoPtrValue.ptr1 = cachePtr->firstObjPtr; \ @@ -4054,7 +4330,7 @@ MODULE_SCOPE void TclpFreeAllocCache(void *); # define USE_TCLALLOC 0 #endif -#ifdef TCL_THREADS +#if TCL_THREADS /* declared in tclObj.c */ MODULE_SCOPE Tcl_Mutex tclObjMutex; #endif @@ -4122,7 +4398,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, #define TclInitStringRep(objPtr, bytePtr, len) \ if ((len) == 0) { \ - (objPtr)->bytes = tclEmptyStringRep; \ + (objPtr)->bytes = &tclEmptyString; \ (objPtr)->length = 0; \ } else { \ (objPtr)->bytes = (char *) ckalloc((unsigned) ((len) + 1)); \ @@ -4144,7 +4420,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, */ #define TclGetString(objPtr) \ - ((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString((objPtr))) + ((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString(objPtr)) #define TclGetStringFromObj(objPtr, lenPtr) \ ((objPtr)->bytes \ @@ -4179,11 +4455,11 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, */ #define TclInvalidateStringRep(objPtr) \ - if (objPtr->bytes != NULL) { \ - if (objPtr->bytes != tclEmptyStringRep) { \ - ckfree((char *) objPtr->bytes); \ + if ((objPtr)->bytes != NULL) { \ + if ((objPtr)->bytes != &tclEmptyString) { \ + ckfree((objPtr)->bytes); \ } \ - objPtr->bytes = NULL; \ + (objPtr)->bytes = NULL; \ } /* @@ -4218,13 +4494,13 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, #define TCL_MAX_TOKENS (int)(UINT_MAX / sizeof(Tcl_Token)) #define TclGrowTokenArray(tokenPtr, used, available, append, staticPtr) \ do { \ - int needed = (used) + (append); \ - if (needed > TCL_MAX_TOKENS) { \ + int _needed = (used) + (append); \ + if (_needed > TCL_MAX_TOKENS) { \ Tcl_Panic("max # of tokens for a Tcl parse (%d) exceeded", \ TCL_MAX_TOKENS); \ } \ - if (needed > (available)) { \ - int allocated = 2 * needed; \ + if (_needed > (available)) { \ + int allocated = 2 * _needed; \ Tcl_Token *oldPtr = (tokenPtr); \ Tcl_Token *newPtr; \ if (oldPtr == (staticPtr)) { \ @@ -4236,7 +4512,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, newPtr = (Tcl_Token *) attemptckrealloc((char *) oldPtr, \ (unsigned int) (allocated * sizeof(Tcl_Token))); \ if (newPtr == NULL) { \ - allocated = needed + (append) + TCL_MIN_TOKEN_GROWTH; \ + allocated = _needed + (append) + TCL_MIN_TOKEN_GROWTH; \ if (allocated > TCL_MAX_TOKENS) { \ allocated = TCL_MAX_TOKENS; \ } \ @@ -4270,8 +4546,8 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, */ #define TclUtfToUniChar(str, chPtr) \ - ((((unsigned char) *(str)) < 0xC0) ? \ - ((*(chPtr) = (Tcl_UniChar) *(str)), 1) \ + ((((unsigned char) *(str)) < 0x80) ? \ + ((*(chPtr) = (unsigned char) *(str)), 1) \ : Tcl_UtfToUniChar(str, chPtr)) /* @@ -4288,14 +4564,14 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, #define TclNumUtfChars(numChars, bytes, numBytes) \ do { \ - int count, i = (numBytes); \ - unsigned char *str = (unsigned char *) (bytes); \ - while (i && (*str < 0xC0)) { i--; str++; } \ - count = (numBytes) - i; \ - if (i) { \ - count += Tcl_NumUtfChars((bytes) + count, i); \ + int _count, _i = (numBytes); \ + unsigned char *_str = (unsigned char *) (bytes); \ + while (_i && (*_str < 0xC0)) { _i--; _str++; } \ + _count = (numBytes) - _i; \ + if (_i) { \ + _count += Tcl_NumUtfChars((bytes) + _count, _i); \ } \ - (numChars) = count; \ + (numChars) = _count; \ } while (0); /* @@ -4313,8 +4589,10 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, *---------------------------------------------------------------- */ -#define TclIsPureByteArray(objPtr) \ - (((objPtr)->typePtr==&tclByteArrayType) && ((objPtr)->bytes==NULL)) +MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr); +#define TclIsPureDict(objPtr) \ + (((objPtr)->bytes==NULL) && ((objPtr)->typePtr==&tclDictType)) + /* *---------------------------------------------------------------- @@ -4336,7 +4614,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, /* *---------------------------------------------------------------- - * Macro used by the Tcl core to increment a namespace's export export epoch + * Macro used by the Tcl core to increment a namespace's export epoch * counter. The ANSI C "prototype" for this macro is: * * MODULE_SCOPE void TclInvalidateNsCmdLookup(Namespace *nsPtr); @@ -4354,17 +4632,12 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, /* *---------------------------------------------------------------------- * - * Core procedures added to libtommath for bignum manipulation. + * Core procedure added to libtommath for bignum manipulation. * *---------------------------------------------------------------------- */ MODULE_SCOPE Tcl_PackageInitProc TclTommath_Init; -MODULE_SCOPE void TclBNInitBignumFromLong(mp_int *bignum, long initVal); -MODULE_SCOPE void TclBNInitBignumFromWideInt(mp_int *bignum, - Tcl_WideInt initVal); -MODULE_SCOPE void TclBNInitBignumFromWideUInt(mp_int *bignum, - Tcl_WideUInt initVal); /* *---------------------------------------------------------------------- @@ -4401,45 +4674,19 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; * core. They should only be called on unshared objects. The ANSI C * "prototypes" for these macros are: * - * MODULE_SCOPE void TclSetIntObj(Tcl_Obj *objPtr, int intValue); - * MODULE_SCOPE void TclSetLongObj(Tcl_Obj *objPtr, long longValue); - * MODULE_SCOPE void TclSetBooleanObj(Tcl_Obj *objPtr, long boolValue); - * MODULE_SCOPE void TclSetWideIntObj(Tcl_Obj *objPtr, Tcl_WideInt w); + * MODULE_SCOPE void TclSetIntObj(Tcl_Obj *objPtr, Tcl_WideInt w); * MODULE_SCOPE void TclSetDoubleObj(Tcl_Obj *objPtr, double d); *---------------------------------------------------------------- */ -#define TclSetLongObj(objPtr, i) \ +#define TclSetIntObj(objPtr, i) \ do { \ TclInvalidateStringRep(objPtr); \ TclFreeIntRep(objPtr); \ - (objPtr)->internalRep.longValue = (long)(i); \ + (objPtr)->internalRep.wideValue = (Tcl_WideInt)(i); \ (objPtr)->typePtr = &tclIntType; \ } while (0) -#define TclSetIntObj(objPtr, l) \ - TclSetLongObj(objPtr, l) - -/* - * NOTE: There is to be no such thing as a "pure" boolean. Boolean values set - * programmatically go straight to being "int" Tcl_Obj's, with value 0 or 1. - * The only "boolean" Tcl_Obj's shall be those holding the cached boolean - * value of strings like: "yes", "no", "true", "false", "on", "off". - */ - -#define TclSetBooleanObj(objPtr, b) \ - TclSetLongObj(objPtr, (b)!=0); - -#ifndef TCL_WIDE_INT_IS_LONG -#define TclSetWideIntObj(objPtr, w) \ - do { \ - TclInvalidateStringRep(objPtr); \ - TclFreeIntRep(objPtr); \ - (objPtr)->internalRep.wideValue = (Tcl_WideInt)(w); \ - (objPtr)->typePtr = &tclWideIntType; \ - } while (0) -#endif - #define TclSetDoubleObj(objPtr, d) \ do { \ TclInvalidateStringRep(objPtr); \ @@ -4454,39 +4701,26 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; * types, avoiding the corresponding function calls in time critical parts of * the core. The ANSI C "prototypes" for these macros are: * - * MODULE_SCOPE void TclNewIntObj(Tcl_Obj *objPtr, int i); - * MODULE_SCOPE void TclNewLongObj(Tcl_Obj *objPtr, long l); - * MODULE_SCOPE void TclNewBooleanObj(Tcl_Obj *objPtr, int b); - * MODULE_SCOPE void TclNewWideObj(Tcl_Obj *objPtr, Tcl_WideInt w); + * MODULE_SCOPE void TclNewIntObj(Tcl_Obj *objPtr, Tcl_WideInt w); * MODULE_SCOPE void TclNewDoubleObj(Tcl_Obj *objPtr, double d); - * MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, char *s, int len); - * MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, char*sLiteral); + * MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, const char *s, int len); + * MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, const char *sLiteral); * *---------------------------------------------------------------- */ #ifndef TCL_MEM_DEBUG -#define TclNewLongObj(objPtr, i) \ +#define TclNewIntObj(objPtr, i) \ do { \ TclIncrObjsAllocated(); \ TclAllocObjStorage(objPtr); \ (objPtr)->refCount = 0; \ (objPtr)->bytes = NULL; \ - (objPtr)->internalRep.longValue = (long)(i); \ + (objPtr)->internalRep.wideValue = (Tcl_WideInt)(i); \ (objPtr)->typePtr = &tclIntType; \ TCL_DTRACE_OBJ_CREATE(objPtr); \ } while (0) -#define TclNewIntObj(objPtr, l) \ - TclNewLongObj(objPtr, l) - -/* - * NOTE: There is to be no such thing as a "pure" boolean. - * See comment above TclSetBooleanObj macro above. - */ -#define TclNewBooleanObj(objPtr, b) \ - TclNewLongObj((objPtr), (b)!=0) - #define TclNewDoubleObj(objPtr, d) \ do { \ TclIncrObjsAllocated(); \ @@ -4509,14 +4743,8 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; } while (0) #else /* TCL_MEM_DEBUG */ -#define TclNewIntObj(objPtr, i) \ - (objPtr) = Tcl_NewIntObj(i) - -#define TclNewLongObj(objPtr, l) \ - (objPtr) = Tcl_NewLongObj(l) - -#define TclNewBooleanObj(objPtr, b) \ - (objPtr) = Tcl_NewBooleanObj(b) +#define TclNewIntObj(objPtr, w) \ + (objPtr) = Tcl_NewWideIntObj(w) #define TclNewDoubleObj(objPtr, d) \ (objPtr) = Tcl_NewDoubleObj(d) @@ -4598,8 +4826,8 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; */ #define TclCleanupCommandMacro(cmdPtr) \ - if (--(cmdPtr)->refCount <= 0) { \ - ckfree((char *) (cmdPtr));\ + if ((cmdPtr)->refCount-- <= 1) { \ + ckfree(cmdPtr);\ } /* @@ -4659,11 +4887,11 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; #ifndef TCL_MEM_DEBUG #define TclSmallAllocEx(interp, nbytes, memPtr) \ do { \ - Tcl_Obj *objPtr; \ + Tcl_Obj *_objPtr; \ TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \ TclIncrObjsAllocated(); \ - TclAllocObjStorageEx((interp), (objPtr)); \ - memPtr = (ClientData) (objPtr); \ + TclAllocObjStorageEx((interp), (_objPtr)); \ + memPtr = (ClientData) (_objPtr); \ } while (0) #define TclSmallFreeEx(interp, memPtr) \ @@ -4675,19 +4903,19 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; #else /* TCL_MEM_DEBUG */ #define TclSmallAllocEx(interp, nbytes, memPtr) \ do { \ - Tcl_Obj *objPtr; \ + Tcl_Obj *_objPtr; \ TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \ - TclNewObj(objPtr); \ - memPtr = (ClientData) objPtr; \ + TclNewObj(_objPtr); \ + memPtr = (ClientData) _objPtr; \ } while (0) #define TclSmallFreeEx(interp, memPtr) \ do { \ - Tcl_Obj *objPtr = (Tcl_Obj *) memPtr; \ - objPtr->bytes = NULL; \ - objPtr->typePtr = NULL; \ - objPtr->refCount = 1; \ - TclDecrRefCount(objPtr); \ + Tcl_Obj *_objPtr = (Tcl_Obj *) memPtr; \ + _objPtr->bytes = NULL; \ + _objPtr->typePtr = NULL; \ + _objPtr->refCount = 1; \ + TclDecrRefCount(_objPtr); \ } while (0) #endif /* TCL_MEM_DEBUG */ @@ -4715,7 +4943,9 @@ void Tcl_Panic(const char *, ...) __attribute__((analyzer_noreturn)); */ #define NRE_USE_SMALL_ALLOC 1 /* Only turn off for debugging purposes. */ -#define NRE_ENABLE_ASSERTS 1 +#ifndef NRE_ENABLE_ASSERTS +#define NRE_ENABLE_ASSERTS 0 +#endif /* * This is the main data struct for representing NR commands. It is designed @@ -4737,15 +4967,15 @@ typedef struct NRE_callback { #define TclNRAddCallback(interp,postProcPtr,data0,data1,data2,data3) \ do { \ - NRE_callback *callbackPtr; \ - TCLNR_ALLOC((interp), (callbackPtr)); \ - callbackPtr->procPtr = (postProcPtr); \ - callbackPtr->data[0] = (ClientData)(data0); \ - callbackPtr->data[1] = (ClientData)(data1); \ - callbackPtr->data[2] = (ClientData)(data2); \ - callbackPtr->data[3] = (ClientData)(data3); \ - callbackPtr->nextPtr = TOP_CB(interp); \ - TOP_CB(interp) = callbackPtr; \ + NRE_callback *_callbackPtr; \ + TCLNR_ALLOC((interp), (_callbackPtr)); \ + _callbackPtr->procPtr = (postProcPtr); \ + _callbackPtr->data[0] = (ClientData)(data0); \ + _callbackPtr->data[1] = (ClientData)(data1); \ + _callbackPtr->data[2] = (ClientData)(data2); \ + _callbackPtr->data[3] = (ClientData)(data3); \ + _callbackPtr->nextPtr = TOP_CB(interp); \ + TOP_CB(interp) = _callbackPtr; \ } while (0) #if NRE_USE_SMALL_ALLOC @@ -4755,7 +4985,7 @@ typedef struct NRE_callback { #else #define TCLNR_ALLOC(interp, ptr) \ (ptr = ((ClientData) ckalloc(sizeof(NRE_callback)))) -#define TCLNR_FREE(interp, ptr) ckfree((char *) (ptr)) +#define TCLNR_FREE(interp, ptr) ckfree(ptr) #endif #if NRE_ENABLE_ASSERTS diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 533d6f4..03a2ed2 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -28,21 +28,21 @@ # endif #endif -/* [Bug #803489] Tcl_FindNamespace problem in the Stubs table */ -#undef Tcl_CreateNamespace -#undef Tcl_DeleteNamespace -#undef Tcl_AppendExportList -#undef Tcl_Export -#undef Tcl_Import -#undef Tcl_ForgetImport -#undef Tcl_GetCurrentNamespace -#undef Tcl_GetGlobalNamespace -#undef Tcl_FindNamespace -#undef Tcl_FindCommand -#undef Tcl_GetCommandFromObj -#undef Tcl_GetCommandFullName -#undef Tcl_SetStartupScript -#undef Tcl_GetStartupScript +#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9) +/* Those macro's are especially for Itcl 3.4 compatibility */ +# define tclCreateNamespace tcl_CreateNamespace +# define tclDeleteNamespace tcl_DeleteNamespace +# define tclAppendExportList tcl_AppendExportList +# define tclExport tcl_Export +# define tclImport tcl_Import +# define tclForgetImport tcl_ForgetImport +# define tclGetCurrentNamespace_ tcl_GetCurrentNamespace +# define tclGetGlobalNamespace_ tcl_GetGlobalNamespace +# define tclFindNamespace tcl_FindNamespace +# define tclFindCommand tcl_FindCommand +# define tclGetCommandFromObj tcl_GetCommandFromObj +# define tclGetCommandFullName tcl_GetCommandFullName +#endif /* !defined(TCL_NO_DEPRECATED) */ /* * WARNING: This file is automatically generated by the tools/genStubs.tcl @@ -52,6 +52,10 @@ /* !BEGIN!: Do not edit below this line. */ +#ifdef __cplusplus +extern "C" { +#endif + /* * Exported function declarations: */ @@ -71,7 +75,8 @@ EXTERN void TclCleanupCommand(Command *cmdPtr); EXTERN int TclCopyAndCollapse(int count, const char *src, char *dst); /* 8 */ -EXTERN int TclCopyChannelOld(Tcl_Interp *interp, +TCL_DEPRECATED("") +int TclCopyChannelOld(Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr); /* 9 */ @@ -109,7 +114,7 @@ EXTERN int TclFindElement(Tcl_Interp *interp, /* 23 */ EXTERN Proc * TclFindProc(Interp *iPtr, const char *procName); /* 24 */ -EXTERN int TclFormatInt(char *buffer, long n); +EXTERN int TclFormatInt(char *buffer, Tcl_WideInt n); /* 25 */ EXTERN void TclFreePackageInfo(Interp *iPtr); /* Slot 26 is reserved */ @@ -169,7 +174,7 @@ EXTERN int TclInterpInit(Tcl_Interp *interp); /* 53 */ EXTERN int TclInvokeObjectCommand(ClientData clientData, Tcl_Interp *interp, int argc, - CONST84 char **argv); + const char **argv); /* 54 */ EXTERN int TclInvokeStringCommand(ClientData clientData, Tcl_Interp *interp, int objc, @@ -214,7 +219,8 @@ EXTERN unsigned long TclpGetClicks(void); /* 76 */ EXTERN unsigned long TclpGetSeconds(void); /* 77 */ -EXTERN void TclpGetTime(Tcl_Time *time); +TCL_DEPRECATED("") +void TclpGetTime(Tcl_Time *time); /* Slot 78 is reserved */ /* Slot 79 is reserved */ /* Slot 80 is reserved */ @@ -227,7 +233,8 @@ EXTERN char * TclpRealloc(char *ptr, unsigned int size); /* Slot 86 is reserved */ /* Slot 87 is reserved */ /* 88 */ -EXTERN char * TclPrecTraceProc(ClientData clientData, +TCL_DEPRECATED("") +char * TclPrecTraceProc(ClientData clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); /* 89 */ @@ -263,7 +270,8 @@ EXTERN void TclSetupEnv(Tcl_Interp *interp); EXTERN int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); /* 104 */ -EXTERN int TclSockMinimumBuffersOld(int sock, int size); +TCL_DEPRECATED("") +int TclSockMinimumBuffersOld(int sock, int size); /* Slot 105 is reserved */ /* Slot 106 is reserved */ /* Slot 107 is reserved */ @@ -280,22 +288,22 @@ EXTERN void Tcl_AddInterpResolvers(Tcl_Interp *interp, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 112 */ -EXTERN int Tcl_AppendExportList(Tcl_Interp *interp, +EXTERN int TclAppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 113 */ -EXTERN Tcl_Namespace * Tcl_CreateNamespace(Tcl_Interp *interp, +EXTERN Tcl_Namespace * TclCreateNamespace(Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 114 */ -EXTERN void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr); +EXTERN void TclDeleteNamespace(Tcl_Namespace *nsPtr); /* 115 */ -EXTERN int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr, +EXTERN int TclExport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 116 */ -EXTERN Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name, +EXTERN Tcl_Command TclFindCommand(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 117 */ -EXTERN Tcl_Namespace * Tcl_FindNamespace(Tcl_Interp *interp, +EXTERN Tcl_Namespace * TclFindNamespace(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 118 */ @@ -310,23 +318,23 @@ EXTERN Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 121 */ -EXTERN int Tcl_ForgetImport(Tcl_Interp *interp, +EXTERN int TclForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern); /* 122 */ -EXTERN Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, +EXTERN Tcl_Command TclGetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 123 */ -EXTERN void Tcl_GetCommandFullName(Tcl_Interp *interp, +EXTERN void TclGetCommandFullName(Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 124 */ -EXTERN Tcl_Namespace * Tcl_GetCurrentNamespace(Tcl_Interp *interp); +EXTERN Tcl_Namespace * TclGetCurrentNamespace_(Tcl_Interp *interp); /* 125 */ -EXTERN Tcl_Namespace * Tcl_GetGlobalNamespace(Tcl_Interp *interp); +EXTERN Tcl_Namespace * TclGetGlobalNamespace_(Tcl_Interp *interp); /* 126 */ EXTERN void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr); /* 127 */ -EXTERN int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr, +EXTERN int TclImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite); /* 128 */ EXTERN void Tcl_PopCallFrame(Tcl_Interp *interp); @@ -346,19 +354,18 @@ EXTERN void Tcl_SetNamespaceResolvers( /* 132 */ EXTERN int TclpHasSockets(Tcl_Interp *interp); /* 133 */ -EXTERN struct tm * TclpGetDate(const time_t *time, int useGMT); +TCL_DEPRECATED("") +struct tm * TclpGetDate(const time_t *time, int useGMT); /* Slot 134 is reserved */ /* Slot 135 is reserved */ /* Slot 136 is reserved */ /* Slot 137 is reserved */ /* 138 */ -EXTERN CONST84_RETURN char * TclGetEnv(const char *name, - Tcl_DString *valuePtr); +EXTERN const char * TclGetEnv(const char *name, Tcl_DString *valuePtr); /* Slot 139 is reserved */ /* Slot 140 is reserved */ /* 141 */ -EXTERN CONST84_RETURN char * TclpGetCwd(Tcl_Interp *interp, - Tcl_DString *cwdPtr); +EXTERN const char * TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 142 */ EXTERN int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, @@ -397,9 +404,11 @@ EXTERN void TclRegError(Tcl_Interp *interp, const char *msg, EXTERN Var * TclVarTraceExists(Tcl_Interp *interp, const char *varName); /* 158 */ -EXTERN void TclSetStartupScriptFileName(const char *filename); +TCL_DEPRECATED("use public Tcl_SetStartupScript()") +void TclSetStartupScriptFileName(const char *filename); /* 159 */ -EXTERN const char * TclGetStartupScriptFileName(void); +TCL_DEPRECATED("use public Tcl_GetStartupScript()") +const char * TclGetStartupScriptFileName(void); /* Slot 160 is reserved */ /* 161 */ EXTERN int TclChannelTransform(Tcl_Interp *interp, @@ -418,9 +427,11 @@ EXTERN int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr); /* 167 */ -EXTERN void TclSetStartupScriptPath(Tcl_Obj *pathPtr); +TCL_DEPRECATED("use public Tcl_SetStartupScript()") +void TclSetStartupScriptPath(Tcl_Obj *pathPtr); /* 168 */ -EXTERN Tcl_Obj * TclGetStartupScriptPath(void); +TCL_DEPRECATED("use public Tcl_GetStartupScript()") +Tcl_Obj * TclGetStartupScriptPath(void); /* 169 */ EXTERN int TclpUtfNcmp2(const char *s1, const char *s2, unsigned long n); @@ -453,16 +464,18 @@ EXTERN void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason); /* 178 */ -EXTERN void Tcl_SetStartupScript(Tcl_Obj *pathPtr, +EXTERN void TclSetStartupScript(Tcl_Obj *pathPtr, const char *encodingName); /* 179 */ -EXTERN Tcl_Obj * Tcl_GetStartupScript(const char **encodingNamePtr); +EXTERN Tcl_Obj * TclGetStartupScript(const char **encodingNamePtr); /* Slot 180 is reserved */ /* Slot 181 is reserved */ /* 182 */ -EXTERN struct tm * TclpLocaltime(const time_t *clock); +TCL_DEPRECATED("") +struct tm * TclpLocaltime(const time_t *clock); /* 183 */ -EXTERN struct tm * TclpGmtime(const time_t *clock); +TCL_DEPRECATED("") +struct tm * TclpGmtime(const time_t *clock); /* Slot 184 is reserved */ /* Slot 185 is reserved */ /* Slot 186 is reserved */ @@ -566,7 +579,8 @@ EXTERN Var * TclVarHashCreateVar(TclVarHashTable *tablePtr, EXTERN void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr); /* 236 */ -EXTERN void TclBackgroundException(Tcl_Interp *interp, int code); +TCL_DEPRECATED("use Tcl_BackgroundException") +void TclBackgroundException(Tcl_Interp *interp, int code); /* 237 */ EXTERN int TclResetCancellation(Tcl_Interp *interp, int force); /* 238 */ @@ -610,6 +624,31 @@ EXTERN char * TclDoubleDigits(double dv, int ndigits, int flags, /* 250 */ EXTERN void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags, int force); +/* 251 */ +EXTERN int TclRegisterLiteral(void *envPtr, const char *bytes, + int length, int flags); +/* 252 */ +EXTERN Tcl_Obj * TclPtrGetVar(Tcl_Interp *interp, Tcl_Var varPtr, + Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, + Tcl_Obj *part2Ptr, const int flags); +/* 253 */ +EXTERN Tcl_Obj * TclPtrSetVar(Tcl_Interp *interp, Tcl_Var varPtr, + Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, + Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, + const int flags); +/* 254 */ +EXTERN Tcl_Obj * TclPtrIncrObjVar(Tcl_Interp *interp, Tcl_Var varPtr, + Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, + Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, + const int flags); +/* 255 */ +EXTERN int TclPtrObjMakeUpvar(Tcl_Interp *interp, + Tcl_Var otherPtr, Tcl_Obj *myNamePtr, + int myFlags); +/* 256 */ +EXTERN int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, + Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, + Tcl_Obj *part2Ptr, const int flags); typedef struct TclIntStubs { int magic; @@ -623,7 +662,7 @@ typedef struct TclIntStubs { int (*tclCleanupChildren) (Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 5 */ void (*tclCleanupCommand) (Command *cmdPtr); /* 6 */ int (*tclCopyAndCollapse) (int count, const char *src, char *dst); /* 7 */ - int (*tclCopyChannelOld) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr); /* 8 */ + TCL_DEPRECATED_API("") int (*tclCopyChannelOld) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr); /* 8 */ int (*tclCreatePipeline) (Tcl_Interp *interp, int argc, const char **argv, Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, TclFile *errFilePtr); /* 9 */ int (*tclCreateProc) (Tcl_Interp *interp, Namespace *nsPtr, const char *procName, Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, Proc **procPtrPtr); /* 10 */ void (*tclDeleteCompiledLocalVars) (Interp *iPtr, CallFrame *framePtr); /* 11 */ @@ -639,7 +678,7 @@ typedef struct TclIntStubs { void (*reserved21)(void); int (*tclFindElement) (Tcl_Interp *interp, const char *listStr, int listLength, const char **elementPtr, const char **nextPtr, int *sizePtr, int *bracePtr); /* 22 */ Proc * (*tclFindProc) (Interp *iPtr, const char *procName); /* 23 */ - int (*tclFormatInt) (char *buffer, long n); /* 24 */ + int (*tclFormatInt) (char *buffer, Tcl_WideInt n); /* 24 */ void (*tclFreePackageInfo) (Interp *iPtr); /* 25 */ void (*reserved26)(void); void (*reserved27)(void); @@ -668,7 +707,7 @@ typedef struct TclIntStubs { void (*tclInitCompiledLocals) (Tcl_Interp *interp, CallFrame *framePtr, Namespace *nsPtr); /* 50 */ int (*tclInterpInit) (Tcl_Interp *interp); /* 51 */ void (*reserved52)(void); - int (*tclInvokeObjectCommand) (ClientData clientData, Tcl_Interp *interp, int argc, CONST84 char **argv); /* 53 */ + int (*tclInvokeObjectCommand) (ClientData clientData, Tcl_Interp *interp, int argc, const char **argv); /* 53 */ int (*tclInvokeStringCommand) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 54 */ Proc * (*tclIsProc) (Command *cmdPtr); /* 55 */ void (*reserved56)(void); @@ -692,7 +731,7 @@ typedef struct TclIntStubs { void (*tclpFree) (char *ptr); /* 74 */ unsigned long (*tclpGetClicks) (void); /* 75 */ unsigned long (*tclpGetSeconds) (void); /* 76 */ - void (*tclpGetTime) (Tcl_Time *time); /* 77 */ + TCL_DEPRECATED_API("") void (*tclpGetTime) (Tcl_Time *time); /* 77 */ void (*reserved78)(void); void (*reserved79)(void); void (*reserved80)(void); @@ -703,7 +742,7 @@ typedef struct TclIntStubs { void (*reserved85)(void); void (*reserved86)(void); void (*reserved87)(void); - char * (*tclPrecTraceProc) (ClientData clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); /* 88 */ + TCL_DEPRECATED_API("") char * (*tclPrecTraceProc) (ClientData clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); /* 88 */ int (*tclPreventAliasLoop) (Tcl_Interp *interp, Tcl_Interp *cmdInterp, Tcl_Command cmd); /* 89 */ void (*reserved90)(void); void (*tclProcCleanupProc) (Proc *procPtr); /* 91 */ @@ -719,7 +758,7 @@ typedef struct TclIntStubs { CONST86 char * (*tclSetPreInitScript) (const char *string); /* 101 */ void (*tclSetupEnv) (Tcl_Interp *interp); /* 102 */ int (*tclSockGetPort) (Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); /* 103 */ - int (*tclSockMinimumBuffersOld) (int sock, int size); /* 104 */ + TCL_DEPRECATED_API("") int (*tclSockMinimumBuffersOld) (int sock, int size); /* 104 */ void (*reserved105)(void); void (*reserved106)(void); void (*reserved107)(void); @@ -727,36 +766,36 @@ typedef struct TclIntStubs { int (*tclUpdateReturnInfo) (Interp *iPtr); /* 109 */ int (*tclSockMinimumBuffers) (void *sock, int size); /* 110 */ void (*tcl_AddInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 111 */ - int (*tcl_AppendExportList) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 112 */ - Tcl_Namespace * (*tcl_CreateNamespace) (Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 113 */ - void (*tcl_DeleteNamespace) (Tcl_Namespace *nsPtr); /* 114 */ - int (*tcl_Export) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 115 */ - Tcl_Command (*tcl_FindCommand) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 116 */ - Tcl_Namespace * (*tcl_FindNamespace) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 117 */ + int (*tclAppendExportList) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 112 */ + Tcl_Namespace * (*tclCreateNamespace) (Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 113 */ + void (*tclDeleteNamespace) (Tcl_Namespace *nsPtr); /* 114 */ + int (*tclExport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 115 */ + Tcl_Command (*tclFindCommand) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 116 */ + Tcl_Namespace * (*tclFindNamespace) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 117 */ int (*tcl_GetInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolverInfo *resInfo); /* 118 */ int (*tcl_GetNamespaceResolvers) (Tcl_Namespace *namespacePtr, Tcl_ResolverInfo *resInfo); /* 119 */ Tcl_Var (*tcl_FindNamespaceVar) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 120 */ - int (*tcl_ForgetImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern); /* 121 */ - Tcl_Command (*tcl_GetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 122 */ - void (*tcl_GetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 123 */ - Tcl_Namespace * (*tcl_GetCurrentNamespace) (Tcl_Interp *interp); /* 124 */ - Tcl_Namespace * (*tcl_GetGlobalNamespace) (Tcl_Interp *interp); /* 125 */ + int (*tclForgetImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern); /* 121 */ + Tcl_Command (*tclGetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 122 */ + void (*tclGetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 123 */ + Tcl_Namespace * (*tclGetCurrentNamespace_) (Tcl_Interp *interp); /* 124 */ + Tcl_Namespace * (*tclGetGlobalNamespace_) (Tcl_Interp *interp); /* 125 */ void (*tcl_GetVariableFullName) (Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr); /* 126 */ - int (*tcl_Import) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite); /* 127 */ + int (*tclImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite); /* 127 */ void (*tcl_PopCallFrame) (Tcl_Interp *interp); /* 128 */ int (*tcl_PushCallFrame) (Tcl_Interp *interp, Tcl_CallFrame *framePtr, Tcl_Namespace *nsPtr, int isProcCallFrame); /* 129 */ int (*tcl_RemoveInterpResolvers) (Tcl_Interp *interp, const char *name); /* 130 */ void (*tcl_SetNamespaceResolvers) (Tcl_Namespace *namespacePtr, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 131 */ int (*tclpHasSockets) (Tcl_Interp *interp); /* 132 */ - struct tm * (*tclpGetDate) (const time_t *time, int useGMT); /* 133 */ + TCL_DEPRECATED_API("") struct tm * (*tclpGetDate) (const time_t *time, int useGMT); /* 133 */ void (*reserved134)(void); void (*reserved135)(void); void (*reserved136)(void); void (*reserved137)(void); - CONST84_RETURN char * (*tclGetEnv) (const char *name, Tcl_DString *valuePtr); /* 138 */ + const char * (*tclGetEnv) (const char *name, Tcl_DString *valuePtr); /* 138 */ void (*reserved139)(void); void (*reserved140)(void); - CONST84_RETURN char * (*tclpGetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 141 */ + const char * (*tclpGetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 141 */ int (*tclSetByteCodeFromAny) (Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, ClientData clientData); /* 142 */ int (*tclAddLiteralObj) (struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr); /* 143 */ void (*tclHideLiteral) (Tcl_Interp *interp, struct CompileEnv *envPtr, int index); /* 144 */ @@ -773,8 +812,8 @@ typedef struct TclIntStubs { void (*reserved155)(void); void (*tclRegError) (Tcl_Interp *interp, const char *msg, int status); /* 156 */ Var * (*tclVarTraceExists) (Tcl_Interp *interp, const char *varName); /* 157 */ - void (*tclSetStartupScriptFileName) (const char *filename); /* 158 */ - const char * (*tclGetStartupScriptFileName) (void); /* 159 */ + TCL_DEPRECATED_API("use public Tcl_SetStartupScript()") void (*tclSetStartupScriptFileName) (const char *filename); /* 158 */ + TCL_DEPRECATED_API("use public Tcl_GetStartupScript()") const char * (*tclGetStartupScriptFileName) (void); /* 159 */ void (*reserved160)(void); int (*tclChannelTransform) (Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr); /* 161 */ void (*tclChannelEventScriptInvoker) (ClientData clientData, int flags); /* 162 */ @@ -782,8 +821,8 @@ typedef struct TclIntStubs { void (*tclExpandCodeArray) (void *envPtr); /* 164 */ void (*tclpSetInitialEncodings) (void); /* 165 */ int (*tclListObjSetElement) (Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr); /* 166 */ - void (*tclSetStartupScriptPath) (Tcl_Obj *pathPtr); /* 167 */ - Tcl_Obj * (*tclGetStartupScriptPath) (void); /* 168 */ + TCL_DEPRECATED_API("use public Tcl_SetStartupScript()") void (*tclSetStartupScriptPath) (Tcl_Obj *pathPtr); /* 167 */ + TCL_DEPRECATED_API("use public Tcl_GetStartupScript()") Tcl_Obj * (*tclGetStartupScriptPath) (void); /* 168 */ int (*tclpUtfNcmp2) (const char *s1, const char *s2, unsigned long n); /* 169 */ int (*tclCheckInterpTraces) (Tcl_Interp *interp, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 170 */ int (*tclCheckExecutionTraces) (Tcl_Interp *interp, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 171 */ @@ -793,12 +832,12 @@ typedef struct TclIntStubs { int (*tclCallVarTraces) (Interp *iPtr, Var *arrayPtr, Var *varPtr, const char *part1, const char *part2, int flags, int leaveErrMsg); /* 175 */ void (*tclCleanupVar) (Var *varPtr, Var *arrayPtr); /* 176 */ void (*tclVarErrMsg) (Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason); /* 177 */ - void (*tcl_SetStartupScript) (Tcl_Obj *pathPtr, const char *encodingName); /* 178 */ - Tcl_Obj * (*tcl_GetStartupScript) (const char **encodingNamePtr); /* 179 */ + void (*tclSetStartupScript) (Tcl_Obj *pathPtr, const char *encodingName); /* 178 */ + Tcl_Obj * (*tclGetStartupScript) (const char **encodingNamePtr); /* 179 */ void (*reserved180)(void); void (*reserved181)(void); - struct tm * (*tclpLocaltime) (const time_t *clock); /* 182 */ - struct tm * (*tclpGmtime) (const time_t *clock); /* 183 */ + TCL_DEPRECATED_API("") struct tm * (*tclpLocaltime) (const time_t *clock); /* 182 */ + TCL_DEPRECATED_API("") struct tm * (*tclpGmtime) (const time_t *clock); /* 183 */ void (*reserved184)(void); void (*reserved185)(void); void (*reserved186)(void); @@ -851,7 +890,7 @@ typedef struct TclIntStubs { void (*tclGetSrcInfoForPc) (CmdFrame *contextPtr); /* 233 */ Var * (*tclVarHashCreateVar) (TclVarHashTable *tablePtr, const char *key, int *newPtr); /* 234 */ void (*tclInitVarHashTable) (TclVarHashTable *tablePtr, Namespace *nsPtr); /* 235 */ - void (*tclBackgroundException) (Tcl_Interp *interp, int code); /* 236 */ + TCL_DEPRECATED_API("use Tcl_BackgroundException") void (*tclBackgroundException) (Tcl_Interp *interp, int code); /* 236 */ int (*tclResetCancellation) (Tcl_Interp *interp, int force); /* 237 */ int (*tclNRInterpProc) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 238 */ int (*tclNRInterpProcCore) (Tcl_Interp *interp, Tcl_Obj *procNameObj, int skip, ProcErrorProc *errorProc); /* 239 */ @@ -866,12 +905,16 @@ typedef struct TclIntStubs { int (*tclCopyChannel) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr); /* 248 */ char * (*tclDoubleDigits) (double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 249 */ void (*tclSetSlaveCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */ + int (*tclRegisterLiteral) (void *envPtr, const char *bytes, int length, int flags); /* 251 */ + Tcl_Obj * (*tclPtrGetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 252 */ + Tcl_Obj * (*tclPtrSetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, const int flags); /* 253 */ + Tcl_Obj * (*tclPtrIncrObjVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, const int flags); /* 254 */ + int (*tclPtrObjMakeUpvar) (Tcl_Interp *interp, Tcl_Var otherPtr, Tcl_Obj *myNamePtr, int myFlags); /* 255 */ + int (*tclPtrUnsetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 256 */ } TclIntStubs; -#ifdef __cplusplus -extern "C" { -#endif extern const TclIntStubs *tclIntStubsPtr; + #ifdef __cplusplus } #endif @@ -1055,38 +1098,38 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclSockMinimumBuffers) /* 110 */ #define Tcl_AddInterpResolvers \ (tclIntStubsPtr->tcl_AddInterpResolvers) /* 111 */ -#define Tcl_AppendExportList \ - (tclIntStubsPtr->tcl_AppendExportList) /* 112 */ -#define Tcl_CreateNamespace \ - (tclIntStubsPtr->tcl_CreateNamespace) /* 113 */ -#define Tcl_DeleteNamespace \ - (tclIntStubsPtr->tcl_DeleteNamespace) /* 114 */ -#define Tcl_Export \ - (tclIntStubsPtr->tcl_Export) /* 115 */ -#define Tcl_FindCommand \ - (tclIntStubsPtr->tcl_FindCommand) /* 116 */ -#define Tcl_FindNamespace \ - (tclIntStubsPtr->tcl_FindNamespace) /* 117 */ +#define TclAppendExportList \ + (tclIntStubsPtr->tclAppendExportList) /* 112 */ +#define TclCreateNamespace \ + (tclIntStubsPtr->tclCreateNamespace) /* 113 */ +#define TclDeleteNamespace \ + (tclIntStubsPtr->tclDeleteNamespace) /* 114 */ +#define TclExport \ + (tclIntStubsPtr->tclExport) /* 115 */ +#define TclFindCommand \ + (tclIntStubsPtr->tclFindCommand) /* 116 */ +#define TclFindNamespace \ + (tclIntStubsPtr->tclFindNamespace) /* 117 */ #define Tcl_GetInterpResolvers \ (tclIntStubsPtr->tcl_GetInterpResolvers) /* 118 */ #define Tcl_GetNamespaceResolvers \ (tclIntStubsPtr->tcl_GetNamespaceResolvers) /* 119 */ #define Tcl_FindNamespaceVar \ (tclIntStubsPtr->tcl_FindNamespaceVar) /* 120 */ -#define Tcl_ForgetImport \ - (tclIntStubsPtr->tcl_ForgetImport) /* 121 */ -#define Tcl_GetCommandFromObj \ - (tclIntStubsPtr->tcl_GetCommandFromObj) /* 122 */ -#define Tcl_GetCommandFullName \ - (tclIntStubsPtr->tcl_GetCommandFullName) /* 123 */ -#define Tcl_GetCurrentNamespace \ - (tclIntStubsPtr->tcl_GetCurrentNamespace) /* 124 */ -#define Tcl_GetGlobalNamespace \ - (tclIntStubsPtr->tcl_GetGlobalNamespace) /* 125 */ +#define TclForgetImport \ + (tclIntStubsPtr->tclForgetImport) /* 121 */ +#define TclGetCommandFromObj \ + (tclIntStubsPtr->tclGetCommandFromObj) /* 122 */ +#define TclGetCommandFullName \ + (tclIntStubsPtr->tclGetCommandFullName) /* 123 */ +#define TclGetCurrentNamespace_ \ + (tclIntStubsPtr->tclGetCurrentNamespace_) /* 124 */ +#define TclGetGlobalNamespace_ \ + (tclIntStubsPtr->tclGetGlobalNamespace_) /* 125 */ #define Tcl_GetVariableFullName \ (tclIntStubsPtr->tcl_GetVariableFullName) /* 126 */ -#define Tcl_Import \ - (tclIntStubsPtr->tcl_Import) /* 127 */ +#define TclImport \ + (tclIntStubsPtr->tclImport) /* 127 */ #define Tcl_PopCallFrame \ (tclIntStubsPtr->tcl_PopCallFrame) /* 128 */ #define Tcl_PushCallFrame \ @@ -1177,10 +1220,10 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclCleanupVar) /* 176 */ #define TclVarErrMsg \ (tclIntStubsPtr->tclVarErrMsg) /* 177 */ -#define Tcl_SetStartupScript \ - (tclIntStubsPtr->tcl_SetStartupScript) /* 178 */ -#define Tcl_GetStartupScript \ - (tclIntStubsPtr->tcl_GetStartupScript) /* 179 */ +#define TclSetStartupScript \ + (tclIntStubsPtr->tclSetStartupScript) /* 178 */ +#define TclGetStartupScript \ + (tclIntStubsPtr->tclGetStartupScript) /* 179 */ /* Slot 180 is reserved */ /* Slot 181 is reserved */ #define TclpLocaltime \ @@ -1297,6 +1340,18 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclDoubleDigits) /* 249 */ #define TclSetSlaveCancelFlags \ (tclIntStubsPtr->tclSetSlaveCancelFlags) /* 250 */ +#define TclRegisterLiteral \ + (tclIntStubsPtr->tclRegisterLiteral) /* 251 */ +#define TclPtrGetVar \ + (tclIntStubsPtr->tclPtrGetVar) /* 252 */ +#define TclPtrSetVar \ + (tclIntStubsPtr->tclPtrSetVar) /* 253 */ +#define TclPtrIncrObjVar \ + (tclIntStubsPtr->tclPtrIncrObjVar) /* 254 */ +#define TclPtrObjMakeUpvar \ + (tclIntStubsPtr->tclPtrObjMakeUpvar) /* 255 */ +#define TclPtrUnsetVar \ + (tclIntStubsPtr->tclPtrUnsetVar) /* 256 */ #endif /* defined(USE_TCL_STUBS) */ @@ -1305,58 +1360,28 @@ extern const TclIntStubs *tclIntStubsPtr; #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT -#undef TclGetStartupScriptFileName -#undef TclSetStartupScriptFileName -#undef TclGetStartupScriptPath -#undef TclSetStartupScriptPath -#undef TclBackgroundException - -#if defined(USE_TCL_STUBS) && defined(TCL_NO_DEPRECATED) -# undef Tcl_SetStartupScript -# define Tcl_SetStartupScript \ - (tclStubsPtr->tcl_SetStartupScript) /* 622 */ -# undef Tcl_GetStartupScript -# define Tcl_GetStartupScript \ - (tclStubsPtr->tcl_GetStartupScript) /* 623 */ -# undef Tcl_CreateNamespace -# define Tcl_CreateNamespace \ - (tclStubsPtr->tcl_CreateNamespace) /* 506 */ -# undef Tcl_DeleteNamespace -# define Tcl_DeleteNamespace \ - (tclStubsPtr->tcl_DeleteNamespace) /* 507 */ -# undef Tcl_AppendExportList -# define Tcl_AppendExportList \ - (tclStubsPtr->tcl_AppendExportList) /* 508 */ -# undef Tcl_Export -# define Tcl_Export \ - (tclStubsPtr->tcl_Export) /* 509 */ -# undef Tcl_Import -# define Tcl_Import \ - (tclStubsPtr->tcl_Import) /* 510 */ -# undef Tcl_ForgetImport -# define Tcl_ForgetImport \ - (tclStubsPtr->tcl_ForgetImport) /* 511 */ -# undef Tcl_GetCurrentNamespace -# define Tcl_GetCurrentNamespace \ - (tclStubsPtr->tcl_GetCurrentNamespace) /* 512 */ -# undef Tcl_GetGlobalNamespace -# define Tcl_GetGlobalNamespace \ - (tclStubsPtr->tcl_GetGlobalNamespace) /* 513 */ -# undef Tcl_FindNamespace -# define Tcl_FindNamespace \ - (tclStubsPtr->tcl_FindNamespace) /* 514 */ -# undef Tcl_FindCommand -# define Tcl_FindCommand \ - (tclStubsPtr->tcl_FindCommand) /* 515 */ -# undef Tcl_GetCommandFromObj -# define Tcl_GetCommandFromObj \ - (tclStubsPtr->tcl_GetCommandFromObj) /* 516 */ -# undef Tcl_GetCommandFullName -# define Tcl_GetCommandFullName \ - (tclStubsPtr->tcl_GetCommandFullName) /* 517 */ +#if defined(USE_TCL_STUBS) +# undef TclGetStartupScriptFileName +# undef TclSetStartupScriptFileName +# undef TclGetStartupScriptPath +# undef TclSetStartupScriptPath +# undef TclBackgroundException +# undef TclSetStartupScript +# undef TclGetStartupScript +# undef TclCreateNamespace +# undef TclDeleteNamespace +# undef TclAppendExportList +# undef TclExport +# undef TclImport +# undef TclForgetImport +# undef TclGetCurrentNamespace_ +# undef TclGetGlobalNamespace_ +# undef TclFindNamespace +# undef TclFindCommand +# undef TclGetCommandFromObj +# undef TclGetCommandFullName +# undef TclCopyChannelOld +# undef TclSockMinimumBuffersOld #endif -#undef TclCopyChannelOld -#undef TclSockMinimumBuffersOld - #endif /* _TCLINTDECLS */ diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 3181d4e..51d2f65 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -13,11 +13,6 @@ #ifndef _TCLINTPLATDECLS #define _TCLINTPLATDECLS -#ifdef __WIN32__ -# define Tcl_DirEntry void -# define DIR void -#endif - #undef TCL_STORAGE_CLASS #ifdef BUILD_tcl # define TCL_STORAGE_CLASS DLLEXPORT @@ -37,11 +32,15 @@ /* !BEGIN!: Do not edit below this line. */ +#ifdef __cplusplus +extern "C" { +#endif + /* * Exported function declarations: */ -#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ /* 0 */ EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan); @@ -68,7 +67,7 @@ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); /* 9 */ EXTERN TclFile TclpCreateTempFile(const char *contents); /* 10 */ -EXTERN Tcl_DirEntry * TclpReaddir(DIR *dir); +EXTERN Tcl_DirEntry * TclpReaddir(TclDIR *dir); /* 11 */ EXTERN struct tm * TclpLocaltime_unix(const time_t *clock); /* 12 */ @@ -94,13 +93,13 @@ EXTERN int TclUnixCopyFile(const char *src, const char *dst, /* Slot 27 is reserved */ /* Slot 28 is reserved */ /* 29 */ -EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs); +EXTERN int TclWinCPUID(int index, int *regs); /* 30 */ EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); #endif /* UNIX */ -#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ /* 0 */ EXTERN void TclWinConvertError(DWORD errCode); /* 1 */ @@ -125,7 +124,7 @@ EXTERN int TclpGetPid(Tcl_Pid pid); /* 9 */ EXTERN int TclWinGetPlatformId(void); /* 10 */ -EXTERN Tcl_DirEntry * TclpReaddir(DIR *dir); +EXTERN Tcl_DirEntry * TclpReaddir(TclDIR *dir); /* 11 */ EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan); @@ -169,7 +168,7 @@ EXTERN void TclWinFlushDirtyChannels(void); /* 28 */ EXTERN void TclWinResetInterfaces(void); /* 29 */ -EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs); +EXTERN int TclWinCPUID(int index, int *regs); /* 30 */ EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, @@ -202,7 +201,7 @@ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); /* 9 */ EXTERN TclFile TclpCreateTempFile(const char *contents); /* 10 */ -EXTERN Tcl_DirEntry * TclpReaddir(DIR *dir); +EXTERN Tcl_DirEntry * TclpReaddir(TclDIR *dir); /* 11 */ EXTERN struct tm * TclpLocaltime_unix(const time_t *clock); /* 12 */ @@ -243,7 +242,7 @@ EXTERN void TclMacOSXNotifierAddRunLoopMode( /* Slot 27 is reserved */ /* Slot 28 is reserved */ /* 29 */ -EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs); +EXTERN int TclWinCPUID(int index, int *regs); /* 30 */ EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, @@ -254,7 +253,7 @@ typedef struct TclIntPlatStubs { int magic; void *hooks; -#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */ int (*tclpCloseFile) (TclFile file); /* 1 */ Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ @@ -265,7 +264,7 @@ typedef struct TclIntPlatStubs { TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */ int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */ TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */ - Tcl_DirEntry * (*tclpReaddir) (DIR *dir); /* 10 */ + Tcl_DirEntry * (*tclpReaddir) (TclDIR *dir); /* 10 */ struct tm * (*tclpLocaltime_unix) (const time_t *clock); /* 11 */ struct tm * (*tclpGmtime_unix) (const time_t *clock); /* 12 */ char * (*tclpInetNtoa) (struct in_addr addr); /* 13 */ @@ -284,10 +283,10 @@ typedef struct TclIntPlatStubs { void (*reserved26)(void); void (*reserved27)(void); void (*reserved28)(void); - int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */ + int (*tclWinCPUID) (int index, int *regs); /* 29 */ int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* UNIX */ -#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ void (*tclWinConvertError) (DWORD errCode); /* 0 */ void (*tclWinConvertWSAError) (DWORD errCode); /* 1 */ struct servent * (*tclWinGetServByName) (const char *nm, const char *proto); /* 2 */ @@ -298,7 +297,7 @@ typedef struct TclIntPlatStubs { int (*tclWinSetSockOpt) (SOCKET s, int level, int optname, const char *optval, int optlen); /* 7 */ int (*tclpGetPid) (Tcl_Pid pid); /* 8 */ int (*tclWinGetPlatformId) (void); /* 9 */ - Tcl_DirEntry * (*tclpReaddir) (DIR *dir); /* 10 */ + Tcl_DirEntry * (*tclpReaddir) (TclDIR *dir); /* 10 */ void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 11 */ int (*tclpCloseFile) (TclFile file); /* 12 */ Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 13 */ @@ -317,7 +316,7 @@ typedef struct TclIntPlatStubs { void (*tclWinSetInterfaces) (int wide); /* 26 */ void (*tclWinFlushDirtyChannels) (void); /* 27 */ void (*tclWinResetInterfaces) (void); /* 28 */ - int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */ + int (*tclWinCPUID) (int index, int *regs); /* 29 */ int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ @@ -331,7 +330,7 @@ typedef struct TclIntPlatStubs { TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */ int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */ TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */ - Tcl_DirEntry * (*tclpReaddir) (DIR *dir); /* 10 */ + Tcl_DirEntry * (*tclpReaddir) (TclDIR *dir); /* 10 */ struct tm * (*tclpLocaltime_unix) (const time_t *clock); /* 11 */ struct tm * (*tclpGmtime_unix) (const time_t *clock); /* 12 */ char * (*tclpInetNtoa) (struct in_addr addr); /* 13 */ @@ -350,15 +349,13 @@ typedef struct TclIntPlatStubs { void (*reserved26)(void); void (*reserved27)(void); void (*reserved28)(void); - int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */ + int (*tclWinCPUID) (int index, int *regs); /* 29 */ int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* MACOSX */ } TclIntPlatStubs; -#ifdef __cplusplus -extern "C" { -#endif extern const TclIntPlatStubs *tclIntPlatStubsPtr; + #ifdef __cplusplus } #endif @@ -369,7 +366,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; * Inline function declarations: */ -#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ #define TclGetAndDetachPids \ (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */ #define TclpCloseFile \ @@ -418,7 +415,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #define TclUnixOpenTemporaryFile \ (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* UNIX */ -#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ #define TclWinConvertError \ (tclIntPlatStubsPtr->tclWinConvertError) /* 0 */ #define TclWinConvertWSAError \ @@ -548,9 +545,23 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #undef TclpInetNtoa #define TclpInetNtoa inet_ntoa -#if defined(__WIN32__) || defined(__CYGWIN__) +#if defined(_WIN32) # undef TclWinNToHS -# define TclWinNToHS ntohs +# undef TclWinGetServByName +# undef TclWinGetSockOpt +# undef TclWinSetSockOpt +# undef TclWinGetPlatformId +# undef TclWinResetInterfaces +# undef TclWinSetInterfaces +# if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 +# define TclWinNToHS ntohs +# define TclWinGetServByName getservbyname +# define TclWinGetSockOpt getsockopt +# define TclWinSetSockOpt setsockopt +# define TclWinGetPlatformId() (2) /* VER_PLATFORM_WIN32_NT */ +# define TclWinResetInterfaces() /* nop */ +# define TclWinSetInterfaces(dummy) /* nop */ +# endif /* TCL_NO_DEPRECATED */ #else # undef TclpGetPid # define TclpGetPid(pid) ((unsigned long) (pid)) diff --git a/generic/tclInterp.c b/generic/tclInterp.c index fe218ff..505aaec 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -274,6 +274,12 @@ static void DeleteScriptLimitCallback(ClientData clientData); static void RunLimitHandlers(LimitHandler *handlerPtr, Tcl_Interp *interp); static void TimeLimitCallback(ClientData clientData); + +/* NRE enabling */ +static Tcl_NRPostProc NRPostInvokeHidden; +static Tcl_ObjCmdProc NRInterpCmd; +static Tcl_ObjCmdProc NRSlaveCmd; + /* *---------------------------------------------------------------------- @@ -320,13 +326,24 @@ TclSetPreInitScript( *---------------------------------------------------------------------- */ +typedef struct PkgName { + struct PkgName *nextPtr; /* Next in list of package names being initialized. */ + char name[4]; +} PkgName; + int Tcl_Init( Tcl_Interp *interp) /* Interpreter to initialize. */ { + PkgName pkgName = {NULL, "Tcl"}; + PkgName **names = TclInitPkgFiles(interp); + int result = TCL_ERROR; + + pkgName.nextPtr = *names; + *names = &pkgName; if (tclPreInitScript != NULL) { - if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) { - return TCL_ERROR; + if (Tcl_EvalEx(interp, tclPreInitScript, -1, 0) == TCL_ERROR) { + goto end; } } @@ -371,7 +388,7 @@ Tcl_Init( * alternate tclInit command before calling Tcl_Init(). */ - return Tcl_Eval(interp, + result = Tcl_EvalEx(interp, "if {[namespace which -command tclInit] eq \"\"} {\n" " proc tclInit {} {\n" " global tcl_libPath tcl_library env tclDefaultLibrary\n" @@ -399,6 +416,7 @@ Tcl_Init( " {file join $grandParentDir lib tcl[info tclversion]} \\\n" " {file join $parentDir library} \\\n" " {file join $grandParentDir library} \\\n" +" {file join $grandParentDir tcl[info tclversion] library} \\\n" " {file join $grandParentDir tcl[info patchlevel] library} \\\n" " {\n" "file join [file dirname $grandParentDir] tcl[info patchlevel] library}\n" @@ -433,7 +451,11 @@ Tcl_Init( " error $msg\n" " }\n" "}\n" -"tclInit"); +"tclInit", -1, 0); + +end: + *names = (*names)->nextPtr; + return result; } /* @@ -476,7 +498,8 @@ TclInterpInit( slavePtr->interpCmd = NULL; Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); - Tcl_CreateObjCommand(interp, "interp", Tcl_InterpObjCmd, NULL, NULL); + Tcl_NRCreateCommand(interp, "interp", Tcl_InterpObjCmd, NRInterpCmd, + NULL, NULL); Tcl_CallWhenDeleted(interp, InterpInfoDeleteProc, NULL); return TCL_OK; @@ -585,6 +608,16 @@ Tcl_InterpObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + return Tcl_NRCallObjProc(interp, NRInterpCmd, clientData, objc, objv); +} + +static int +NRInterpCmd( + ClientData clientData, /* Unused. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ Tcl_Interp *slaveInterp; int index; static const char *const options[] = { @@ -638,14 +671,9 @@ Tcl_InterpObjCmd( if (masterInterp == NULL) { return TCL_ERROR; } - if (TclGetString(objv[5])[0] == '\0') { - if (objc == 6) { - return AliasDelete(interp, slaveInterp, objv[3]); - } - } else { - return AliasCreate(interp, slaveInterp, masterInterp, objv[3], - objv[5], objc - 6, objv + 6); - } + + return AliasCreate(interp, slaveInterp, masterInterp, objv[3], + objv[5], objc - 6, objv + 6); } goto aliasArgs; } @@ -701,7 +729,7 @@ Tcl_InterpObjCmd( } endOfForLoop: - if ((i + 2) < objc) { + if (i < objc - 2) { Tcl_WrongNumArgs(interp, 2, objv, "?-unwind? ?--? ?path? ?result?"); return TCL_ERROR; @@ -1773,11 +1801,9 @@ AliasNRCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument vector. */ { - Interp *iPtr = (Interp *) interp; Alias *aliasPtr = clientData; int prefc, cmdc, i; Tcl_Obj **prefv, **cmdv; - int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL); Tcl_Obj *listPtr; List *listRep; int flags = TCL_EVAL_INVOKE; @@ -1809,21 +1835,7 @@ AliasNRCmd( * only the source command should show, not the full target prefix. */ - if (isRootEnsemble) { - iPtr->ensembleRewrite.sourceObjs = objv; - iPtr->ensembleRewrite.numRemovedObjs = 1; - iPtr->ensembleRewrite.numInsertedObjs = prefc; - } else { - iPtr->ensembleRewrite.numInsertedObjs += prefc - 1; - } - - /* - * We are sending a 0-refCount obj, do not need a callback: it will be - * cleaned up automatically. But we may need to clear the rootEnsemble - * stuff ... - */ - - if (isRootEnsemble) { + if (TclInitRewriteEnsemble(interp, 1, prefc, objv)) { TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); } TclSkipTailcall(interp); @@ -1844,7 +1856,7 @@ TclAliasObjCmd( Tcl_Obj **prefv, **cmdv; Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC]; Interp *tPtr = (Interp *) targetInterp; - int isRootEnsemble = (tPtr->ensembleRewrite.sourceObjs == NULL); + int isRootEnsemble; /* * Append the arguments to the command prefix and invoke the command in @@ -1860,7 +1872,6 @@ TclAliasObjCmd( cmdv = TclStackAlloc(interp, cmdc * sizeof(Tcl_Obj *)); } - prefv = &aliasPtr->objPtr; memcpy(cmdv, prefv, (size_t) (prefc * sizeof(Tcl_Obj *))); memcpy(cmdv+prefc, objv+1, (size_t) ((objc-1) * sizeof(Tcl_Obj *))); @@ -1875,13 +1886,7 @@ TclAliasObjCmd( * only the source command should show, not the full target prefix. */ - if (isRootEnsemble) { - tPtr->ensembleRewrite.sourceObjs = objv; - tPtr->ensembleRewrite.numRemovedObjs = 1; - tPtr->ensembleRewrite.numInsertedObjs = prefc; - } else { - tPtr->ensembleRewrite.numInsertedObjs += prefc - 1; - } + isRootEnsemble = TclInitRewriteEnsemble((Tcl_Interp *)tPtr, 1, prefc, objv); /* * Protect the target interpreter if it isn't the same as the source @@ -1904,9 +1909,7 @@ TclAliasObjCmd( */ if (isRootEnsemble) { - tPtr->ensembleRewrite.sourceObjs = NULL; - tPtr->ensembleRewrite.numRemovedObjs = 0; - tPtr->ensembleRewrite.numInsertedObjs = 0; + TclResetRewriteEnsemble((Tcl_Interp *)tPtr, 1); } /* @@ -2367,11 +2370,11 @@ SlaveCreate( slavePtr->masterInterp = masterInterp; slavePtr->slaveEntryPtr = hPtr; slavePtr->slaveInterp = slaveInterp; - slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, path, - TclSlaveObjCmd, slaveInterp, SlaveObjCmdDeleteProc); + slavePtr->interpCmd = Tcl_NRCreateCommand(masterInterp, path, + TclSlaveObjCmd, NRSlaveCmd, slaveInterp, SlaveObjCmdDeleteProc); Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); Tcl_SetHashValue(hPtr, slavePtr); - Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); + Tcl_SetVar2(slaveInterp, "tcl_interactive", NULL, "0", TCL_GLOBAL_ONLY); /* * Inherit the recursion limit. @@ -2457,6 +2460,16 @@ TclSlaveObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + return Tcl_NRCallObjProc(interp, NRSlaveCmd, clientData, objc, objv); +} + +static int +NRSlaveCmd( + ClientData clientData, /* Slave interpreter. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ Tcl_Interp *slaveInterp = clientData; int index; static const char *const options[] = { @@ -3047,7 +3060,11 @@ SlaveInvokeHidden( Tcl_AllowExceptions(slaveInterp); if (namespaceName == NULL) { - result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN); + NRE_callback *rootPtr = TOP_CB(slaveInterp); + + Tcl_NRAddCallback(interp, NRPostInvokeHidden, slaveInterp, + rootPtr, NULL, NULL); + return TclNRInvoke(NULL, slaveInterp, objc, objv); } else { Namespace *nsPtr, *dummy1, *dummy2; const char *tail; @@ -3066,6 +3083,23 @@ SlaveInvokeHidden( Tcl_Release(slaveInterp); return result; } + +static int +NRPostInvokeHidden( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_Interp *slaveInterp = (Tcl_Interp *)data[0]; + NRE_callback *rootPtr = (NRE_callback *)data[1]; + + if (interp != slaveInterp) { + result = TclNRRunCallbacks(slaveInterp, result, rootPtr); + Tcl_TransferResult(slaveInterp, result, interp); + } + Tcl_Release(slaveInterp); + return result; +} /* *---------------------------------------------------------------------- @@ -3167,12 +3201,8 @@ Tcl_MakeSafe( * Assume these functions all work. [Bug 2895741] */ - (void) Tcl_Eval(interp, - "namespace eval ::tcl {namespace eval mathfunc {}}"); - (void) Tcl_CreateAlias(interp, "::tcl::mathfunc::min", master, - "::tcl::mathfunc::min", 0, NULL); - (void) Tcl_CreateAlias(interp, "::tcl::mathfunc::max", master, - "::tcl::mathfunc::max", 0, NULL); + (void) Tcl_EvalEx(interp, + "namespace eval ::tcl {namespace eval mathfunc {}}", -1, 0); } iPtr->flags |= SAFE_INTERP; @@ -3494,9 +3524,6 @@ Tcl_LimitAddHandler( if (deleteProc == (Tcl_LimitHandlerDeleteProc *) TCL_DYNAMIC) { deleteProc = (Tcl_LimitHandlerDeleteProc *) Tcl_Free; } - if (deleteProc == (Tcl_LimitHandlerDeleteProc *) TCL_STATIC) { - deleteProc = NULL; - } /* * Allocate a handler record. @@ -4474,7 +4501,7 @@ SlaveCommandLimitCmd( switch ((enum Options) index) { case OPT_CMD: scriptObj = objv[i+1]; - (void) Tcl_GetStringFromObj(objv[i+1], &scriptLen); + (void) TclGetStringFromObj(scriptObj, &scriptLen); break; case OPT_GRAN: granObj = objv[i+1]; @@ -4491,7 +4518,7 @@ SlaveCommandLimitCmd( break; case OPT_VAL: limitObj = objv[i+1]; - (void) Tcl_GetStringFromObj(objv[i+1], &limitLen); + (void) TclGetStringFromObj(objv[i+1], &limitLen); if (limitLen == 0) { break; } @@ -4683,7 +4710,7 @@ SlaveTimeLimitCmd( switch ((enum Options) index) { case OPT_CMD: scriptObj = objv[i+1]; - (void) Tcl_GetStringFromObj(objv[i+1], &scriptLen); + (void) TclGetStringFromObj(objv[i+1], &scriptLen); break; case OPT_GRAN: granObj = objv[i+1]; @@ -4700,7 +4727,7 @@ SlaveTimeLimitCmd( break; case OPT_MILLI: milliObj = objv[i+1]; - (void) Tcl_GetStringFromObj(objv[i+1], &milliLen); + (void) TclGetStringFromObj(objv[i+1], &milliLen); if (milliLen == 0) { break; } @@ -4718,7 +4745,7 @@ SlaveTimeLimitCmd( break; case OPT_SEC: secObj = objv[i+1]; - (void) Tcl_GetStringFromObj(objv[i+1], &secLen); + (void) TclGetStringFromObj(objv[i+1], &secLen); if (secLen == 0) { break; } diff --git a/generic/tclLink.c b/generic/tclLink.c index 2735256..53187d7 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -36,8 +36,10 @@ typedef struct Link { unsigned int ui; short s; unsigned short us; +#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) long l; unsigned long ul; +#endif Tcl_WideInt w; Tcl_WideUInt uw; float f; @@ -67,6 +69,9 @@ typedef struct Link { static char * LinkTraceProc(ClientData clientData,Tcl_Interp *interp, const char *name1, const char *name2, int flags); static Tcl_Obj * ObjValue(Link *linkPtr); +static int GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr); +static int GetInvalidWideFromObj(Tcl_Obj *objPtr, Tcl_WideInt *widePtr); +static int GetInvalidDoubleFromObj(Tcl_Obj *objPtr, double *doublePtr); /* * Convenience macro for accessing the value of the C variable pointed to by a @@ -126,6 +131,14 @@ Tcl_LinkVar( Tcl_IncrRefCount(linkPtr->varName); linkPtr->addr = addr; linkPtr->type = type & ~TCL_LINK_READ_ONLY; +#if !defined(TCL_NO_DEPRECATED) && (defined(TCL_WIDE_INT_IS_LONG) \ + || defined(_WIN32) || defined(__CYGWIN__)) + if (linkPtr->type == 11 /* legacy TCL_LINK_LONG */) { + linkPtr->type = TCL_LINK_LONG; + } else if (linkPtr->type == 12 /* legacy TCL_LINK_ULONG */) { + linkPtr->type = TCL_LINK_ULONG; + } +#endif if (type & TCL_LINK_READ_ONLY) { linkPtr->flags = LINK_READ_ONLY; } else { @@ -259,7 +272,8 @@ LinkTraceProc( int flags) /* Miscellaneous additional information. */ { Link *linkPtr = clientData; - int changed, valueLength; + int changed; + size_t valueLength; const char *value; char **pp; Tcl_Obj *valueObj; @@ -331,12 +345,14 @@ LinkTraceProc( case TCL_LINK_UINT: changed = (LinkedVar(unsigned int) != linkPtr->lastValue.ui); break; +#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) case TCL_LINK_LONG: changed = (LinkedVar(long) != linkPtr->lastValue.l); break; case TCL_LINK_ULONG: changed = (LinkedVar(unsigned long) != linkPtr->lastValue.ul); break; +#endif case TCL_LINK_FLOAT: changed = (LinkedVar(float) != linkPtr->lastValue.f); break; @@ -378,8 +394,8 @@ LinkTraceProc( switch (linkPtr->type) { case TCL_LINK_INT: - if (Tcl_GetIntFromObj(NULL, valueObj, &linkPtr->lastValue.i) - != TCL_OK) { + if (Tcl_GetIntFromObj(NULL, valueObj, &linkPtr->lastValue.i) != TCL_OK + && GetInvalidIntFromObj(valueObj, &linkPtr->lastValue.i) != TCL_OK) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable must have integer value"; @@ -388,8 +404,8 @@ LinkTraceProc( break; case TCL_LINK_WIDE_INT: - if (Tcl_GetWideIntFromObj(NULL, valueObj, &linkPtr->lastValue.w) - != TCL_OK) { + if (Tcl_GetWideIntFromObj(NULL, valueObj, &linkPtr->lastValue.w) != TCL_OK + && GetInvalidWideFromObj(valueObj, &linkPtr->lastValue.w) != TCL_OK) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable must have integer value"; @@ -398,14 +414,15 @@ LinkTraceProc( break; case TCL_LINK_DOUBLE: - if (Tcl_GetDoubleFromObj(NULL, valueObj, &linkPtr->lastValue.d) - != TCL_OK) { + if (Tcl_GetDoubleFromObj(NULL, valueObj, &linkPtr->lastValue.d) != TCL_OK) { #ifdef ACCEPT_NAN if (valueObj->typePtr != &tclDoubleType) { #endif - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, - ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable must have real value"; + if (GetInvalidDoubleFromObj(valueObj, &linkPtr->lastValue.d) != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have real value"; + } #ifdef ACCEPT_NAN } linkPtr->lastValue.d = valueObj->internalRep.doubleValue; @@ -415,8 +432,7 @@ LinkTraceProc( break; case TCL_LINK_BOOLEAN: - if (Tcl_GetBooleanFromObj(NULL, valueObj, &linkPtr->lastValue.i) - != TCL_OK) { + if (Tcl_GetBooleanFromObj(NULL, valueObj, &linkPtr->lastValue.i) != TCL_OK) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable must have boolean value"; @@ -425,113 +441,115 @@ LinkTraceProc( break; case TCL_LINK_CHAR: - if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK + if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK + && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) || valueInt < SCHAR_MIN || valueInt > SCHAR_MAX) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable must have char value"; } - linkPtr->lastValue.c = (char)valueInt; - LinkedVar(char) = linkPtr->lastValue.c; + LinkedVar(char) = linkPtr->lastValue.c = (char)valueInt; break; case TCL_LINK_UCHAR: - if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK + if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK + && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) || valueInt < 0 || valueInt > UCHAR_MAX) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable must have unsigned char value"; } - linkPtr->lastValue.uc = (unsigned char) valueInt; - LinkedVar(unsigned char) = linkPtr->lastValue.uc; + LinkedVar(unsigned char) = linkPtr->lastValue.uc = (unsigned char) valueInt; break; case TCL_LINK_SHORT: - if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK + if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK + && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) || valueInt < SHRT_MIN || valueInt > SHRT_MAX) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable must have short value"; } - linkPtr->lastValue.s = (short)valueInt; - LinkedVar(short) = linkPtr->lastValue.s; + LinkedVar(short) = linkPtr->lastValue.s = (short)valueInt; break; case TCL_LINK_USHORT: - if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK + if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK + && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) || valueInt < 0 || valueInt > USHRT_MAX) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable must have unsigned short value"; } - linkPtr->lastValue.us = (unsigned short)valueInt; - LinkedVar(unsigned short) = linkPtr->lastValue.us; + LinkedVar(unsigned short) = linkPtr->lastValue.us = (unsigned short)valueInt; break; case TCL_LINK_UINT: - if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK + if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK + && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) || valueWide < 0 || valueWide > UINT_MAX) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable must have unsigned int value"; } - linkPtr->lastValue.ui = (unsigned int)valueWide; - LinkedVar(unsigned int) = linkPtr->lastValue.ui; + LinkedVar(unsigned int) = linkPtr->lastValue.ui = (unsigned int)valueWide; break; +#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) case TCL_LINK_LONG: - if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK + if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK + && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) || valueWide < LONG_MIN || valueWide > LONG_MAX) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable must have long value"; } - linkPtr->lastValue.l = (long)valueWide; - LinkedVar(long) = linkPtr->lastValue.l; + LinkedVar(long) = linkPtr->lastValue.l = (long)valueWide; break; case TCL_LINK_ULONG: - if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK + if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK + && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) || valueWide < 0 || (Tcl_WideUInt) valueWide > ULONG_MAX) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable must have unsigned long value"; } - linkPtr->lastValue.ul = (unsigned long)valueWide; - LinkedVar(unsigned long) = linkPtr->lastValue.ul; + LinkedVar(unsigned long) = linkPtr->lastValue.ul = (unsigned long)valueWide; break; +#endif case TCL_LINK_WIDE_UINT: /* * FIXME: represent as a bignum. */ - if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK) { + if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK + && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable must have unsigned wide int value"; } - linkPtr->lastValue.uw = (Tcl_WideUInt)valueWide; - LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw; + LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw = (Tcl_WideUInt)valueWide; break; case TCL_LINK_FLOAT: - if (Tcl_GetDoubleFromObj(interp, valueObj, &valueDouble) != TCL_OK + if ((Tcl_GetDoubleFromObj(NULL, valueObj, &valueDouble) != TCL_OK + && GetInvalidDoubleFromObj(valueObj, &valueDouble) != TCL_OK) || valueDouble < -FLT_MAX || valueDouble > FLT_MAX) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable must have float value"; } - linkPtr->lastValue.f = (float)valueDouble; - LinkedVar(float) = linkPtr->lastValue.f; + LinkedVar(float) = linkPtr->lastValue.f = (float)valueDouble; break; case TCL_LINK_STRING: - value = Tcl_GetStringFromObj(valueObj, &valueLength); - valueLength++; + value = TclGetString(valueObj); + valueLength = valueObj->length + 1; pp = (char **) linkPtr->addr; *pp = ckrealloc(*pp, valueLength); - memcpy(*pp, value, (unsigned) valueLength); + memcpy(*pp, value, valueLength); break; default: @@ -577,7 +595,7 @@ ObjValue( return Tcl_NewDoubleObj(linkPtr->lastValue.d); case TCL_LINK_BOOLEAN: linkPtr->lastValue.i = LinkedVar(int); - return Tcl_NewBooleanObj(linkPtr->lastValue.i != 0); + return Tcl_NewBooleanObj(linkPtr->lastValue.i); case TCL_LINK_CHAR: linkPtr->lastValue.c = LinkedVar(char); return Tcl_NewIntObj(linkPtr->lastValue.c); @@ -593,12 +611,14 @@ ObjValue( case TCL_LINK_UINT: linkPtr->lastValue.ui = LinkedVar(unsigned int); return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ui); +#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) case TCL_LINK_LONG: linkPtr->lastValue.l = LinkedVar(long); return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.l); case TCL_LINK_ULONG: linkPtr->lastValue.ul = LinkedVar(unsigned long); return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ul); +#endif case TCL_LINK_FLOAT: linkPtr->lastValue.f = LinkedVar(float); return Tcl_NewDoubleObj(linkPtr->lastValue.f); @@ -626,6 +646,108 @@ ObjValue( return resultObj; } } + +static int SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); + +static Tcl_ObjType invalidRealType = { + "invalidReal", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + NULL, /* updateStringProc */ + NULL /* setFromAnyProc */ +}; + +static int +SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) { + const char *str; + const char *endPtr; + + str = TclGetString(objPtr); + if ((objPtr->length == 1) && (str[0] == '.')){ + objPtr->typePtr = &invalidRealType; + objPtr->internalRep.doubleValue = 0.0; + return TCL_OK; + } + if (TclParseNumber(NULL, objPtr, NULL, str, objPtr->length, &endPtr, + TCL_PARSE_DECIMAL_ONLY) == TCL_OK) { + /* If number is followed by [eE][+-]?, then it is an invalid + * double, but it could be the start of a valid double. */ + if (*endPtr == 'e' || *endPtr == 'E') { + ++endPtr; + if (*endPtr == '+' || *endPtr == '-') ++endPtr; + if (*endPtr == 0) { + double doubleValue = 0.0; + Tcl_GetDoubleFromObj(NULL, objPtr, &doubleValue); + TclFreeIntRep(objPtr); + objPtr->typePtr = &invalidRealType; + objPtr->internalRep.doubleValue = doubleValue; + return TCL_OK; + } + } + } + return TCL_ERROR; +} + + +/* + * This function checks for integer representations, which are valid + * when linking with C variables, but which are invalid in other + * contexts in Tcl. Handled are "+", "-", "", "0x", "0b", "0d" and "0o" + * (upperand lowercase). See bug [39f6304c2e]. + */ +int +GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr) +{ + const char *str = TclGetString(objPtr); + + if ((objPtr->length == 0) || + ((objPtr->length == 2) && (str[0] == '0') && strchr("xXbBoOdD", str[1]))) { + *intPtr = 0; + return TCL_OK; + } else if ((objPtr->length == 1) && strchr("+-", str[0])) { + *intPtr = (str[0] == '+'); + return TCL_OK; + } + return TCL_ERROR; +} + +int +GetInvalidWideFromObj(Tcl_Obj *objPtr, Tcl_WideInt *widePtr) +{ + int intValue; + + if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) { + return TCL_ERROR; + } + *widePtr = intValue; + return TCL_OK; +} + +/* + * This function checks for double representations, which are valid + * when linking with C variables, but which are invalid in other + * contexts in Tcl. Handled are "+", "-", "", ".", "0x", "0b" and "0o" + * (upper- and lowercase) and sequences like "1e-". See bug [39f6304c2e]. + */ +int +GetInvalidDoubleFromObj(Tcl_Obj *objPtr, double *doublePtr) +{ + int intValue; + + if (objPtr->typePtr == &invalidRealType) { + goto gotdouble; + } + if (GetInvalidIntFromObj(objPtr, &intValue) == TCL_OK) { + *doublePtr = (double) intValue; + return TCL_OK; + } + if (SetInvalidRealFromAny(NULL, objPtr) == TCL_OK) { + gotdouble: + *doublePtr = objPtr->internalRep.doubleValue; + return TCL_OK; + } + return TCL_ERROR; +} /* * Local Variables: diff --git a/generic/tclListObj.c b/generic/tclListObj.c index bd2dbc4..8314306 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -137,7 +137,7 @@ NewListIntRep( * Creates a list internal rep with space for objc elements. objc * must be > 0. If objv!=NULL, initializes with the first objc values * in that array. If objv==NULL, initalize list internal rep to have - * 0 elements, with space to add objc more. + * 0 elements, with space to add objc more. * * Results: * A new List struct with refCount 0 is returned. If some failure @@ -374,7 +374,7 @@ Tcl_SetListObj( listRepPtr = NewListIntRep(objc, objv, 1); ListSetIntRep(objPtr, listRepPtr); } else { - objPtr->bytes = tclEmptyStringRep; + objPtr->bytes = &tclEmptyString; objPtr->length = 0; } } @@ -423,6 +423,87 @@ TclListObjCopy( /* *---------------------------------------------------------------------- * + * TclListObjRange -- + * + * Makes a slice of a list value. + * *listPtr must be known to be a valid list. + * + * Results: + * Returns a pointer to the sliced list. + * This may be a new object or the same object if not shared. + * + * Side effects: + * The possible conversion of the object referenced by listPtr + * to a list object. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclListObjRange( + Tcl_Obj *listPtr, /* List object to take a range from. */ + int fromIdx, /* Index of first element to include. */ + int toIdx) /* Index of last element to include. */ +{ + Tcl_Obj **elemPtrs; + int listLen, i, newLen; + List *listRepPtr; + + TclListObjGetElements(NULL, listPtr, &listLen, &elemPtrs); + + if (fromIdx < 0) { + fromIdx = 0; + } + if (toIdx >= listLen) { + toIdx = listLen-1; + } + if (fromIdx > toIdx) { + return Tcl_NewObj(); + } + + newLen = toIdx - fromIdx + 1; + + if (Tcl_IsShared(listPtr) || + ((ListRepPtr(listPtr)->refCount > 1))) { + return Tcl_NewListObj(newLen, &elemPtrs[fromIdx]); + } + + /* + * In-place is possible. + */ + + /* + * Even if nothing below cause any changes, we still want the + * string-canonizing effect of [lrange 0 end]. + */ + + TclInvalidateStringRep(listPtr); + + /* + * Delete elements that should not be included. + */ + + for (i = 0; i < fromIdx; i++) { + TclDecrRefCount(elemPtrs[i]); + } + for (i = toIdx + 1; i < listLen; i++) { + TclDecrRefCount(elemPtrs[i]); + } + + if (fromIdx > 0) { + memmove(elemPtrs, &elemPtrs[fromIdx], + (size_t) newLen * sizeof(Tcl_Obj*)); + } + + listRepPtr = ListRepPtr(listPtr); + listRepPtr->elemCount = newLen; + + return listPtr; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_ListObjGetElements -- * * This function returns an (objc,objv) array of the elements in a list @@ -465,7 +546,7 @@ Tcl_ListObjGetElements( if (listPtr->typePtr != &tclListType) { int result; - if (listPtr->bytes == tclEmptyStringRep) { + if (listPtr->bytes == &tclEmptyString) { *objcPtr = 0; *objvPtr = NULL; return TCL_OK; @@ -575,7 +656,7 @@ Tcl_ListObjAppendElement( if (listPtr->typePtr != &tclListType) { int result; - if (listPtr->bytes == tclEmptyStringRep) { + if (listPtr->bytes == &tclEmptyString) { Tcl_SetListObj(listPtr, 1, &objPtr); return TCL_OK; } @@ -739,7 +820,7 @@ Tcl_ListObjIndex( if (listPtr->typePtr != &tclListType) { int result; - if (listPtr->bytes == tclEmptyStringRep) { + if (listPtr->bytes == &tclEmptyString) { *objPtrPtr = NULL; return TCL_OK; } @@ -792,7 +873,7 @@ Tcl_ListObjLength( if (listPtr->typePtr != &tclListType) { int result; - if (listPtr->bytes == tclEmptyStringRep) { + if (listPtr->bytes == &tclEmptyString) { *intPtr = 0; return TCL_OK; } @@ -857,13 +938,13 @@ Tcl_ListObjReplace( { List *listRepPtr; register Tcl_Obj **elemPtrs; - int numElems, numRequired, numAfterLast, start, i, j, isShared; + int needGrow, numElems, numRequired, numAfterLast, start, i, j, isShared; if (Tcl_IsShared(listPtr)) { Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace"); } if (listPtr->typePtr != &tclListType) { - if (listPtr->bytes == tclEmptyStringRep) { + if (listPtr->bytes == &tclEmptyString) { if (!objc) { return TCL_OK; } @@ -897,23 +978,55 @@ Tcl_ListObjReplace( } if (count < 0) { count = 0; - } else if (numElems < first+count || first+count < 0) { - /* - * The 'first+count < 0' condition here guards agains integer - * overflow in determining 'first+count'. - */ + } else if (first > INT_MAX - count /* Handle integer overflow */ + || numElems < first+count) { count = numElems - first; } + if (objc > LIST_MAX - (numElems - count)) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "max length of a Tcl list (%d elements) exceeded", + LIST_MAX)); + } + return TCL_ERROR; + } isShared = (listRepPtr->refCount > 1); - numRequired = numElems - count + objc; + numRequired = numElems - count + objc; /* Known <= LIST_MAX */ + needGrow = numRequired > listRepPtr->maxElemCount; for (i = 0; i < objc; i++) { Tcl_IncrRefCount(objv[i]); } - if ((numRequired <= listRepPtr->maxElemCount) && !isShared) { + if (needGrow && !isShared) { + /* Try to use realloc */ + List *newPtr = NULL; + int attempt = 2 * numRequired; + if (attempt <= LIST_MAX) { + newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt)); + } + if (newPtr == NULL) { + attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH; + if (attempt > LIST_MAX) { + attempt = LIST_MAX; + } + newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt)); + } + if (newPtr == NULL) { + attempt = numRequired; + newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt)); + } + if (newPtr) { + listRepPtr = newPtr; + listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr; + elemPtrs = &listRepPtr->elements; + listRepPtr->maxElemCount = attempt; + needGrow = numRequired > listRepPtr->maxElemCount; + } + } + if (!needGrow && !isShared) { int shift; /* @@ -950,7 +1063,7 @@ Tcl_ListObjReplace( Tcl_Obj **oldPtrs = elemPtrs; int newMax; - if (numRequired > listRepPtr->maxElemCount){ + if (needGrow){ newMax = 2 * numRequired; } else { newMax = listRepPtr->maxElemCount; @@ -1133,17 +1246,11 @@ TclLindexList( return TclLindexFlat(interp, listPtr, 1, &argPtr); } - if (indexListCopy->typePtr == &tclListType) { - List *listRepPtr = ListRepPtr(indexListCopy); - - listPtr = TclLindexFlat(interp, listPtr, listRepPtr->elemCount, - &listRepPtr->elements); - } else { - int indexCount = -1; /* Size of the array of list indices. */ - Tcl_Obj **indices = NULL; - /* Array of list indices. */ + { + int indexCount = -1; /* Size of the array of list indices. */ + Tcl_Obj **indices = NULL; /* Array of list indices. */ - Tcl_ListObjGetElements(NULL, indexListCopy, &indexCount, &indices); + TclListObjGetElements(NULL, indexListCopy, &indexCount, &indices); listPtr = TclLindexFlat(interp, listPtr, indexCount, indices); } Tcl_DecrRefCount(indexListCopy); @@ -1618,7 +1725,7 @@ TclListObjSetElement( if (listPtr->typePtr != &tclListType) { int result; - if (listPtr->bytes == tclEmptyStringRep) { + if (listPtr->bytes == &tclEmptyString) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("list index out of range", -1)); @@ -1726,7 +1833,7 @@ FreeListInternalRep( { List *listRepPtr = ListRepPtr(listPtr); - if (--listRepPtr->refCount <= 0) { + if (listRepPtr->refCount-- <= 1) { Tcl_Obj **elemPtrs = &listRepPtr->elements; int i, numElems = listRepPtr->elemCount; @@ -1866,7 +1973,7 @@ SetListFromAny( while (--elemPtrs >= &listRepPtr->elements) { Tcl_DecrRefCount(*elemPtrs); } - ckfree((char *) listRepPtr); + ckfree(listRepPtr); return TCL_ERROR; } if (elemStart == limit) { @@ -1925,8 +2032,8 @@ static void UpdateStringOfList( Tcl_Obj *listPtr) /* List object with string rep to update. */ { -# define LOCAL_SIZE 20 - int localFlags[LOCAL_SIZE], *flagPtr = NULL; +# define LOCAL_SIZE 64 + char localFlags[LOCAL_SIZE], *flagPtr = NULL; List *listRepPtr = ListRepPtr(listPtr); int numElems = listRepPtr->elemCount; int i, length, bytesNeeded = 0; @@ -1947,7 +2054,7 @@ UpdateStringOfList( */ if (numElems == 0) { - listPtr->bytes = tclEmptyStringRep; + listPtr->bytes = &tclEmptyString; listPtr->length = 0; return; } @@ -1963,7 +2070,7 @@ UpdateStringOfList( * We know numElems <= LIST_MAX, so this is safe. */ - flagPtr = ckalloc(numElems * sizeof(int)); + flagPtr = ckalloc(numElems); } elemPtrs = &listRepPtr->elements; for (i = 0; i < numElems; i++) { diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index 11da6f8..003884d 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -174,7 +174,7 @@ TclDeleteLiteralTable( Tcl_Obj * TclCreateLiteral( Interp *iPtr, - char *bytes, /* The start of the string. Note that this is + const char *bytes, /* The start of the string. Note that this is * not a NUL-terminated string. */ int length, /* Number of bytes in the string. */ unsigned hash, /* The string's hash. If -1, it will be @@ -186,7 +186,7 @@ TclCreateLiteral( { LiteralTable *globalTablePtr = &iPtr->literalTable; LiteralEntry *globalPtr; - int globalHash; + unsigned int globalHash; Tcl_Obj *objPtr; /* @@ -214,7 +214,7 @@ TclCreateLiteral( if (globalPtrPtr) { *globalPtrPtr = globalPtr; } - if (flags & LITERAL_ON_HEAP) { + if ((flags & LITERAL_ON_HEAP)) { ckfree(bytes); } globalPtr->refCount++; @@ -222,26 +222,40 @@ TclCreateLiteral( } } if (!newPtr) { - if (flags & LITERAL_ON_HEAP) { + if ((flags & LITERAL_ON_HEAP)) { ckfree(bytes); } return NULL; } /* - * The literal is new to the interpreter. Add it to the global literal - * table. + * The literal is new to the interpreter. */ TclNewObj(objPtr); - Tcl_IncrRefCount(objPtr); - if (flags & LITERAL_ON_HEAP) { - objPtr->bytes = bytes; + if ((flags & LITERAL_ON_HEAP)) { + objPtr->bytes = (char *) bytes; objPtr->length = length; } else { TclInitStringRep(objPtr, bytes, length); } + /* Should the new literal be shared globally? */ + + if ((flags & LITERAL_UNSHARED)) { + /* + * No, do *not* add it the global literal table + * Make clear, that no global value is returned + */ + if (globalPtrPtr != NULL) { + *globalPtrPtr = NULL; + } + return objPtr; + } + + /* + * Yes, add it to the global literal table. + */ #ifdef TCL_COMPILE_DEBUG if (LookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) { Tcl_Panic("%s: literal \"%.*s\" found globally but shouldn't be", @@ -251,6 +265,7 @@ TclCreateLiteral( globalPtr = ckalloc(sizeof(LiteralEntry)); globalPtr->objPtr = objPtr; + Tcl_IncrRefCount(objPtr); globalPtr->refCount = 1; globalPtr->nsPtr = nsPtr; globalPtr->nextPtr = globalTablePtr->buckets[globalHash]; @@ -358,9 +373,9 @@ TclFetchLiteral( int TclRegisterLiteral( - CompileEnv *envPtr, /* Points to the CompileEnv in whose object + void *ePtr, /* Points to the CompileEnv in whose object * array an object is found or created. */ - register char *bytes, /* Points to string for which to find or + register const char *bytes, /* Points to string for which to find or * create an object in CompileEnv's object * array. */ int length, /* Number of bytes in the string. If < 0, the @@ -372,12 +387,14 @@ TclRegisterLiteral( * the literal should not be shared accross * namespaces. */ { + CompileEnv *envPtr = ePtr; Interp *iPtr = envPtr->iPtr; LiteralTable *localTablePtr = &envPtr->localLitTable; LiteralEntry *globalPtr, *localPtr; Tcl_Obj *objPtr; unsigned hash; - int localHash, objIndex, new; + unsigned int localHash; + int objIndex, new; Namespace *nsPtr; if (length < 0) { @@ -397,7 +414,7 @@ TclRegisterLiteral( if ((objPtr->length == length) && ((length == 0) || ((objPtr->bytes[0] == bytes[0]) && (memcmp(objPtr->bytes, bytes, (unsigned) length) == 0)))) { - if (flags & LITERAL_ON_HEAP) { + if ((flags & LITERAL_ON_HEAP)) { ckfree(bytes); } objIndex = (localPtr - envPtr->literalArrayPtr); @@ -416,7 +433,7 @@ TclRegisterLiteral( * the namespace as the interp's global NS. */ - if (flags & LITERAL_CMD_NAME) { + if ((flags & LITERAL_CMD_NAME)) { if ((length >= 2) && (bytes[0] == ':') && (bytes[1] == ':')) { nsPtr = iPtr->globalNsPtr; } else { @@ -425,17 +442,18 @@ TclRegisterLiteral( } else { nsPtr = NULL; } - + /* * Is it in the interpreter's global literal table? If not, create it. */ + globalPtr = NULL; objPtr = TclCreateLiteral(iPtr, bytes, length, hash, &new, nsPtr, flags, &globalPtr); objIndex = AddLocalLiteralEntry(envPtr, objPtr, localHash); #ifdef TCL_COMPILE_DEBUG - if (globalPtr->refCount < 1) { + if (globalPtr != NULL && globalPtr->refCount < 1) { Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d", "TclRegisterLiteral", (length>60? 60 : length), bytes, globalPtr->refCount); @@ -520,7 +538,8 @@ TclHideLiteral( { LiteralEntry **nextPtrPtr, *entryPtr, *lPtr; LiteralTable *localTablePtr = &envPtr->localLitTable; - int localHash, length; + unsigned int localHash; + int length; const char *bytes; Tcl_Obj *newObjPtr; @@ -539,7 +558,7 @@ TclHideLiteral( lPtr->objPtr = newObjPtr; bytes = TclGetStringFromObj(newObjPtr, &length); - localHash = (HashString(bytes, length) & localTablePtr->mask); + localHash = HashString(bytes, length) & localTablePtr->mask; nextPtrPtr = &localTablePtr->buckets[localHash]; for (entryPtr=*nextPtrPtr ; entryPtr!=NULL ; entryPtr=*nextPtrPtr) { @@ -595,7 +614,7 @@ TclAddLiteralObj( lPtr = &envPtr->literalArrayPtr[objIndex]; lPtr->objPtr = objPtr; Tcl_IncrRefCount(objPtr); - lPtr->refCount = -1; /* i.e., unused */ + lPtr->refCount = (size_t)-1; /* i.e., unused */ lPtr->nextPtr = NULL; if (litPtrPtr) { @@ -670,7 +689,7 @@ AddLocalLiteralEntry( } if (!found) { - bytes = Tcl_GetStringFromObj(objPtr, &length); + bytes = TclGetStringFromObj(objPtr, &length); Tcl_Panic("%s: literal \"%.*s\" wasn't found locally", "AddLocalLiteralEntry", (length>60? 60 : length), bytes); } @@ -716,16 +735,22 @@ ExpandLocalLiteralArray( LiteralEntry *currArrayPtr = envPtr->literalArrayPtr; LiteralEntry *newArrayPtr; int i; + unsigned int newSize = (currBytes <= UINT_MAX / 2) ? 2*currBytes : UINT_MAX; + + if (currBytes == newSize) { + Tcl_Panic("max size of Tcl literal array (%d literals) exceeded", + currElems); + } if (envPtr->mallocedLiteralArray) { - newArrayPtr = ckrealloc(currArrayPtr, 2 * currBytes); + newArrayPtr = ckrealloc(currArrayPtr, newSize); } else { /* * envPtr->literalArrayPtr isn't a ckalloc'd pointer, so we must * code a ckrealloc equivalent for ourselves. */ - newArrayPtr = ckalloc(2 * currBytes); + newArrayPtr = ckalloc(newSize); memcpy(newArrayPtr, currArrayPtr, currBytes); envPtr->mallocedLiteralArray = 1; } @@ -750,7 +775,7 @@ ExpandLocalLiteralArray( } envPtr->literalArrayPtr = newArrayPtr; - envPtr->literalArrayEnd = (2 * currElems); + envPtr->literalArrayEnd = newSize / sizeof(LiteralEntry); } /* @@ -786,7 +811,8 @@ TclReleaseLiteral( LiteralTable *globalTablePtr; register LiteralEntry *entryPtr, *prevPtr; const char *bytes; - int length, index; + int length; + unsigned int index; if (iPtr == NULL) { goto done; @@ -805,15 +831,13 @@ TclReleaseLiteral( for (prevPtr=NULL, entryPtr=globalTablePtr->buckets[index]; entryPtr!=NULL ; prevPtr=entryPtr, entryPtr=entryPtr->nextPtr) { if (entryPtr->objPtr == objPtr) { - entryPtr->refCount--; - /* * If the literal is no longer being used by any ByteCode, delete * the entry then remove the reference corresponding to the global * literal table entry (decrement the ref count of the object). */ - if (entryPtr->refCount == 0) { + if (entryPtr->refCount-- <= 1) { if (prevPtr == NULL) { globalTablePtr->buckets[index] = entryPtr->nextPtr; } else { @@ -931,7 +955,8 @@ RebuildLiteralTable( register LiteralEntry *entryPtr; LiteralEntry **bucketPtr; const char *bytes; - int oldSize, count, index, length; + unsigned int oldSize, index; + int count, length; oldSize = tablePtr->numBuckets; oldBuckets = tablePtr->buckets; @@ -941,6 +966,16 @@ RebuildLiteralTable( * constants for new array size. */ + if (oldSize > UINT_MAX/(4 * sizeof(LiteralEntry *))) { + /* + * Memory allocator limitations will not let us create the + * next larger table size. Best option is to limp along + * with what we have. + */ + + return; + } + tablePtr->numBuckets *= 4; tablePtr->buckets = ckalloc(tablePtr->numBuckets * sizeof(LiteralEntry*)); for (count=tablePtr->numBuckets, newChainPtr=tablePtr->buckets; @@ -990,7 +1025,7 @@ RebuildLiteralTable( * Results: * None. * - * Side effects: + * Side effects: * Resets the internal representation of the CmdName Tcl_Obj * using TclFreeIntRep(). * @@ -1007,7 +1042,7 @@ TclInvalidateCmdLiteral( * invalidate a cmd literal. */ { Interp *iPtr = (Interp *) interp; - Tcl_Obj *literalObjPtr = TclCreateLiteral(iPtr, (char *) name, + Tcl_Obj *literalObjPtr = TclCreateLiteral(iPtr, name, strlen(name), -1, NULL, nsPtr, 0, NULL); if (literalObjPtr != NULL) { @@ -1129,18 +1164,11 @@ TclVerifyLocalLiteralTable( localPtr=localPtr->nextPtr) { count++; if (localPtr->refCount != -1) { - bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length); + bytes = TclGetStringFromObj(localPtr->objPtr, &length); Tcl_Panic("%s: local literal \"%.*s\" had bad refCount %d", "TclVerifyLocalLiteralTable", (length>60? 60 : length), bytes, localPtr->refCount); } - if (LookupLiteralEntry((Tcl_Interp *) envPtr->iPtr, - localPtr->objPtr) == NULL) { - bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length); - Tcl_Panic("%s: local literal \"%.*s\" is not global", - "TclVerifyLocalLiteralTable", - (length>60? 60 : length), bytes); - } if (localPtr->objPtr->bytes == NULL) { Tcl_Panic("%s: literal has NULL string rep", "TclVerifyLocalLiteralTable"); @@ -1187,7 +1215,7 @@ TclVerifyGlobalLiteralTable( globalPtr=globalPtr->nextPtr) { count++; if (globalPtr->refCount < 1) { - bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length); + bytes = TclGetStringFromObj(globalPtr->objPtr, &length); Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d", "TclVerifyGlobalLiteralTable", (length>60? 60 : length), bytes, globalPtr->refCount); diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 5cacab1..77e6425 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -130,7 +130,7 @@ Tcl_LoadObjCmd( Tcl_PackageInitProc *initProc; const char *p, *fullFileName, *packageName; Tcl_LoadHandle loadHandle; - Tcl_UniChar ch; + Tcl_UniChar ch = 0; unsigned len; int index, flags = 0; Tcl_Obj *const *savedobjv = objv; @@ -336,7 +336,7 @@ Tcl_LoadObjCmd( } #endif /* __CYGWIN__ */ for (p = pkgGuess; *p != 0; p += offset) { - offset = Tcl_UtfToUniChar(p, &ch); + offset = TclUtfToUniChar(p, &ch); if ((ch > 0x100) || !(isalpha(UCHAR(ch)) /* INTL: ISO only */ || (UCHAR(ch) == '_'))) { @@ -470,6 +470,19 @@ Tcl_LoadObjCmd( */ if (code != TCL_OK) { +#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 + Interp *iPtr = (Interp *) target; + if (iPtr->result && *(iPtr->result) && !iPtr->freeProc) { + /* + * A call to Tcl_InitStubs() determined the caller extension and + * this interp are incompatible in their stubs mechanisms, and + * recorded the error in the oldest legacy place we have to do so. + */ + Tcl_SetObjResult(target, Tcl_NewStringObj(iPtr->result, -1)); + iPtr->result = &tclEmptyString; + iPtr->freeProc = NULL; + } +#endif /* defined(TCL_NO_DEPRECATED) */ Tcl_TransferResult(target, code, interp); goto done; } @@ -830,7 +843,7 @@ Tcl_UnloadObjCmd( * Unload the shared library from the application memory... */ -#if defined(TCL_UNLOAD_DLLS) || defined(__WIN32__) +#if defined(TCL_UNLOAD_DLLS) || defined(_WIN32) /* * Some Unix dlls are poorly behaved - registering things like atexit * calls that can't be unregistered. If you unload such dlls, you get @@ -998,7 +1011,7 @@ Tcl_StaticPackage( } /* - * Package isn't loade in the current interp yet. Mark it as now being + * Package isn't loaded in the current interp yet. Mark it as now being * loaded. */ @@ -1012,10 +1025,10 @@ Tcl_StaticPackage( /* *---------------------------------------------------------------------- * - * TclGetLoadedPackages -- + * TclGetLoadedPackages, TclGetLoadedPackagesEx -- * * This function returns information about all of the files that are - * loaded (either in a particular intepreter, or for all interpreters). + * loaded (either in a particular interpreter, or for all interpreters). * * Results: * The return value is a standard Tcl completion code. If successful, a @@ -1039,16 +1052,27 @@ TclGetLoadedPackages( * otherwise, just return info about this * interpreter. */ { + return TclGetLoadedPackagesEx(interp, targetName, NULL); +} + +int +TclGetLoadedPackagesEx( + Tcl_Interp *interp, /* Interpreter in which to return information + * or error message. */ + const char *targetName, /* Name of target interpreter or NULL. If + * NULL, return info about all interps; + * otherwise, just return info about this + * interpreter. */ + const char *packageName) /* Package name or NULL. If NULL, return info + * for all packages. + */ +{ Tcl_Interp *target; LoadedPackage *pkgPtr; InterpPackage *ipPtr; Tcl_Obj *resultObj, *pkgDesc[2]; if (targetName == NULL) { - /* - * Return information about all of the available packages. - */ - resultObj = Tcl_NewObj(); Tcl_MutexLock(&packageMutex); for (pkgPtr = firstPackagePtr; pkgPtr != NULL; @@ -1063,16 +1087,38 @@ TclGetLoadedPackages( return TCL_OK; } - /* - * Return information about only the packages that are loaded in a given - * interpreter. - */ - target = Tcl_GetSlave(interp, targetName); if (target == NULL) { return TCL_ERROR; } ipPtr = Tcl_GetAssocData(target, "tclLoad", NULL); + + /* + * Return information about all of the available packages. + */ + if (packageName) { + resultObj = NULL; + + for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { + pkgPtr = ipPtr->pkgPtr; + + if (!strcmp(packageName, pkgPtr->packageName)) { + resultObj = Tcl_NewStringObj(pkgPtr->fileName, -1); + break; + } + } + + if (resultObj) { + Tcl_SetObjResult(interp, resultObj); + } + return TCL_OK; + } + + /* + * Return information about only the packages that are loaded in a given + * interpreter. + */ + resultObj = Tcl_NewObj(); for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { pkgPtr = ipPtr->pkgPtr; @@ -1151,7 +1197,7 @@ TclFinalizeLoad(void) pkgPtr = firstPackagePtr; firstPackagePtr = pkgPtr->nextPtr; -#if defined(TCL_UNLOAD_DLLS) || defined(__WIN32__) +#if defined(TCL_UNLOAD_DLLS) || defined(_WIN32) /* * Some Unix dlls are poorly behaved - registering things like atexit * calls that can't be unregistered. If you unload such dlls, you get diff --git a/generic/tclLoadNone.c b/generic/tclLoadNone.c index c22c4c4..6af5c4f 100644 --- a/generic/tclLoadNone.c +++ b/generic/tclLoadNone.c @@ -45,9 +45,11 @@ TclpDlopen( * file. */ int flags) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "dynamic loading is not currently available on this system", - -1)); + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "dynamic loading is not currently available on this system", + -1)); + } return TCL_ERROR; } @@ -104,11 +106,15 @@ TclpLoadMemory( int size, /* Dummy: unused by this implementation */ int codeSize, /* Dummy: unused by this implementation */ Tcl_LoadHandle *loadHandle, /* Dummy: unused by this implementation */ - Tcl_FSUnloadFileProc **unloadProcPtr) + Tcl_FSUnloadFileProc **unloadProcPtr, + /* Dummy: unused by this implementation */ + int flags) /* Dummy: unused by this implementation */ { - Tcl_SetObjResult(interp, Tcl_NewStringObj("dynamic loading from memory " - "is not available on this system", -1)); + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("dynamic loading from memory " + "is not available on this system", -1)); + } return TCL_ERROR; } diff --git a/generic/tclMain.c b/generic/tclMain.c index faea75a..9380fb2 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -47,7 +47,7 @@ * we have to translate that to strcmp here. */ -#ifndef __WIN32__ +#ifndef _WIN32 # define TCHAR char # define TEXT(arg) arg # define _tcscmp strcmp @@ -80,7 +80,10 @@ NewNativeObj( * source directory to make their own modified versions). */ +#if defined _MSC_VER && _MSC_VER < 1900 +/* isatty is always defined on MSVC 14.0, but not necessarily as CRTIMPORT. */ extern CRTIMPORT int isatty(int fd); +#endif /* * The thread-local variables for this file's functions. @@ -109,7 +112,7 @@ typedef enum { PROMPT_CONTINUE /* Print prompt for command continuation */ } PromptType; -typedef struct InteractiveState { +typedef struct { Tcl_Channel input; /* The standard input channel from which lines * are read. */ int tty; /* Non-zero means standard input is a @@ -243,7 +246,7 @@ Tcl_SourceRCFile( const char *fileName; Tcl_Channel chan; - fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY); + fileName = Tcl_GetVar2(interp, "tcl_rcFileName", NULL, TCL_GLOBAL_ONLY); if (fileName != NULL) { Tcl_Channel c; const char *fullName; @@ -280,7 +283,7 @@ Tcl_SourceRCFile( /*---------------------------------------------------------------------- * - * Tcl_Main, Tcl_MainEx -- + * Tcl_MainEx -- * * Main program for tclsh and most other Tcl-based applications. * @@ -529,7 +532,7 @@ Tcl_MainEx( * error messages troubles deeper in, so lop it back off. */ - Tcl_GetStringFromObj(is.commandPtr, &length); + TclGetStringFromObj(is.commandPtr, &length); Tcl_SetObjLength(is.commandPtr, --length); code = Tcl_RecordAndEvalObj(interp, is.commandPtr, TCL_EVAL_GLOBAL); @@ -546,7 +549,7 @@ Tcl_MainEx( } else if (is.tty) { resultPtr = Tcl_GetObjResult(interp); Tcl_IncrRefCount(resultPtr); - Tcl_GetStringFromObj(resultPtr, &length); + TclGetStringFromObj(resultPtr, &length); chan = Tcl_GetStdChannel(TCL_STDOUT); if ((length > 0) && chan) { Tcl_WriteObj(chan, resultPtr); @@ -616,7 +619,7 @@ Tcl_MainEx( if (!Tcl_InterpDeleted(interp) && !Tcl_LimitExceeded(interp)) { Tcl_Obj *cmd = Tcl_ObjPrintf("exit %d", exitCode); - + Tcl_IncrRefCount(cmd); Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL); Tcl_DecrRefCount(cmd); @@ -631,21 +634,6 @@ Tcl_MainEx( Tcl_Exit(exitCode); } - -#if (TCL_MAJOR_VERSION == 8) && !defined(UNICODE) -#undef Tcl_Main -extern DLLEXPORT void -Tcl_Main( - int argc, /* Number of arguments. */ - char **argv, /* Array of argument strings. */ - Tcl_AppInitProc *appInitProc) - /* Application-specific initialization - * function to call after most initialization - * but before starting to execute commands. */ -{ - Tcl_MainEx(argc, argv, appInitProc, Tcl_CreateInterp()); -} -#endif /* TCL_MAJOR_VERSION == 8 && !UNICODE */ #ifndef TCL_ASCII_MAIN @@ -729,7 +717,7 @@ TclFullFinalizationRequested(void) const char *fin; Tcl_DString ds; int finalize = 0; - + fin = TclGetEnv("TCL_FINALIZE_ON_EXIT", &ds); finalize = ((fin != NULL) && strcmp(fin, "0")); if (fin != NULL) { @@ -805,7 +793,7 @@ StdinProc( goto prompt; } isPtr->prompt = PROMPT_START; - Tcl_GetStringFromObj(commandPtr, &length); + TclGetStringFromObj(commandPtr, &length); Tcl_SetObjLength(commandPtr, --length); /* @@ -836,7 +824,7 @@ StdinProc( chan = Tcl_GetStdChannel(TCL_STDOUT); Tcl_IncrRefCount(resultPtr); - Tcl_GetStringFromObj(resultPtr, &length); + TclGetStringFromObj(resultPtr, &length); if ((length > 0) && (chan != NULL)) { Tcl_WriteObj(chan, resultPtr); Tcl_WriteChars(chan, "\n", 1); diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index cc2f953..2b8dd51 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -31,8 +31,8 @@ * limited to a single interpreter. */ -typedef struct ThreadSpecificData { - long numNsCreated; /* Count of the number of namespaces created +typedef struct { + unsigned long numNsCreated; /* Count of the number of namespaces created * within the thread. This value is used as a * unique id for each namespace. Cannot be * per-interp because the nsId is used to @@ -59,7 +59,7 @@ typedef struct ResolvedNsName { * the name was resolved. NULL if the name is * fully qualified and thus the resolution * does not depend on the context. */ - int refCount; /* Reference count: 1 for each nsName object + size_t refCount; /* Reference count: 1 for each nsName object * that has a pointer to this ResolvedNsName * structure as its internal rep. This * structure can be freed when refCount @@ -169,7 +169,7 @@ static const EnsembleImplMap defaultNamespaceMap[] = { {"forget", NamespaceForgetCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, {"import", NamespaceImportCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, {"inscope", NamespaceInscopeCmd, NULL, NRNamespaceInscopeCmd, NULL, 0}, - {"origin", NamespaceOriginCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"origin", NamespaceOriginCmd, TclCompileNamespaceOriginCmd, NULL, NULL, 0}, {"parent", NamespaceParentCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"path", NamespacePathCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"qualifiers", NamespaceQualifiersCmd, TclCompileNamespaceQualifiersCmd, NULL, NULL, 0}, @@ -341,7 +341,7 @@ Tcl_PushCallFrame( framePtr->clientData = NULL; framePtr->localCachePtr = NULL; framePtr->tailcallPtr = NULL; - + /* * Push the new call frame onto the interpreter's stack of procedure call * frames making it the current frame. @@ -400,7 +400,7 @@ Tcl_PopCallFrame( } if (framePtr->numCompiledLocals > 0) { TclDeleteCompiledLocalVars(iPtr, framePtr); - if (--framePtr->localCachePtr->refCount == 0) { + if (framePtr->localCachePtr->refCount-- <= 1) { TclFreeLocalCache(interp, framePtr->localCachePtr); } framePtr->localCachePtr = NULL; @@ -671,6 +671,10 @@ Tcl_CreateNamespace( Tcl_DString *namePtr, *buffPtr; int newEntry, nameLen; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + const char *nameStr; + Tcl_DString tmpBuffer; + + Tcl_DStringInit(&tmpBuffer); /* * If there is no active namespace, the interpreter is being initialized. @@ -684,49 +688,78 @@ Tcl_CreateNamespace( parentPtr = NULL; simpleName = ""; - } else if (*name == '\0') { + goto doCreate; + } + + /* + * Ensure that there are no trailing colons as that causes chaos when a + * deleteProc is specified. [Bug d614d63989] + */ + + if (deleteProc != NULL) { + nameStr = name + strlen(name) - 2; + if (nameStr >= name && nameStr[1] == ':' && nameStr[0] == ':') { + Tcl_DStringAppend(&tmpBuffer, name, -1); + while ((nameLen = Tcl_DStringLength(&tmpBuffer)) > 0 + && Tcl_DStringValue(&tmpBuffer)[nameLen-1] == ':') { + Tcl_DStringSetLength(&tmpBuffer, nameLen-1); + } + name = Tcl_DStringValue(&tmpBuffer); + } + } + + /* + * If we've ended up with an empty string now, we're attempting to create + * the global namespace despite the global namespace existing. That's + * naughty! + */ + + if (*name == '\0') { Tcl_SetObjResult(interp, Tcl_NewStringObj("can't create namespace" " \"\": only global namespace can have empty name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", "CREATEGLOBAL", NULL); + Tcl_DStringFree(&tmpBuffer); return NULL; - } else { - /* - * Find the parent for the new namespace. - */ + } - TclGetNamespaceForQualName(interp, name, NULL, TCL_CREATE_NS_IF_UNKNOWN, - &parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName); + /* + * Find the parent for the new namespace. + */ - /* - * If the unqualified name at the end is empty, there were trailing - * "::"s after the namespace's name which we ignore. The new namespace - * was already (recursively) created and is pointed to by parentPtr. - */ + TclGetNamespaceForQualName(interp, name, NULL, TCL_CREATE_NS_IF_UNKNOWN, + &parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName); - if (*simpleName == '\0') { - return (Tcl_Namespace *) parentPtr; - } + /* + * If the unqualified name at the end is empty, there were trailing "::"s + * after the namespace's name which we ignore. The new namespace was + * already (recursively) created and is pointed to by parentPtr. + */ - /* - * Check for a bad namespace name and make sure that the name does not - * already exist in the parent namespace. - */ + if (*simpleName == '\0') { + Tcl_DStringFree(&tmpBuffer); + return (Tcl_Namespace *) parentPtr; + } - if ( + /* + * Check for a bad namespace name and make sure that the name does not + * already exist in the parent namespace. + */ + + if ( #ifndef BREAK_NAMESPACE_COMPAT - Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL + Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL #else - parentPtr->childTablePtr != NULL && - Tcl_FindHashEntry(parentPtr->childTablePtr, simpleName) != NULL + parentPtr->childTablePtr != NULL && + Tcl_FindHashEntry(parentPtr->childTablePtr, simpleName) != NULL #endif - ) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't create namespace \"%s\": already exists", name)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", - "CREATEEXISTING", NULL); - return NULL; - } + ) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create namespace \"%s\": already exists", name)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", + "CREATEEXISTING", NULL); + Tcl_DStringFree(&tmpBuffer); + return NULL; } /* @@ -734,6 +767,7 @@ Tcl_CreateNamespace( * of namespaces created. */ + doCreate: nsPtr = ckalloc(sizeof(Namespace)); nameLen = strlen(simpleName) + 1; nsPtr->name = ckalloc(nameLen); @@ -829,6 +863,7 @@ Tcl_CreateNamespace( Tcl_DStringFree(&buffer1); Tcl_DStringFree(&buffer2); + Tcl_DStringFree(&tmpBuffer); /* * If compilation of commands originating from the parent NS is @@ -879,6 +914,11 @@ Tcl_DeleteNamespace( Command *cmdPtr; /* + * Ensure that this namespace doesn't get deallocated in the meantime. + */ + nsPtr->refCount++; + + /* * Give anyone interested - notably TclOO - a chance to use this namespace * normally despite the fact that the namespace is going to go. Allows the * calling of destructors. Will only be called once (unless re-established @@ -1010,16 +1050,7 @@ Tcl_DeleteNamespace( #endif Tcl_DeleteHashTable(&nsPtr->cmdTable); - /* - * If the reference count is 0, then discard the namespace. - * Otherwise, mark it as "dead" so that it can't be used. - */ - - if (nsPtr->refCount == 0) { - NamespaceFree(nsPtr); - } else { - nsPtr->flags |= NS_DEAD; - } + nsPtr ->flags |= NS_DEAD; } else { /* * Restore the ::errorInfo and ::errorCode traces. @@ -1036,6 +1067,7 @@ Tcl_DeleteNamespace( nsPtr->flags &= ~(NS_DYING|NS_KILLED); } } + TclNsDecrRefCount(nsPtr); } /* @@ -1068,8 +1100,6 @@ TclTeardownNamespace( Interp *iPtr = (Interp *) nsPtr->interp; register Tcl_HashEntry *entryPtr; Tcl_HashSearch search; - Tcl_Namespace *childNsPtr; - Tcl_Command cmd; int i; /* @@ -1084,16 +1114,31 @@ TclTeardownNamespace( /* * Delete all commands in this namespace. Be careful when traversing the * hash table: when each command is deleted, it removes itself from the - * command table. - * - * Don't optimize to Tcl_NextHashEntry() because of traces. + * command table. Because of traces (and the desire to avoid the quadratic + * problems of just using Tcl_FirstHashEntry over and over, [Bug + * f97d4ee020]) we copy to a temporary array and then delete all those + * commands. */ - for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); - entryPtr != NULL; - entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search)) { - cmd = Tcl_GetHashValue(entryPtr); - Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, cmd); + while (nsPtr->cmdTable.numEntries > 0) { + int length = nsPtr->cmdTable.numEntries; + Command **cmds = TclStackAlloc((Tcl_Interp *) iPtr, + sizeof(Command *) * length); + + i = 0; + for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); + entryPtr != NULL; + entryPtr = Tcl_NextHashEntry(&search)) { + cmds[i] = Tcl_GetHashValue(entryPtr); + cmds[i]->refCount++; + i++; + } + for (i = 0 ; i < length ; i++) { + Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, + (Tcl_Command) cmds[i]); + TclCleanupCommandMacro(cmds[i]); + } + TclStackFree((Tcl_Interp *) iPtr, cmds); } Tcl_DeleteHashTable(&nsPtr->cmdTable); Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS); @@ -1138,25 +1183,54 @@ TclTeardownNamespace( * * BE CAREFUL: When each child is deleted, it will divorce itself from its * parent. You can't traverse a hash table properly if its elements are - * being deleted. We use only the Tcl_FirstHashEntry function to be safe. + * being deleted. Because of traces (and the desire to avoid the + * quadratic problems of just using Tcl_FirstHashEntry over and over, [Bug + * f97d4ee020]) we copy to a temporary array and then delete all those + * namespaces. * - * Don't optimize to Tcl_NextHashEntry() because of traces. + * Important: leave the hash table itself still live. */ #ifndef BREAK_NAMESPACE_COMPAT - for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); - entryPtr != NULL; - entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search)) { - childNsPtr = Tcl_GetHashValue(entryPtr); - Tcl_DeleteNamespace(childNsPtr); + while (nsPtr->childTable.numEntries > 0) { + int length = nsPtr->childTable.numEntries; + Namespace **children = TclStackAlloc((Tcl_Interp *) iPtr, + sizeof(Namespace *) * length); + + i = 0; + for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); + entryPtr != NULL; + entryPtr = Tcl_NextHashEntry(&search)) { + children[i] = Tcl_GetHashValue(entryPtr); + children[i]->refCount++; + i++; + } + for (i = 0 ; i < length ; i++) { + Tcl_DeleteNamespace((Tcl_Namespace *) children[i]); + TclNsDecrRefCount(children[i]); + } + TclStackFree((Tcl_Interp *) iPtr, children); } #else if (nsPtr->childTablePtr != NULL) { - for (entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search); - entryPtr != NULL; - entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr,&search)) { - childNsPtr = Tcl_GetHashValue(entryPtr); - Tcl_DeleteNamespace(childNsPtr); + while (nsPtr->childTablePtr->numEntries > 0) { + int length = nsPtr->childTablePtr->numEntries; + Namespace **children = TclStackAlloc((Tcl_Interp *) iPtr, + sizeof(Namespace *) * length); + + i = 0; + for (entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search); + entryPtr != NULL; + entryPtr = Tcl_NextHashEntry(&search)) { + children[i] = Tcl_GetHashValue(entryPtr); + children[i]->refCount++; + i++; + } + for (i = 0 ; i < length ; i++) { + Tcl_DeleteNamespace((Tcl_Namespace *) children[i]); + TclNsDecrRefCount(children[i]); + } + TclStackFree((Tcl_Interp *) iPtr, children); } } #endif @@ -1247,8 +1321,7 @@ void TclNsDecrRefCount( Namespace *nsPtr) { - nsPtr->refCount--; - if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) { + if ((nsPtr->refCount-- <= 1) && (nsPtr->flags & NS_DEAD)) { NamespaceFree(nsPtr); } } @@ -1940,7 +2013,7 @@ InvokeImportedNRCmd( Command *realCmdPtr = dataPtr->realCmdPtr; TclSkipTailcall(interp); - return Tcl_NRCmdSwap(interp, (Tcl_Command) realCmdPtr, objc, objv, 0); + return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR, realCmdPtr); } int @@ -2346,6 +2419,35 @@ TclGetNamespaceForQualName( /* *---------------------------------------------------------------------- * + * TclEnsureNamespace -- + * + * Provide a namespace that is not deleted. + * + * Value + * + * namespacePtr, if it is not scheduled for deletion, or a pointer to a + * new namespace with the same name otherwise. + * + * Effect + * None. + * + *---------------------------------------------------------------------- + */ +Tcl_Namespace * +TclEnsureNamespace( + Tcl_Interp *interp, + Tcl_Namespace *namespacePtr) +{ + Namespace *nsPtr = (Namespace *) namespacePtr; + if (!(nsPtr->flags & NS_DYING)) { + return namespacePtr; + } + return Tcl_CreateNamespace(interp, nsPtr->fullName, NULL, NULL); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_FindNamespace -- * * Searches for a namespace. @@ -2487,7 +2589,9 @@ Tcl_FindCommand( } if (result == TCL_OK) { + ((Command *)cmd)->flags |= CMD_VIA_RESOLVER; return cmd; + } else if (result != TCL_CONTINUE) { return NULL; } @@ -2558,7 +2662,7 @@ Tcl_FindCommand( Namespace *nsPtr[2]; register int search; - TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, + TclGetNamespaceForQualName(interp, name, cxtNsPtr, flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); /* @@ -2579,6 +2683,7 @@ Tcl_FindCommand( } if (cmdPtr != NULL) { + cmdPtr->flags &= ~CMD_VIA_RESOLVER; return (Tcl_Command) cmdPtr; } @@ -2804,9 +2909,9 @@ GetNamespaceFromObj( resNamePtr = objPtr->internalRep.twoPtrValue.ptr1; nsPtr = resNamePtr->nsPtr; refNsPtr = resNamePtr->refNsPtr; - if (!(nsPtr->flags & NS_DYING) && (interp == nsPtr->interp) && - (!refNsPtr || ((interp == refNsPtr->interp) && - (refNsPtr== (Namespace *) Tcl_GetCurrentNamespace(interp))))){ + if (!(nsPtr->flags & NS_DYING) && (interp == nsPtr->interp) + && (!refNsPtr || (refNsPtr == + (Namespace *) TclGetCurrentNamespace(interp)))) { *nsPtrPtr = (Tcl_Namespace *) nsPtr; return TCL_OK; } @@ -3019,7 +3124,7 @@ NamespaceCodeCmd( */ arg = TclGetStringFromObj(objv[1], &length); - if (*arg==':' && length > 20 + if (*arg==':' && length > 20 && strncmp(arg, "::namespace inscope ", 20) == 0) { Tcl_SetObjResult(interp, objv[1]); return TCL_OK; @@ -3272,20 +3377,10 @@ NRNamespaceEvalCmd( /* This is needed to satisfy GCC 3.3's strict aliasing rules */ framePtrPtr = &framePtr; - result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, + (void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, namespacePtr, /*isProcCallFrame*/ 0); - if (result != TCL_OK) { - return TCL_ERROR; - } - if (iPtr->ensembleRewrite.sourceObjs == NULL) { - framePtr->objc = objc; - framePtr->objv = objv; - } else { - framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs - - iPtr->ensembleRewrite.numInsertedObjs; - framePtr->objv = iPtr->ensembleRewrite.sourceObjs; - } + framePtr->objv = TclFetchEnsembleRoot(interp, objv, objc, &framePtr->objc); if (objc == 3) { /* @@ -3692,8 +3787,7 @@ NRNamespaceInscopeCmd( { Tcl_Namespace *namespacePtr; CallFrame *framePtr, **framePtrPtr; - register Interp *iPtr = (Interp *) interp; - int i, result; + int i; Tcl_Obj *cmdObjPtr; if (objc < 3) { @@ -3715,20 +3809,10 @@ NRNamespaceInscopeCmd( framePtrPtr = &framePtr; /* This is needed to satisfy GCC's * strict aliasing rules. */ - result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, + (void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, namespacePtr, /*isProcCallFrame*/ 0); - if (result != TCL_OK) { - return result; - } - if (iPtr->ensembleRewrite.sourceObjs == NULL) { - framePtr->objc = objc; - framePtr->objv = objv; - } else { - framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs - - iPtr->ensembleRewrite.numInsertedObjs; - framePtr->objv = iPtr->ensembleRewrite.sourceObjs; - } + framePtr->objv = TclFetchEnsembleRoot(interp, objv, objc, &framePtr->objc); /* * Execute the command. If there is just one argument, just treat it as a @@ -4480,8 +4564,8 @@ NamespaceUpvarCmd( savedNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr; otherPtr = TclObjLookupVarEx(interp, objv[0], NULL, - (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access", - /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); + (TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG|TCL_AVOID_RESOLVERS), + "access", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); iPtr->varFramePtr->nsPtr = (Namespace *) savedNsPtr; if (otherPtr == NULL) { return TCL_ERROR; @@ -4610,8 +4694,7 @@ FreeNsNameInternalRep( * references, free it up. */ - resNamePtr->refCount--; - if (resNamePtr->refCount == 0) { + if (resNamePtr->refCount-- <= 1) { /* * Decrement the reference count for the cached namespace. If the * namespace is dead, and there are no more references to it, free @@ -4721,7 +4804,7 @@ SetNsNameFromAny( if ((name[0] == ':') && (name[1] == ':')) { resNamePtr->refNsPtr = NULL; } else { - resNamePtr->refNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + resNamePtr->refNsPtr = (Namespace *) TclGetCurrentNamespace(interp); } resNamePtr->refCount = 1; TclFreeIntRep(objPtr); @@ -4892,7 +4975,7 @@ TclLogCommandInfo( if (Tcl_IsShared(iPtr->errorStack)) { Tcl_Obj *newObj; - + newObj = Tcl_DuplicateObj(iPtr->errorStack); Tcl_DecrRefCount(iPtr->errorStack); Tcl_IncrRefCount(newObj); @@ -4924,7 +5007,7 @@ TclLogCommandInfo( Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewStringObj(command, length)); } - } + } if (!iPtr->framePtr->objc) { /* @@ -4977,7 +5060,7 @@ TclErrorStackResetIf( if (Tcl_IsShared(iPtr->errorStack)) { Tcl_Obj *newObj; - + newObj = Tcl_DuplicateObj(iPtr->errorStack); Tcl_DecrRefCount(iPtr->errorStack); Tcl_IncrRefCount(newObj); @@ -4997,7 +5080,7 @@ TclErrorStackResetIf( Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->innerLiteral); Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewStringObj(msg, length)); - } + } } /* diff --git a/generic/tclNotify.c b/generic/tclNotify.c index a6523fc..e76bca8 100644 --- a/generic/tclNotify.c +++ b/generic/tclNotify.c @@ -813,11 +813,7 @@ Tcl_SetMaxBlockTime( */ if (!tsdPtr->inTraversal) { - if (tsdPtr->blockTimeSet) { - Tcl_SetTimer(&tsdPtr->blockTime); - } else { - Tcl_SetTimer(NULL); - } + Tcl_SetTimer(&tsdPtr->blockTime); } } diff --git a/generic/tclOO.c b/generic/tclOO.c index 1138c99..c8471d5 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -4,6 +4,7 @@ * This file contains the object-system core (NB: not Tcl_Obj, but ::oo) * * Copyright (c) 2005-2012 by Donal K. Fellows + * Copyright (c) 2017 by Nathan Coulter * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -30,6 +31,7 @@ static const struct { {"export", TclOODefineExportObjCmd, 0}, {"forward", TclOODefineForwardObjCmd, 0}, {"method", TclOODefineMethodObjCmd, 0}, + {"private", TclOODefinePrivateObjCmd, 0}, {"renamemethod", TclOODefineRenameMethodObjCmd, 0}, {"self", TclOODefineSelfObjCmd, 0}, {"unexport", TclOODefineUnexportObjCmd, 0}, @@ -40,7 +42,9 @@ static const struct { {"export", TclOODefineExportObjCmd, 1}, {"forward", TclOODefineForwardObjCmd, 1}, {"method", TclOODefineMethodObjCmd, 1}, + {"private", TclOODefinePrivateObjCmd, 1}, {"renamemethod", TclOODefineRenameMethodObjCmd, 1}, + {"self", TclOODefineObjSelfObjCmd, 0}, {"unexport", TclOODefineUnexportObjCmd, 1}, {NULL, NULL, 0} }; @@ -57,7 +61,7 @@ static const struct { static Class * AllocClass(Tcl_Interp *interp, Object *useThisObj); static Object * AllocObject(Tcl_Interp *interp, const char *nameStr, - const char *nsNameStr); + Namespace *nsPtr, const char *nsNameStr); static int CloneClassMethod(Tcl_Interp *interp, Class *clsPtr, Method *mPtr, Tcl_Obj *namePtr, Method **newMPtrPtr); @@ -66,12 +70,12 @@ static int CloneObjectMethod(Tcl_Interp *interp, Object *oPtr, static void DeletedDefineNamespace(ClientData clientData); static void DeletedObjdefNamespace(ClientData clientData); static void DeletedHelpersNamespace(ClientData clientData); -static int FinalizeAlloc(ClientData data[], - Tcl_Interp *interp, int result); -static int FinalizeNext(ClientData data[], - Tcl_Interp *interp, int result); -static int FinalizeObjectCall(ClientData data[], - Tcl_Interp *interp, int result); +static Tcl_NRPostProc FinalizeAlloc; +static Tcl_NRPostProc FinalizeNext; +static Tcl_NRPostProc FinalizeObjectCall; +static inline void InitClassPath(Tcl_Interp * interp, Class *clsPtr); +static void InitClassSystemRoots(Tcl_Interp *interp, + Foundation *fPtr); static int InitFoundation(Tcl_Interp *interp); static void KillFoundation(ClientData clientData, Tcl_Interp *interp); @@ -81,8 +85,10 @@ static void ObjectRenamedTrace(ClientData clientData, Tcl_Interp *interp, const char *oldName, const char *newName, int flags); static void ReleaseClassContents(Tcl_Interp *interp,Object *oPtr); +static void DeleteDescendants(Tcl_Interp *interp,Object *oPtr); +static inline void RemoveClass(Class **list, int num, int idx); +static inline void RemoveObject(Object **list, int num, int idx); static inline void SquelchCachedName(Object *oPtr); -static void SquelchedNsFirst(ClientData clientData); static int PublicNRObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, @@ -90,6 +96,10 @@ static int PublicNRObjectCmd(ClientData clientData, static int PrivateNRObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); +static int MyClassNRObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); +static void MyClassDeleted(ClientData clientData); /* * Methods in the oo::object and oo::class classes. First, we define a helper @@ -140,65 +150,10 @@ static const char *initScript = /* " tcloo.tcl OO_LIBRARY oo::library;"; */ /* - * The scripted part of the definitions of slots. - */ - -static const char *slotScript = -"::oo::define ::oo::Slot {\n" -" method Get {} {error unimplemented}\n" -" method Set list {error unimplemented}\n" -" method -set args {\n" -" uplevel 1 [list [namespace which my] Set $args]\n" -" }\n" -" method -append args {\n" -" uplevel 1 [list [namespace which my] Set [list" -" {*}[uplevel 1 [list [namespace which my] Get]] {*}$args]]\n" -" }\n" -" method -clear {} {uplevel 1 [list [namespace which my] Set {}]}\n" -" forward --default-operation my -append\n" -" method unknown {args} {\n" -" set def --default-operation\n" -" if {[llength $args] == 0} {\n" -" return [uplevel 1 [list [namespace which my] $def]]\n" -" } elseif {![string match -* [lindex $args 0]]} {\n" -" return [uplevel 1 [list [namespace which my] $def {*}$args]]\n" -" }\n" -" next {*}$args\n" -" }\n" -" export -set -append -clear\n" -" unexport unknown destroy\n" -"}\n" -"::oo::objdefine ::oo::define::superclass forward --default-operation my -set\n" -"::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n" -"::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n"; - -/* - * The body of the <cloned> method of oo::object. + * The scripted part of the definitions of TclOO. */ -static const char *clonedBody = -"foreach p [info procs [info object namespace $originObject]::*] {" -" set args [info args $p];" -" set idx -1;" -" foreach a $args {" -" lset args [incr idx] " -" [if {[info default $p $a d]} {list $a $d} {list $a}]" -" };" -" set b [info body $p];" -" set p [namespace tail $p];" -" proc $p $args $b;" -"};" -"foreach v [info vars [info object namespace $originObject]::*] {" -" upvar 0 $v vOrigin;" -" namespace upvar [namespace current] [namespace tail $v] vNew;" -" if {[info exists vOrigin]} {" -" if {[array exists vOrigin]} {" -" array set vNew [array get vOrigin];" -" } else {" -" set vNew $vOrigin;" -" }" -" }" -"}"; +#include "tclOOScript.h" /* * The actual definition of the variable holding the TclOO stub table. @@ -222,10 +177,52 @@ MODULE_SCOPE const TclOOStubs tclOOStubs; * ROOT_CLASS respectively. */ -#define Deleted(oPtr) (((Object *)(oPtr))->command == NULL) +#define Deleted(oPtr) ((oPtr)->flags & OBJECT_DELETED) #define IsRootObject(ocPtr) ((ocPtr)->flags & ROOT_OBJECT) #define IsRootClass(ocPtr) ((ocPtr)->flags & ROOT_CLASS) #define IsRoot(ocPtr) ((ocPtr)->flags & (ROOT_OBJECT|ROOT_CLASS)) + +#define RemoveItem(type, lst, i) \ + do { \ + Remove ## type ((lst).list, (lst).num, i); \ + (lst).num--; \ + } while (0) + +/* + * ---------------------------------------------------------------------- + * + * RemoveClass, RemoveObject -- + * + * Helpers for the RemoveItem macro for deleting a class or object from a + * list. Setting the "empty" location to NULL makes debugging a little + * easier. + * + * ---------------------------------------------------------------------- + */ + +static inline void +RemoveClass( + Class **list, + int num, + int idx) +{ + for (; idx < num - 1; idx++) { + list[idx] = list[idx + 1]; + } + list[idx] = NULL; +} + +static inline void +RemoveObject( + Object **list, + int num, + int idx) +{ + for (; idx < num - 1; idx++) { + list[idx] = list[idx + 1]; + } + list[idx] = NULL; +} /* * ---------------------------------------------------------------------- @@ -261,11 +258,11 @@ TclOOInit( * to be fully provided. */ - if (Tcl_Eval(interp, initScript) != TCL_OK) { + if (Tcl_EvalEx(interp, initScript, -1, 0) != TCL_OK) { return TCL_ERROR; } - return Tcl_PkgProvideEx(interp, "TclOO", TCLOO_VERSION, + return Tcl_PkgProvideEx(interp, "TclOO", TCLOO_PATCHLEVEL, (ClientData) &tclOOStubs); } @@ -306,7 +303,7 @@ InitFoundation( ThreadLocalData *tsdPtr = Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData)); Foundation *fPtr = ckalloc(sizeof(Foundation)); - Tcl_Obj *namePtr, *argsPtr, *bodyPtr; + Tcl_Obj *namePtr; Tcl_DString buffer; Command *cmdPtr; int i; @@ -369,27 +366,10 @@ InitFoundation( Tcl_CallWhenDeleted(interp, KillFoundation, NULL); /* - * Create the objects at the core of the object system. These need to be - * spliced manually. + * Create the special objects at the core of the object system. */ - fPtr->objectCls = AllocClass(interp, - AllocObject(interp, "::oo::object", NULL)); - fPtr->classCls = AllocClass(interp, - AllocObject(interp, "::oo::class", NULL)); - fPtr->objectCls->thisPtr->selfCls = fPtr->classCls; - fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT; - fPtr->objectCls->flags |= ROOT_OBJECT; - fPtr->objectCls->superclasses.num = 0; - ckfree(fPtr->objectCls->superclasses.list); - fPtr->objectCls->superclasses.list = NULL; - fPtr->classCls->thisPtr->selfCls = fPtr->classCls; - fPtr->classCls->thisPtr->flags |= ROOT_CLASS; - fPtr->classCls->flags |= ROOT_CLASS; - TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls); - TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls); - AddRef(fPtr->objectCls->thisPtr); - AddRef(fPtr->objectCls); + InitClassSystemRoots(interp, fPtr); /* * Basic method declarations for the core classes. @@ -403,18 +383,6 @@ InitFoundation( } /* - * Create the default <cloned> method implementation, used when 'oo::copy' - * is called to finish the copying of one object to another. - */ - - TclNewLiteralStringObj(argsPtr, "originObject"); - Tcl_IncrRefCount(argsPtr); - bodyPtr = Tcl_NewStringObj(clonedBody, -1); - TclOONewProcMethod(interp, fPtr->objectCls, 0, fPtr->clonedName, argsPtr, - bodyPtr, NULL); - TclDecrRefCount(argsPtr); - - /* * Finish setting up the class of classes by marking the 'new' method as * private; classes, unlike general objects, must have explicit names. We * also need to create the constructor for classes. @@ -431,10 +399,12 @@ InitFoundation( * ensemble. */ - Tcl_CreateObjCommand(interp, "::oo::Helpers::next", TclOONextObjCmd, NULL, - NULL); - Tcl_CreateObjCommand(interp, "::oo::Helpers::nextto", TclOONextToObjCmd, - NULL, NULL); + cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::next", + NULL, TclOONextObjCmd, NULL, NULL); + cmdPtr->compileProc = TclCompileObjectNextCmd; + cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::nextto", + NULL, TclOONextToObjCmd, NULL, NULL); + cmdPtr->compileProc = TclCompileObjectNextToCmd; cmdPtr = (Command *) Tcl_CreateObjCommand(interp, "::oo::Helpers::self", TclOOSelfObjCmd, NULL, NULL); cmdPtr->compileProc = TclCompileObjectSelfCmd; @@ -452,7 +422,86 @@ InitFoundation( if (TclOODefineSlots(fPtr) != TCL_OK) { return TCL_ERROR; } - return Tcl_Eval(interp, slotScript); + + /* + * Evaluate the remaining definitions, which are a compiled-in Tcl script. + */ + + return Tcl_EvalEx(interp, tclOOSetupScript, -1, 0); +} + +/* + * ---------------------------------------------------------------------- + * + * InitClassSystemRoots -- + * + * Creates the objects at the core of the object system. These need to be + * spliced manually. + * + * ---------------------------------------------------------------------- + */ + +static void +InitClassSystemRoots( + Tcl_Interp *interp, + Foundation *fPtr) +{ + Class fakeCls; + Object fakeObject; + + /* Stand up a phony class for bootstrapping. */ + fPtr->objectCls = &fakeCls; + /* referenced in AllocClass to increment the refCount. */ + fakeCls.thisPtr = &fakeObject; + + fPtr->objectCls = AllocClass(interp, + AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL)); + /* Corresponding TclOODecrRefCount in KillFoudation */ + AddRef(fPtr->objectCls->thisPtr); + + /* This is why it is unnecessary in this routine to replace the + * incremented reference count of fPtr->objectCls that was swallowed by + * fakeObject. */ + fPtr->objectCls->superclasses.num = 0; + ckfree(fPtr->objectCls->superclasses.list); + fPtr->objectCls->superclasses.list = NULL; + + /* special initialization for the primordial objects */ + fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT; + fPtr->objectCls->flags |= ROOT_OBJECT; + + fPtr->classCls = AllocClass(interp, + AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL)); + /* Corresponding TclOODecrRefCount in KillFoudation */ + AddRef(fPtr->classCls->thisPtr); + + /* + * Increment reference counts for each reference because these + * relationships can be dynamically changed. + * + * Corresponding TclOODecrRefCount for all incremented refcounts is in + * KillFoundation. + */ + + /* Rewire bootstrapped objects. */ + fPtr->objectCls->thisPtr->selfCls = fPtr->classCls; + AddRef(fPtr->classCls->thisPtr); + TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls); + + fPtr->classCls->thisPtr->selfCls = fPtr->classCls; + AddRef(fPtr->classCls->thisPtr); + TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls); + + fPtr->classCls->thisPtr->flags |= ROOT_CLASS; + fPtr->classCls->flags |= ROOT_CLASS; + + /* Standard initialization for new Objects */ + TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls); + + /* + * THIS IS THE ONLY FUNCTION THAT DOES NON-STANDARD CLASS SPLICING. + * Everything else is careful to prohibit looping. + */ } /* @@ -513,13 +562,14 @@ KillFoundation( { Foundation *fPtr = GetFoundation(interp); - DelRef(fPtr->objectCls->thisPtr); - DelRef(fPtr->objectCls); TclDecrRefCount(fPtr->unknownMethodNameObj); TclDecrRefCount(fPtr->constructorName); TclDecrRefCount(fPtr->destructorName); TclDecrRefCount(fPtr->clonedName); TclDecrRefCount(fPtr->defineName); + TclOODecrRefCount(fPtr->objectCls->thisPtr); + TclOODecrRefCount(fPtr->classCls->thisPtr); + ckfree(fPtr); } @@ -529,7 +579,11 @@ KillFoundation( * AllocObject -- * * Allocate an object of basic type. Does not splice the object into its - * class's instance list. + * class's instance list. The caller must set the classPtr on the object + * to either a class or NULL, call TclOOAddToInstances to add the object + * to the class's instance list, and if the object itself is a class, use + * call TclOOAddToSubclasses() to add it to the right class's list of + * subclasses. * * ---------------------------------------------------------------------- */ @@ -542,6 +596,8 @@ AllocObject( * if the OO system should pick the object * name itself (equal to the namespace * name). */ + Namespace *nsPtr, /* The namespace to create the object in, or + * NULL if *nameStr is NULL */ const char *nsNameStr) /* The name of the namespace to create, or * NULL if the OO system should pick a unique * name itself. If this is non-NULL but names @@ -552,7 +608,7 @@ AllocObject( Object *oPtr; Command *cmdPtr; CommandTrace *tracePtr; - int creationEpoch, ignored; + int creationEpoch; oPtr = ckalloc(sizeof(Object)); memset(oPtr, 0, sizeof(Object)); @@ -570,8 +626,7 @@ AllocObject( */ if (nsNameStr != NULL) { - oPtr->namespacePtr = Tcl_CreateNamespace(interp, nsNameStr, oPtr, - ObjectNamespaceDeleted); + oPtr->namespacePtr = Tcl_CreateNamespace(interp, nsNameStr, oPtr, NULL); if (oPtr->namespacePtr != NULL) { creationEpoch = ++fPtr->tsdPtr->nsCount; goto configNamespace; @@ -583,8 +638,7 @@ AllocObject( char objName[10 + TCL_INTEGER_SPACE]; sprintf(objName, "::oo::Obj%d", ++fPtr->tsdPtr->nsCount); - oPtr->namespacePtr = Tcl_CreateNamespace(interp, objName, oPtr, - ObjectNamespaceDeleted); + oPtr->namespacePtr = Tcl_CreateNamespace(interp, objName, oPtr, NULL); if (oPtr->namespacePtr != NULL) { creationEpoch = fPtr->tsdPtr->nsCount; break; @@ -599,12 +653,16 @@ AllocObject( Tcl_ResetResult(interp); } + + configNamespace: + + ((Namespace *)oPtr->namespacePtr)->refCount++; + /* * Make the namespace know about the helper commands. This grants access * to the [self] and [next] commands. */ - configNamespace: if (fPtr->helpersNs != NULL) { TclSetNsPath((Namespace *) oPtr->namespacePtr, 1, &fPtr->helpersNs); } @@ -624,16 +682,22 @@ AllocObject( * access variables in it. [Bug 2950259] */ - ((Namespace *) oPtr->namespacePtr)->earlyDeleteProc = SquelchedNsFirst; + ((Namespace *) oPtr->namespacePtr)->earlyDeleteProc = ObjectNamespaceDeleted; /* * Fill in the rest of the non-zero/NULL parts of the structure. */ oPtr->fPtr = fPtr; - oPtr->selfCls = fPtr->objectCls; oPtr->creationEpoch = creationEpoch; - oPtr->refCount = 1; + + /* + * An object starts life with a refCount of 2 to mark the two stages of + * destruction it occur: A call to ObjectRenamedTrace(), and a call to + * ObjectNamespaceDeleted(). + */ + + oPtr->refCount = 2; oPtr->flags = USE_CLASS_CACHE; /* @@ -643,24 +707,14 @@ AllocObject( */ if (!nameStr) { - oPtr->command = Tcl_CreateObjCommand(interp, - oPtr->namespacePtr->fullName, TclOOPublicObjectCmd, oPtr, - NULL); - } else if (nameStr[0] == ':' && nameStr[1] == ':') { - oPtr->command = Tcl_CreateObjCommand(interp, nameStr, - TclOOPublicObjectCmd, oPtr, NULL); - } else { - Tcl_DString buffer; - - Tcl_DStringInit(&buffer); - Tcl_DStringAppend(&buffer, - Tcl_GetCurrentNamespace(interp)->fullName, -1); - TclDStringAppendLiteral(&buffer, "::"); - Tcl_DStringAppend(&buffer, nameStr, -1); - oPtr->command = Tcl_CreateObjCommand(interp, - Tcl_DStringValue(&buffer), TclOOPublicObjectCmd, oPtr, NULL); - Tcl_DStringFree(&buffer); + nameStr = oPtr->namespacePtr->name; + nsPtr = (Namespace *)oPtr->namespacePtr; + if (nsPtr->parentPtr != NULL) { + nsPtr = nsPtr->parentPtr; + } } + oPtr->command = TclCreateObjCommandInNs(interp, nameStr, + (Tcl_Namespace *)nsPtr, TclOOPublicObjectCmd, oPtr, NULL); /* * Add the NRE command and trace directly. While this breaks a number of @@ -676,26 +730,11 @@ AllocObject( tracePtr->nextPtr = NULL; tracePtr->refCount = 1; - /* - * Access the namespace command table directly when creating "my" to avoid - * a bottleneck in string manipulation. Another abstraction-buster. - */ - - cmdPtr = ckalloc(sizeof(Command)); - memset(cmdPtr, 0, sizeof(Command)); - cmdPtr->nsPtr = (Namespace *) oPtr->namespacePtr; - cmdPtr->hPtr = Tcl_CreateHashEntry(&cmdPtr->nsPtr->cmdTable, "my", - &ignored); - cmdPtr->refCount = 1; - cmdPtr->objProc = TclOOPrivateObjectCmd; - cmdPtr->deleteProc = MyDeleted; - cmdPtr->objClientData = cmdPtr->deleteData = oPtr; - cmdPtr->proc = TclInvokeObjectCommand; - cmdPtr->clientData = cmdPtr; - cmdPtr->nreProc = PrivateNRObjectCmd; - Tcl_SetHashValue(cmdPtr->hPtr, cmdPtr); - oPtr->myCommand = (Tcl_Command) cmdPtr; - + oPtr->myCommand = TclNRCreateCommandInNs(interp, "my", oPtr->namespacePtr, + TclOOPrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted); + oPtr->myclassCommand = TclNRCreateCommandInNs(interp, "myclass", + oPtr->namespacePtr, TclOOMyClassObjCmd, MyClassNRObjCmd, oPtr, + MyClassDeleted); return oPtr; } @@ -723,12 +762,12 @@ SquelchCachedName( /* * ---------------------------------------------------------------------- * - * MyDeleted -- + * MyDeleted, MyClassDeleted -- * - * This callback is triggered when the object's [my] command is deleted - * by any mechanism. It just marks the object as not having a [my] - * command, and so prevents cleanup of that when the object itself is - * deleted. + * These callbacks are triggered when the object's [my] or [myclass] + * commands are deleted by any mechanism. They just mark the object as + * not having a [my] command or [myclass] command, and so prevent cleanup + * of those commands when the object itself is deleted. * * ---------------------------------------------------------------------- */ @@ -742,29 +781,13 @@ MyDeleted( oPtr->myCommand = NULL; } - -/* - * ---------------------------------------------------------------------- - * - * SquelchedNsFirst -- - * - * This callback is triggered when the object's namespace is deleted by - * any mechanism. It deletes the object's public command if it has not - * already been deleted, so ensuring that destructors get run at an - * appropriate time. [Bug 2950259] - * - * ---------------------------------------------------------------------- - */ static void -SquelchedNsFirst( +MyClassDeleted( ClientData clientData) { Object *oPtr = clientData; - - if (oPtr->command) { - Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command); - } + oPtr->myclassCommand = NULL; } /* @@ -785,11 +808,10 @@ ObjectRenamedTrace( ClientData clientData, /* The object being deleted. */ Tcl_Interp *interp, /* The interpreter containing the object. */ const char *oldName, /* What the object was (last) called. */ - const char *newName, /* Always NULL. */ + const char *newName, /* What it's getting renamed to. (unused) */ int flags) /* Why was the object deleted? */ { Object *oPtr = clientData; - Foundation *fPtr = oPtr->fPtr; /* * If this is a rename and not a delete of the object, we just flush the @@ -802,87 +824,99 @@ ObjectRenamedTrace( } /* - * Oh dear, the object really is being deleted. Handle this by running the - * destructors and deleting the object's namespace, which in turn causes - * the real object structures to be deleted. - * - * Note that it is possible for the namespace to be deleted before the - * command. Because of that case, we must take care here to mark the - * command as being deleted so that if we return here we don't run into - * reentrancy problems. - * - * We also do not run destructors on the core class objects when the - * interpreter is being deleted; their incestuous nature causes problems - * in that case when the destructor is partially deleted before the uses - * of it have gone. [Bug 2949397] + * The namespace is only deleted if it hasn't already been deleted. [Bug + * 2950259]. */ - AddRef(oPtr); - AddRef(fPtr->classCls); - AddRef(fPtr->objectCls); - AddRef(fPtr->classCls->thisPtr); - AddRef(fPtr->objectCls->thisPtr); + if (!Deleted(oPtr)) { + Tcl_DeleteNamespace(oPtr->namespacePtr); + } oPtr->command = NULL; + TclOODecrRefCount(oPtr); + return; +} + +/* + * ---------------------------------------------------------------------- + * + * DeleteDescendants -- + * + * Delete all descendants of a particular class. + * + * ---------------------------------------------------------------------- + */ - if (!(oPtr->flags & DESTRUCTOR_CALLED) && !Tcl_InterpDeleted(interp)) { - CallContext *contextPtr = - TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL); - int result; - Tcl_InterpState state; +static void +DeleteDescendants( + Tcl_Interp *interp, /* The interpreter containing the class. */ + Object *oPtr) /* The object representing the class. */ +{ + Class *clsPtr = oPtr->classPtr, *subclassPtr, *mixinSubclassPtr; + Object *instancePtr; - oPtr->flags |= DESTRUCTOR_CALLED; - if (contextPtr != NULL) { - contextPtr->callPtr->flags |= DESTRUCTOR; - contextPtr->skip = 0; - state = Tcl_SaveInterpState(interp, TCL_OK); - result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, - contextPtr, 0, NULL); - if (result != TCL_OK) { - Tcl_BackgroundException(interp, result); + /* + * Squelch classes that this class has been mixed into. + */ + + if (clsPtr->mixinSubs.num > 0) { + while (clsPtr->mixinSubs.num > 0) { + mixinSubclassPtr = clsPtr->mixinSubs.list[clsPtr->mixinSubs.num-1]; + /* This condition also covers the case where mixinSubclassPtr == + * clsPtr + */ + if (!Deleted(mixinSubclassPtr->thisPtr)) { + Tcl_DeleteCommandFromToken(interp, + mixinSubclassPtr->thisPtr->command); } - Tcl_RestoreInterpState(interp, state); - TclOODeleteContext(contextPtr); + TclOORemoveFromMixinSubs(mixinSubclassPtr, clsPtr); } } + if (clsPtr->mixinSubs.size > 0) { + ckfree(clsPtr->mixinSubs.list); + clsPtr->mixinSubs.size = 0; + } /* - * OK, the destructor's been run. Time to splat the class data (if any) - * and nuke the namespace (which triggers the final crushing of the object - * structure itself). - * - * The class of objects needs some special care; if it is deleted (and - * we're not killing the whole interpreter) we force the delete of the - * class of classes now as well. Due to the incestuous nature of those two - * classes, if one goes the other must too and yet the tangle can - * sometimes not go away automatically; we force it here. [Bug 2962664] + * Squelch subclasses of this class. */ - if (!Tcl_InterpDeleted(interp) && IsRootObject(oPtr) - && !Deleted(fPtr->classCls->thisPtr)) { - Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command); + if (clsPtr->subclasses.num > 0) { + while (clsPtr->subclasses.num > 0) { + subclassPtr = clsPtr->subclasses.list[clsPtr->subclasses.num-1]; + if (!Deleted(subclassPtr->thisPtr) && !IsRoot(subclassPtr)) { + Tcl_DeleteCommandFromToken(interp, subclassPtr->thisPtr->command); + } + TclOORemoveFromSubclasses(subclassPtr, clsPtr); + } } - - if (oPtr->classPtr != NULL) { - AddRef(oPtr->classPtr); - ReleaseClassContents(interp, oPtr); + if (clsPtr->subclasses.size > 0) { + ckfree(clsPtr->subclasses.list); + clsPtr->subclasses.list = NULL; + clsPtr->subclasses.size = 0; } /* - * The namespace is only deleted if it hasn't already been deleted. [Bug - * 2950259] + * Squelch instances of this class (includes objects we're mixed into). */ - if (((Namespace *) oPtr->namespacePtr)->earlyDeleteProc != NULL) { - Tcl_DeleteNamespace(oPtr->namespacePtr); + if (clsPtr->instances.num > 0) { + while (clsPtr->instances.num > 0) { + instancePtr = clsPtr->instances.list[clsPtr->instances.num-1]; + /* + * This condition also covers the case where instancePtr == oPtr + */ + + if (!Deleted(instancePtr) && !IsRoot(instancePtr)) { + Tcl_DeleteCommandFromToken(interp, instancePtr->command); + } + TclOORemoveFromInstances(instancePtr, clsPtr); + } } - if (oPtr->classPtr) { - DelRef(oPtr->classPtr); + if (clsPtr->instances.size > 0) { + ckfree(clsPtr->instances.list); + clsPtr->instances.list = NULL; + clsPtr->instances.size = 0; } - DelRef(fPtr->classCls->thisPtr); - DelRef(fPtr->objectCls->thisPtr); - DelRef(fPtr->classCls); - DelRef(fPtr->objectCls); - DelRef(oPtr); } /* @@ -903,9 +937,11 @@ ReleaseClassContents( { FOREACH_HASH_DECLS; int i; - Class *clsPtr = oPtr->classPtr, *mixinSubclassPtr, *subclassPtr; - Object *instancePtr; + Class *clsPtr = oPtr->classPtr, *tmpClsPtr; + Method *mPtr; Foundation *fPtr = oPtr->fPtr; + Tcl_Obj *variableObj; + PrivateVariableMapping *privateVariable; /* * Sanity check! @@ -925,101 +961,6 @@ ReleaseClassContents( } /* - * Lock a number of dependent objects until we've stopped putting our - * fingers in them. - */ - - FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) { - if (mixinSubclassPtr != NULL) { - AddRef(mixinSubclassPtr); - AddRef(mixinSubclassPtr->thisPtr); - } - } - FOREACH(subclassPtr, clsPtr->subclasses) { - if (subclassPtr != NULL && !IsRoot(subclassPtr)) { - AddRef(subclassPtr); - AddRef(subclassPtr->thisPtr); - } - } - if (!IsRootClass(oPtr)) { - FOREACH(instancePtr, clsPtr->instances) { - if (instancePtr != NULL && !IsRoot(instancePtr)) { - AddRef(instancePtr); - } - } - } - - /* - * Squelch classes that this class has been mixed into. - */ - - FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) { - if (mixinSubclassPtr == NULL) { - continue; - } - if (!Deleted(mixinSubclassPtr->thisPtr)) { - Tcl_DeleteCommandFromToken(interp, - mixinSubclassPtr->thisPtr->command); - } - DelRef(mixinSubclassPtr->thisPtr); - DelRef(mixinSubclassPtr); - } - if (clsPtr->mixinSubs.list != NULL) { - ckfree(clsPtr->mixinSubs.list); - clsPtr->mixinSubs.list = NULL; - clsPtr->mixinSubs.num = 0; - } - - /* - * Squelch subclasses of this class. - */ - - FOREACH(subclassPtr, clsPtr->subclasses) { - if (subclassPtr == NULL || IsRoot(subclassPtr)) { - continue; - } - if (!Deleted(subclassPtr->thisPtr)) { - Tcl_DeleteCommandFromToken(interp, subclassPtr->thisPtr->command); - } - DelRef(subclassPtr->thisPtr); - DelRef(subclassPtr); - } - if (clsPtr->subclasses.list != NULL) { - ckfree(clsPtr->subclasses.list); - clsPtr->subclasses.list = NULL; - clsPtr->subclasses.num = 0; - } - - /* - * Squelch instances of this class (includes objects we're mixed into). - */ - - if (!IsRootClass(oPtr)) { - FOREACH(instancePtr, clsPtr->instances) { - if (instancePtr == NULL || IsRoot(instancePtr)) { - continue; - } - if (!Deleted(instancePtr)) { - Tcl_DeleteCommandFromToken(interp, instancePtr->command); - } - DelRef(instancePtr); - } - } - if (clsPtr->instances.list != NULL) { - ckfree(clsPtr->instances.list); - clsPtr->instances.list = NULL; - clsPtr->instances.num = 0; - } - - /* - * Special: We delete these after everything else. - */ - - if (IsRootClass(oPtr) && !Deleted(fPtr->objectCls->thisPtr)) { - Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command); - } - - /* * Squelch method implementation chain caches. */ @@ -1053,6 +994,7 @@ ReleaseClassContents( TclDecrRefCount(filterObj); } ckfree(clsPtr->filters.list); + clsPtr->filters.list = NULL; clsPtr->filters.num = 0; } @@ -1071,6 +1013,52 @@ ReleaseClassContents( ckfree(clsPtr->metadataPtr); clsPtr->metadataPtr = NULL; } + + if (clsPtr->mixins.num) { + FOREACH(tmpClsPtr, clsPtr->mixins) { + TclOORemoveFromMixinSubs(clsPtr, tmpClsPtr); + TclOODecrRefCount(tmpClsPtr->thisPtr); + } + ckfree(clsPtr->mixins.list); + clsPtr->mixins.list = NULL; + clsPtr->mixins.num = 0; + } + + if (clsPtr->superclasses.num > 0) { + FOREACH(tmpClsPtr, clsPtr->superclasses) { + TclOORemoveFromSubclasses(clsPtr, tmpClsPtr); + TclOODecrRefCount(tmpClsPtr->thisPtr); + } + ckfree(clsPtr->superclasses.list); + clsPtr->superclasses.num = 0; + clsPtr->superclasses.list = NULL; + } + + FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) { + TclOODelMethodRef(mPtr); + } + Tcl_DeleteHashTable(&clsPtr->classMethods); + TclOODelMethodRef(clsPtr->constructorPtr); + TclOODelMethodRef(clsPtr->destructorPtr); + + FOREACH(variableObj, clsPtr->variables) { + TclDecrRefCount(variableObj); + } + if (i) { + ckfree(clsPtr->variables.list); + } + + FOREACH_STRUCT(privateVariable, clsPtr->privateVariables) { + TclDecrRefCount(privateVariable->variableObj); + TclDecrRefCount(privateVariable->fullNameObj); + } + if (i) { + ckfree(clsPtr->privateVariables.list); + } + + if (IsRootClass(oPtr) && !Deleted(fPtr->objectCls->thisPtr)) { + Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command); + } } /* @@ -1092,22 +1080,90 @@ ObjectNamespaceDeleted( * being deleted. */ { Object *oPtr = clientData; + Foundation *fPtr = oPtr->fPtr; FOREACH_HASH_DECLS; - Class *clsPtr = oPtr->classPtr, *mixinPtr; + Class *mixinPtr; Method *mPtr; Tcl_Obj *filterObj, *variableObj; + PrivateVariableMapping *privateVariable; + Tcl_Interp *interp = oPtr->fPtr->interp; int i; + if (Deleted(oPtr)) { + /* + * TODO: Can ObjectNamespaceDeleted ever be called twice? If not, this + * guard could be removed. + */ + + return; + } + + /* + * One rule for the teardown routines is that if an object is in the + * process of being deleted, nothing else may modify its bookeeping + * records. This is the flag that + */ + + oPtr->flags |= OBJECT_DELETED; + + /* Let the dominoes fall */ + if (oPtr->classPtr) { + DeleteDescendants(interp, oPtr); + } + + /* + * We do not run destructors on the core class objects when the + * interpreter is being deleted; their incestuous nature causes problems + * in that case when the destructor is partially deleted before the uses + * of it have gone. [Bug 2949397] + */ + + if (!Tcl_InterpDeleted(interp) && !(oPtr->flags & DESTRUCTOR_CALLED)) { + CallContext *contextPtr = + TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL, NULL); + int result; + + Tcl_InterpState state; + oPtr->flags |= DESTRUCTOR_CALLED; + + if (contextPtr != NULL) { + contextPtr->callPtr->flags |= DESTRUCTOR; + contextPtr->skip = 0; + state = Tcl_SaveInterpState(interp, TCL_OK); + result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, + contextPtr, 0, NULL); + if (result != TCL_OK) { + Tcl_BackgroundException(interp, result); + } + Tcl_RestoreInterpState(interp, state); + TclOODeleteContext(contextPtr); + } + } + /* * Instruct everyone to no longer use any allocated fields of the object. - * Also delete the commands that refer to the object at this point (if - * they still exist) because otherwise their references to the object - * point into freed memory, allowing crashes. + * Also delete the command that refers to the object at this point (if + * it still exists) because otherwise its pointer to the object + * points into freed memory. */ - if (oPtr->command) { + if (((Command *)oPtr->command)->flags && CMD_IS_DELETED) { + /* + * Something has already started the command deletion process. We can + * go ahead and clean up the the namespace, + */ + } else { + /* + * The namespace must have been deleted directly. Delete the command + * as well. + */ + Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command); } + + if (oPtr->myclassCommand) { + Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myclassCommand); + } if (oPtr->myCommand) { Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand); } @@ -1117,14 +1173,17 @@ ObjectNamespaceDeleted( * methods on the object. */ - if (!IsRootObject(oPtr)) { - TclOORemoveFromInstances(oPtr, oPtr->selfCls); - } + /* + * TODO: Should this be protected with a * !IsRoot() condition? + */ - FOREACH(mixinPtr, oPtr->mixins) { - TclOORemoveFromInstances(oPtr, mixinPtr); - } - if (i) { + TclOORemoveFromInstances(oPtr, oPtr->selfCls); + + if (oPtr->mixins.num > 0) { + FOREACH(mixinPtr, oPtr->mixins) { + TclOORemoveFromInstances(oPtr, mixinPtr); + TclOODecrRefCount(mixinPtr->thisPtr); + } ckfree(oPtr->mixins.list); } @@ -1150,6 +1209,14 @@ ObjectNamespaceDeleted( ckfree(oPtr->variables.list); } + FOREACH_STRUCT(privateVariable, oPtr->privateVariables) { + TclDecrRefCount(privateVariable->variableObj); + TclDecrRefCount(privateVariable->fullNameObj); + } + if (i) { + ckfree(oPtr->privateVariables.list); + } + if (oPtr->chainCache) { TclOODeleteChainCache(oPtr->chainCache); } @@ -1168,80 +1235,64 @@ ObjectNamespaceDeleted( oPtr->metadataPtr = NULL; } - if (clsPtr != NULL) { - Class *superPtr; - Tcl_ObjectMetadataType *metadataTypePtr; - ClientData value; - - if (clsPtr->metadataPtr != NULL) { - FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) { - metadataTypePtr->deleteProc(value); - } - Tcl_DeleteHashTable(clsPtr->metadataPtr); - ckfree(clsPtr->metadataPtr); - clsPtr->metadataPtr = NULL; - } - - FOREACH(filterObj, clsPtr->filters) { - TclDecrRefCount(filterObj); - } - if (i) { - ckfree(clsPtr->filters.list); - clsPtr->filters.num = 0; - } - FOREACH(mixinPtr, clsPtr->mixins) { - if (!Deleted(mixinPtr->thisPtr)) { - TclOORemoveFromMixinSubs(clsPtr, mixinPtr); - } - } - if (i) { - ckfree(clsPtr->mixins.list); - clsPtr->mixins.num = 0; - } - FOREACH(superPtr, clsPtr->superclasses) { - if (!Deleted(superPtr->thisPtr)) { - TclOORemoveFromSubclasses(clsPtr, superPtr); - } - } - if (i) { - ckfree(clsPtr->superclasses.list); - clsPtr->superclasses.num = 0; - } - if (clsPtr->subclasses.list) { - ckfree(clsPtr->subclasses.list); - clsPtr->subclasses.num = 0; - } - if (clsPtr->instances.list) { - ckfree(clsPtr->instances.list); - clsPtr->instances.num = 0; - } - if (clsPtr->mixinSubs.list) { - ckfree(clsPtr->mixinSubs.list); - clsPtr->mixinSubs.num = 0; - } - - FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) { - TclOODelMethodRef(mPtr); - } - Tcl_DeleteHashTable(&clsPtr->classMethods); - TclOODelMethodRef(clsPtr->constructorPtr); - TclOODelMethodRef(clsPtr->destructorPtr); + /* + * Because an object can be a class that is an instance of itself, the + * class object's class structure should only be cleaned after most of the + * cleanup on the object is done. + * + * The class of objects needs some special care; if it is deleted (and + * we're not killing the whole interpreter) we force the delete of the + * class of classes now as well. Due to the incestuous nature of those two + * classes, if one goes the other must too and yet the tangle can + * sometimes not go away automatically; we force it here. [Bug 2962664] + */ - FOREACH(variableObj, clsPtr->variables) { - TclDecrRefCount(variableObj); - } - if (i) { - ckfree(clsPtr->variables.list); - } + if (IsRootObject(oPtr) && !Deleted(fPtr->classCls->thisPtr) + && !Tcl_InterpDeleted(interp)) { + Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command); + } - DelRef(clsPtr); + if (oPtr->classPtr != NULL) { + ReleaseClassContents(interp, oPtr); } /* * Delete the object structure itself. */ - DelRef(oPtr); + TclNsDecrRefCount((Namespace *)oPtr->namespacePtr); + oPtr->namespacePtr = NULL; + TclOODecrRefCount(oPtr->selfCls->thisPtr); + oPtr->selfCls = NULL; + TclOODecrRefCount(oPtr); + return; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOODecrRefCount -- + * + * Decrement the refcount of an object and deallocate storage then object + * is no longer referenced. Returns 1 if storage was deallocated, and 0 + * otherwise. + * + * ---------------------------------------------------------------------- + */ + +int +TclOODecrRefCount( + Object *oPtr) +{ + if (oPtr->refCount-- <= 1) { + + if (oPtr->classPtr != NULL) { + ckfree(oPtr->classPtr); + } + ckfree(oPtr); + return 1; + } + return 0; } /* @@ -1255,33 +1306,24 @@ ObjectNamespaceDeleted( * ---------------------------------------------------------------------- */ -void +int TclOORemoveFromInstances( Object *oPtr, /* The instance to remove. */ Class *clsPtr) /* The class (possibly) containing the * reference to the instance. */ { - int i; + int i, res = 0; Object *instPtr; FOREACH(instPtr, clsPtr->instances) { if (oPtr == instPtr) { - goto removeInstance; - } - } - return; - - removeInstance: - if (Deleted(clsPtr->thisPtr)) { - clsPtr->instances.list[i] = NULL; - } else { - clsPtr->instances.num--; - if (i < clsPtr->instances.num) { - clsPtr->instances.list[i] = - clsPtr->instances.list[clsPtr->instances.num]; + RemoveItem(Object, clsPtr->instances, i); + TclOODecrRefCount(oPtr); + res++; + break; } - clsPtr->instances.list[clsPtr->instances.num] = NULL; } + return res; } /* @@ -1302,9 +1344,6 @@ TclOOAddToInstances( * assumed that the class is not already * present as an instance in the class. */ { - if (Deleted(clsPtr->thisPtr)) { - return; - } if (clsPtr->instances.num >= clsPtr->instances.size) { clsPtr->instances.size += ALLOC_CHUNK; if (clsPtr->instances.size == ALLOC_CHUNK) { @@ -1315,6 +1354,7 @@ TclOOAddToInstances( } } clsPtr->instances.list[clsPtr->instances.num++] = oPtr; + AddRef(oPtr); } /* @@ -1323,38 +1363,28 @@ TclOOAddToInstances( * TclOORemoveFromSubclasses -- * * Utility function to remove a class from the list of subclasses within - * another class. + * another class. Returns the number of removals performed. * * ---------------------------------------------------------------------- */ -void +int TclOORemoveFromSubclasses( Class *subPtr, /* The subclass to remove. */ - Class *superPtr) /* The superclass to (possibly) remove the + Class *superPtr) /* The superclass to possibly remove the * subclass reference from. */ { - int i; + int i, res = 0; Class *subclsPtr; FOREACH(subclsPtr, superPtr->subclasses) { if (subPtr == subclsPtr) { - goto removeSubclass; - } - } - return; - - removeSubclass: - if (Deleted(superPtr->thisPtr)) { - superPtr->subclasses.list[i] = NULL; - } else { - superPtr->subclasses.num--; - if (i < superPtr->subclasses.num) { - superPtr->subclasses.list[i] = - superPtr->subclasses.list[superPtr->subclasses.num]; + RemoveItem(Class, superPtr->subclasses, i); + TclOODecrRefCount(subPtr->thisPtr); + res++; } - superPtr->subclasses.list[superPtr->subclasses.num] = NULL; } + return res; } /* @@ -1381,13 +1411,14 @@ TclOOAddToSubclasses( if (superPtr->subclasses.num >= superPtr->subclasses.size) { superPtr->subclasses.size += ALLOC_CHUNK; if (superPtr->subclasses.size == ALLOC_CHUNK) { - superPtr->subclasses.list = ckalloc(sizeof(Class*) * ALLOC_CHUNK); + superPtr->subclasses.list = ckalloc(sizeof(Class *) * ALLOC_CHUNK); } else { superPtr->subclasses.list = ckrealloc(superPtr->subclasses.list, sizeof(Class *) * superPtr->subclasses.size); } } superPtr->subclasses.list[superPtr->subclasses.num++] = subPtr; + AddRef(subPtr->thisPtr); } /* @@ -1401,33 +1432,24 @@ TclOOAddToSubclasses( * ---------------------------------------------------------------------- */ -void +int TclOORemoveFromMixinSubs( Class *subPtr, /* The subclass to remove. */ - Class *superPtr) /* The superclass to (possibly) remove the + Class *superPtr) /* The superclass to possibly remove the * subclass reference from. */ { - int i; + int i, res = 0; Class *subclsPtr; FOREACH(subclsPtr, superPtr->mixinSubs) { if (subPtr == subclsPtr) { - goto removeSubclass; - } - } - return; - - removeSubclass: - if (Deleted(superPtr->thisPtr)) { - superPtr->mixinSubs.list[i] = NULL; - } else { - superPtr->mixinSubs.num--; - if (i < superPtr->mixinSubs.num) { - superPtr->mixinSubs.list[i] = - superPtr->mixinSubs.list[superPtr->mixinSubs.num]; + RemoveItem(Class, superPtr->mixinSubs, i); + TclOODecrRefCount(subPtr->thisPtr); + res++; + break; } - superPtr->mixinSubs.list[superPtr->mixinSubs.num] = NULL; } + return res; } /* @@ -1461,6 +1483,7 @@ TclOOAddToMixinSubs( } } superPtr->mixinSubs.list[superPtr->mixinSubs.num++] = subPtr; + AddRef(subPtr->thisPtr); } /* @@ -1468,37 +1491,18 @@ TclOOAddToMixinSubs( * * AllocClass -- * - * Allocate a basic class. Does not splice the class object into its + * Allocate a basic class. Does not add class to its * class's instance list. * * ---------------------------------------------------------------------- */ -static Class * -AllocClass( - Tcl_Interp *interp, /* Interpreter within which to allocate the - * class. */ - Object *useThisObj) /* Object that is to act as the class - * representation, or NULL if a new object - * (with automatic name) is to be used. */ +static inline void +InitClassPath( + Tcl_Interp *interp, + Class *clsPtr) { Foundation *fPtr = GetFoundation(interp); - Class *clsPtr = ckalloc(sizeof(Class)); - - /* - * Make an object if we haven't been given one. - */ - - memset(clsPtr, 0, sizeof(Class)); - if (useThisObj == NULL) { - clsPtr->thisPtr = AllocObject(interp, NULL, NULL); - } else { - clsPtr->thisPtr = useThisObj; - } - - /* - * Configure the namespace path for the class's object. - */ if (fPtr->helpersNs != NULL) { Tcl_Namespace *path[2]; @@ -1510,13 +1514,26 @@ AllocClass( TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 1, &fPtr->ooNs); } +} + +static Class * +AllocClass( + Tcl_Interp *interp, /* Interpreter within which to allocate the + * class. */ + Object *useThisObj) /* Object that is to act as the class + * representation. */ +{ + Foundation *fPtr = GetFoundation(interp); + Class *clsPtr = ckalloc(sizeof(Class)); + + memset(clsPtr, 0, sizeof(Class)); + clsPtr->thisPtr = useThisObj; /* - * Class objects inherit from the class of classes unless they inherit - * from some subclass of it. Enforce this right now. + * Configure the namespace path for the class's object. */ - clsPtr->thisPtr->selfCls = fPtr->classCls; + InitClassPath(interp, clsPtr); /* * Classes are subclasses of oo::object, i.e. the objects they create are @@ -1526,6 +1543,7 @@ AllocClass( clsPtr->superclasses.num = 1; clsPtr->superclasses.list = ckalloc(sizeof(Class *)); clsPtr->superclasses.list[0] = fPtr->objectCls; + AddRef(fPtr->objectCls->thisPtr); /* * Finish connecting the class structure to the object structure. @@ -1538,7 +1556,6 @@ AllocClass( * fields. */ - clsPtr->refCount = 1; Tcl_InitObjHashTable(&clsPtr->classMethods); return clsPtr; } @@ -1552,7 +1569,6 @@ AllocClass( * * ---------------------------------------------------------------------- */ - Tcl_Object Tcl_NewObjectInstance( Tcl_Interp *interp, /* Interpreter context. */ @@ -1569,60 +1585,25 @@ Tcl_NewObjectInstance( * constructor. */ { register Class *classPtr = (Class *) cls; - Foundation *fPtr = GetFoundation(interp); Object *oPtr; + ClientData clientData[4]; - /* - * Check if we're going to create an object over an existing command; - * that's not allowed. - */ - - if (nameStr && Tcl_FindCommand(interp, nameStr, NULL, - TCL_NAMESPACE_ONLY)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't create object \"%s\": command already exists with" - " that name", nameStr)); - Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL); + oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr); + if (oPtr == NULL) { return NULL; } /* - * Create the object. - */ - - oPtr = AllocObject(interp, nameStr, nsNameStr); - oPtr->selfCls = classPtr; - TclOOAddToInstances(oPtr, classPtr); - - /* - * Check to see if we're really creating a class. If so, allocate the - * class structure as well. - */ - - if (TclOOIsReachable(fPtr->classCls, classPtr)) { - /* - * Is a class, so attach a class structure. Note that the AllocClass - * function splices the structure into the object, so we don't have - * to. Once that's done, we need to repatch the object to have the - * right class since AllocClass interferes with that. - */ - - AllocClass(interp, oPtr); - oPtr->selfCls = classPtr; - TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls); - } - - /* - * Run constructors, except when objc < 0 (a special flag case used for - * object cloning only). + * Run constructors, except when objc < 0, which is a special flag case + * used for object cloning only. */ if (objc >= 0) { CallContext *contextPtr = - TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL); + TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL); if (contextPtr != NULL) { - int result; + int isRoot, result; Tcl_InterpState state; state = Tcl_SaveInterpState(interp, TCL_OK); @@ -1630,43 +1611,26 @@ Tcl_NewObjectInstance( contextPtr->skip = skip; /* - * Adjust the ensmble tracking record if necessary. [Bug 3514761] + * Adjust the ensemble tracking record if necessary. [Bug 3514761] */ - if (((Interp*) interp)->ensembleRewrite.sourceObjs) { - ((Interp*) interp)->ensembleRewrite.numInsertedObjs += skip-1; - ((Interp*) interp)->ensembleRewrite.numRemovedObjs += skip-1; - } + isRoot = TclInitRewriteEnsemble(interp, skip, skip, objv); result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr, objc, objv); - /* - * It's an error if the object was whacked in the constructor. - * Force this if it isn't already an error (don't want to lose - * errors by accident...) [Bug 2903011] - */ - - if (result != TCL_ERROR && Deleted(oPtr)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "object deleted in constructor", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL); - result = TCL_ERROR; + if (isRoot) { + TclResetRewriteEnsemble(interp, 1); } - TclOODeleteContext(contextPtr); - if (result != TCL_OK) { - Tcl_DiscardInterpState(state); - /* - * Take care to not delete a deleted object; that would be - * bad. [Bug 2903011] - */ + clientData[0] = contextPtr; + clientData[1] = oPtr; + clientData[2] = state; + clientData[3] = &oPtr; - if (!Deleted(oPtr)) { - Tcl_DeleteCommandFromToken(interp, oPtr->command); - } + result = FinalizeAlloc(clientData, interp, result); + if (result != TCL_OK) { return NULL; } - Tcl_RestoreInterpState(interp, state); } } @@ -1691,52 +1655,16 @@ TclNRNewObjectInstance( * successful allocation. */ { register Class *classPtr = (Class *) cls; - Foundation *fPtr = GetFoundation(interp); CallContext *contextPtr; Tcl_InterpState state; Object *oPtr; - /* - * Check if we're going to create an object over an existing command; - * that's not allowed. - */ - - if (nameStr && Tcl_FindCommand(interp, nameStr, NULL, - TCL_NAMESPACE_ONLY)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't create object \"%s\": command already exists with" - " that name", nameStr)); - Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL); + oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr); + if (oPtr == NULL) { return TCL_ERROR; } /* - * Create the object. - */ - - oPtr = AllocObject(interp, nameStr, nsNameStr); - oPtr->selfCls = classPtr; - TclOOAddToInstances(oPtr, classPtr); - - /* - * Check to see if we're really creating a class. If so, allocate the - * class structure as well. - */ - - if (TclOOIsReachable(fPtr->classCls, classPtr)) { - /* - * Is a class, so attach a class structure. Note that the AllocClass - * function splices the structure into the object, so we don't have - * to. Once that's done, we need to repatch the object to have the - * right class since AllocClass interferes with that. - */ - - AllocClass(interp, oPtr); - oPtr->selfCls = classPtr; - TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls); - } - - /* * Run constructors, except when objc < 0 (a special flag case used for * object cloning only). If there aren't any constructors, we do nothing. */ @@ -1745,7 +1673,7 @@ TclNRNewObjectInstance( *objectPtr = (Tcl_Object) oPtr; return TCL_OK; } - contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL); + contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL); if (contextPtr == NULL) { *objectPtr = (Tcl_Object) oPtr; return TCL_OK; @@ -1756,25 +1684,96 @@ TclNRNewObjectInstance( contextPtr->skip = skip; /* - * Adjust the ensmble tracking record if necessary. [Bug 3514761] + * Adjust the ensemble tracking record if necessary. [Bug 3514761] */ - if (((Interp *) interp)->ensembleRewrite.sourceObjs) { - ((Interp *) interp)->ensembleRewrite.numInsertedObjs += skip - 1; - ((Interp *) interp)->ensembleRewrite.numRemovedObjs += skip - 1; + if (TclInitRewriteEnsemble(interp, skip, skip, objv)) { + TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); } /* * Fire off the constructors non-recursively. */ - AddRef(oPtr); TclNRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state, objectPtr); TclPushTailcallPoint(interp); return TclOOInvokeContext(contextPtr, interp, objc, objv); } + +Object * +TclNewObjectInstanceCommon( + Tcl_Interp *interp, + Class *classPtr, + const char *nameStr, + const char *nsNameStr) +{ + Tcl_HashEntry *hPtr; + Foundation *fPtr = GetFoundation(interp); + Object *oPtr; + const char *simpleName = NULL; + Namespace *nsPtr = NULL, *dummy; + Namespace *inNsPtr = (Namespace *) TclGetCurrentNamespace(interp); + int isNew; + + if (nameStr) { + TclGetNamespaceForQualName(interp, nameStr, inNsPtr, + TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy, &dummy, &simpleName); + + /* + * Disallow creation of an object over an existing command. + */ + + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, simpleName, &isNew); + if (!isNew) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create object \"%s\": command already exists with" + " that name", nameStr)); + Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL); + return NULL; + } + + /* + * We could make a hash entry! Don't actually want to do that here so + * nuke it immediately because we'll create it properly soon. + */ + + Tcl_DeleteHashEntry(hPtr); + } + + /* + * Create the object. + */ + + oPtr = AllocObject(interp, simpleName, nsPtr, nsNameStr); + oPtr->selfCls = classPtr; + AddRef(classPtr->thisPtr); + TclOOAddToInstances(oPtr, classPtr); + + /* + * Check to see if we're really creating a class. If so, allocate the + * class structure as well. + */ + + if (TclOOIsReachable(fPtr->classCls, classPtr)) { + /* + * Is a class, so attach a class structure. Note that the AllocClass + * function splices the structure into the object, so we don't have + * to. Once that's done, we need to repatch the object to have the + * right class since AllocClass interferes with that. + */ + + AllocClass(interp, oPtr); + TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls); + } else { + oPtr->classPtr = NULL; + } + return oPtr; +} + + + static int FinalizeAlloc( ClientData data[], @@ -1787,9 +1786,8 @@ FinalizeAlloc( Tcl_Object *objectPtr = data[3]; /* - * It's an error if the object was whacked in the constructor. Force this - * if it isn't already an error (don't want to lose errors by accident...) - * [Bug 2903011] + * Ensure an error if the object was deleted in the constructor. Don't + * want to lose errors by accident. [Bug 2903011] */ if (result != TCL_ERROR && Deleted(oPtr)) { @@ -1798,24 +1796,35 @@ FinalizeAlloc( Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL); result = TCL_ERROR; } - TclOODeleteContext(contextPtr); if (result != TCL_OK) { Tcl_DiscardInterpState(state); /* * Take care to not delete a deleted object; that would be bad. [Bug - * 2903011] + * 2903011] Also take care to make sure that we have the name of the + * command before we delete it. [Bug 9dd1bd7a74] */ if (!Deleted(oPtr)) { + (void) TclOOObjectName(interp, oPtr); Tcl_DeleteCommandFromToken(interp, oPtr->command); } - DelRef(oPtr); + + /* + * This decrements the refcount of oPtr. + */ + + TclOODeleteContext(contextPtr); return TCL_ERROR; } Tcl_RestoreInterpState(interp, state); *objectPtr = (Tcl_Object) oPtr; - DelRef(oPtr); + + /* + * This decrements the refcount of oPtr. + */ + + TclOODeleteContext(contextPtr); return TCL_OK; } @@ -1844,6 +1853,7 @@ Tcl_CopyObjectInstance( Class *mixinPtr; CallContext *contextPtr; Tcl_Obj *keyPtr, *filterObj, *variableObj, *args[3]; + PrivateVariableMapping *privateVariable; int i, result; /* @@ -1885,16 +1895,22 @@ Tcl_CopyObjectInstance( * Copy the object's mixin references to the new object. */ - FOREACH(mixinPtr, o2Ptr->mixins) { - if (mixinPtr != o2Ptr->selfCls) { - TclOORemoveFromInstances(o2Ptr, mixinPtr); + if (o2Ptr->mixins.num != 0) { + FOREACH(mixinPtr, o2Ptr->mixins) { + if (mixinPtr && mixinPtr != o2Ptr->selfCls) { + TclOORemoveFromInstances(o2Ptr, mixinPtr); + } + TclOODecrRefCount(mixinPtr->thisPtr); } + ckfree(o2Ptr->mixins.list); } DUPLICATE(o2Ptr->mixins, oPtr->mixins, Class *); FOREACH(mixinPtr, o2Ptr->mixins) { - if (mixinPtr != o2Ptr->selfCls) { + if (mixinPtr && mixinPtr != o2Ptr->selfCls) { TclOOAddToInstances(o2Ptr, mixinPtr); } + /* For the reference just created in DUPLICATE */ + AddRef(mixinPtr->thisPtr); } /* @@ -1907,7 +1923,7 @@ Tcl_CopyObjectInstance( } /* - * Copy the object's variable resolution list to the new object. + * Copy the object's variable resolution lists to the new object. */ DUPLICATE(o2Ptr->variables, oPtr->variables, Tcl_Obj *); @@ -1915,6 +1931,13 @@ Tcl_CopyObjectInstance( Tcl_IncrRefCount(variableObj); } + DUPLICATE(o2Ptr->privateVariables, oPtr->privateVariables, + PrivateVariableMapping); + FOREACH_STRUCT(privateVariable, o2Ptr->privateVariables) { + Tcl_IncrRefCount(privateVariable->variableObj); + Tcl_IncrRefCount(privateVariable->fullNameObj); + } + /* * Copy the object's flags to the new object, clearing those that must be * kept object-local. The duplicate is never deleted at this point, nor is @@ -1924,7 +1947,6 @@ Tcl_CopyObjectInstance( o2Ptr->flags = oPtr->flags & ~( OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING); - /* * Copy the object's metadata. */ @@ -1973,6 +1995,7 @@ Tcl_CopyObjectInstance( FOREACH(superPtr, cls2Ptr->superclasses) { TclOORemoveFromSubclasses(cls2Ptr, superPtr); + TclOODecrRefCount(superPtr->thisPtr); } if (cls2Ptr->superclasses.num) { cls2Ptr->superclasses.list = ckrealloc(cls2Ptr->superclasses.list, @@ -1986,6 +2009,11 @@ Tcl_CopyObjectInstance( cls2Ptr->superclasses.num = clsPtr->superclasses.num; FOREACH(superPtr, cls2Ptr->superclasses) { TclOOAddToSubclasses(cls2Ptr, superPtr); + + /* For the new item in cls2Ptr->superclasses that memcpy just + * created + */ + AddRef(superPtr->thisPtr); } /* @@ -1998,7 +2026,7 @@ Tcl_CopyObjectInstance( } /* - * Copy the source class's variable resolution list. + * Copy the source class's variable resolution lists. */ DUPLICATE(cls2Ptr->variables, clsPtr->variables, Tcl_Obj *); @@ -2006,20 +2034,30 @@ Tcl_CopyObjectInstance( Tcl_IncrRefCount(variableObj); } + DUPLICATE(cls2Ptr->privateVariables, clsPtr->privateVariables, + PrivateVariableMapping); + FOREACH_STRUCT(privateVariable, cls2Ptr->privateVariables) { + Tcl_IncrRefCount(privateVariable->variableObj); + Tcl_IncrRefCount(privateVariable->fullNameObj); + } + /* * Duplicate the source class's mixins (which cannot be circular * references to the duplicate). */ - FOREACH(mixinPtr, cls2Ptr->mixins) { - TclOORemoveFromMixinSubs(cls2Ptr, mixinPtr); - } if (cls2Ptr->mixins.num != 0) { + FOREACH(mixinPtr, cls2Ptr->mixins) { + TclOORemoveFromMixinSubs(cls2Ptr, mixinPtr); + TclOODecrRefCount(mixinPtr->thisPtr); + } ckfree(clsPtr->mixins.list); } DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *); FOREACH(mixinPtr, cls2Ptr->mixins) { TclOOAddToMixinSubs(cls2Ptr, mixinPtr); + /* For the copy just created in DUPLICATE */ + AddRef(mixinPtr->thisPtr); } /* @@ -2075,7 +2113,8 @@ Tcl_CopyObjectInstance( } TclResetRewriteEnsemble(interp, 1); - contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL); + contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL, + NULL, NULL); if (contextPtr) { args[0] = TclOOObjectName(interp, o2Ptr); args[1] = oPtr->fPtr->clonedName; @@ -2365,7 +2404,7 @@ Tcl_ObjectSetMetadata( * * TclOOPublicObjectCmd, TclOOPrivateObjectCmd, TclOOInvokeObject -- * - * Main entry point for object invokations. The Public* and Private* + * Main entry point for object invocations. The Public* and Private* * wrapper functions (implementations of both object instance commands * and [my]) are just thin wrappers round the main TclOOObjectCmdCore * function. Note that the core is function is NRE-aware. @@ -2448,10 +2487,47 @@ TclOOInvokeObject( /* * ---------------------------------------------------------------------- * + * TclOOMyClassObjCmd, MyClassNRObjCmd -- + * + * Special trap door to allow an object to delegate simply to its class. + * + * ---------------------------------------------------------------------- + */ + +int +TclOOMyClassObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + return Tcl_NRCallObjProc(interp, MyClassNRObjCmd, clientData, objc, objv); +} + +static int +MyClassNRObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = clientData; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "methodName ?arg ...?"); + return TCL_ERROR; + } + return TclOOObjectCmdCore(oPtr->selfCls->thisPtr, interp, objc, objv, 0, + NULL); +} + +/* + * ---------------------------------------------------------------------- + * * TclOOObjectCmdCore, FinalizeObjectCall -- * - * Main function for object invokations. Does call chain creation, - * management and invokation. The function FinalizeObjectCall exists to + * Main function for object invocations. Does call chain creation, + * management and invocation. The function FinalizeObjectCall exists to * clean up after the non-recursive processing of TclOOObjectCmdCore. * * ---------------------------------------------------------------------- @@ -2463,7 +2539,7 @@ TclOOObjectCmdCore( Tcl_Interp *interp, /* The interpreter containing the object. */ int objc, /* How many arguments are being passed in. */ Tcl_Obj *const *objv, /* The array of arguments. */ - int flags, /* Whether this is an invokation through the + int flags, /* Whether this is an invocation through the * public or the private command interface. */ Class *startCls) /* Where to start in the call chain, or NULL * if we are to start at the front with @@ -2472,6 +2548,9 @@ TclOOObjectCmdCore( { CallContext *contextPtr; Tcl_Obj *methodNamePtr; + CallFrame *framePtr = ((Interp *) interp)->varFramePtr; + Object *callerObjPtr = NULL; + Class *callerClsPtr = NULL; int result; /* @@ -2486,6 +2565,24 @@ TclOOObjectCmdCore( } /* + * Determine if we're in a context that can see the extra, private methods + * in this class. + */ + + if (framePtr->isProcCallFrame & FRAME_IS_METHOD) { + CallContext *callerContextPtr = framePtr->clientData; + Method *callerMethodPtr = + callerContextPtr->callPtr->chain[callerContextPtr->index].mPtr; + + if (callerMethodPtr->declaringObjectPtr) { + callerObjPtr = callerMethodPtr->declaringObjectPtr; + } + if (callerMethodPtr->declaringClassPtr) { + callerClsPtr = callerMethodPtr->declaringClassPtr; + } + } + + /* * Give plugged in code a chance to remap the method name. */ @@ -2512,7 +2609,8 @@ TclOOObjectCmdCore( Tcl_IncrRefCount(mappedMethodName); contextPtr = TclOOGetCallContext(oPtr, mappedMethodName, - flags | (oPtr->flags & FILTER_HANDLING), methodNamePtr); + flags | (oPtr->flags & FILTER_HANDLING), callerObjPtr, + callerClsPtr, methodNamePtr); TclDecrRefCount(mappedMethodName); if (contextPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -2529,7 +2627,8 @@ TclOOObjectCmdCore( noMapping: contextPtr = TclOOGetCallContext(oPtr, methodNamePtr, - flags | (oPtr->flags & FILTER_HANDLING), NULL); + flags | (oPtr->flags & FILTER_HANDLING), callerObjPtr, + callerClsPtr, NULL); if (contextPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "impossible to invoke method \"%s\": no defined method or" @@ -2652,7 +2751,7 @@ Tcl_ObjectContextInvokeNext( * call context while we process the body. However, need to adjust the * argument-skip control because we're guaranteed to have a single prefix * arg (i.e., 'next') and not the variable amount that can happen because - * method invokations (i.e., '$obj meth' and 'my meth'), constructors + * method invocations (i.e., '$obj meth' and 'my meth'), constructors * (i.e., '$cls new' and '$cls create obj') and destructors (no args at * all) come through the same code. */ @@ -2721,7 +2820,7 @@ TclNRObjectContextInvokeNext( * call context while we process the body. However, need to adjust the * argument-skip control because we're guaranteed to have a single prefix * arg (i.e., 'next') and not the variable amount that can happen because - * method invokations (i.e., '$obj meth' and 'my meth'), constructors + * method invocations (i.e., '$obj meth' and 'my meth'), constructors * (i.e., '$cls new' and '$cls create obj') and destructors (no args at * all) come through the same code. */ @@ -2936,7 +3035,7 @@ int Tcl_ObjectDeleted( Tcl_Object object) { - return Deleted(object) ? 1 : 0; + return ((Object *)object)->command == NULL; } Tcl_Object diff --git a/generic/tclOO.decls b/generic/tclOO.decls index 31d1113..f1bb320 100644 --- a/generic/tclOO.decls +++ b/generic/tclOO.decls @@ -1,12 +1,24 @@ +# tclOO.decls -- +# +# This file contains the declarations for all supported public functions +# that are exported by the TclOO package that is embedded within the Tcl +# library via the stubs table. This file is used to generate the +# tclOODecls.h, tclOOIntDecls.h and tclOOStubInit.c files. +# +# Copyright (c) 2008-2013 by Donal K. Fellows. +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + library tclOO ###################################################################### -# public API +# Public API, exposed for general users of TclOO. # interface tclOO hooks tclOOInt -scspec TCLOOAPI +scspec TCLAPI declare 0 { Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, @@ -46,12 +58,12 @@ declare 10 { } declare 11 { Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object, - Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, + Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, ClientData clientData) } declare 12 { Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, - Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, + Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, ClientData clientData) } declare 13 { @@ -114,9 +126,14 @@ declare 27 { declare 28 { Tcl_Obj *Tcl_GetObjectName(Tcl_Interp *interp, Tcl_Object object) } +declare 29 { + int Tcl_MethodIsPrivate(Tcl_Method method) +} ###################################################################### -# private API, exposed to support advanced OO systems that plug in on top +# Private API, exposed to support advanced OO systems that plug in on top of +# TclOO; not intended for general use and does not have any commitment to +# long-term support. # interface tclOOInt diff --git a/generic/tclOO.h b/generic/tclOO.h index cf253b1..9c1dd1e 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -12,21 +12,6 @@ #ifndef TCLOO_H_INCLUDED #define TCLOO_H_INCLUDED -#include "tcl.h" - -#ifndef TCLOOAPI -# if defined(BUILD_tcl) || defined(BUILD_TclOO) -# define TCLOOAPI MODULE_SCOPE -# else -# define TCLOOAPI extern -# undef USE_TCLOO_STUBS -# define USE_TCLOO_STUBS 1 -# endif -#endif - -extern const char *TclOOInitializeStubs( - Tcl_Interp *, const char *version); -#define Tcl_OOInitStubs(interp) TclOOInitializeStubs((interp), TCLOO_VERSION) /* * Be careful when it comes to versioning; need to make sure that the @@ -39,9 +24,27 @@ extern const char *TclOOInitializeStubs( * win/tclooConfig.sh */ -#define TCLOO_VERSION "1.0" +#define TCLOO_VERSION "1.2.0" #define TCLOO_PATCHLEVEL TCLOO_VERSION +#include "tcl.h" + +/* + * For C++ compilers, use extern "C" + */ + +#ifdef __cplusplus +extern "C" { +#endif + +extern const char *TclOOInitializeStubs( + Tcl_Interp *, const char *version); +#define Tcl_OOInitStubs(interp) \ + TclOOInitializeStubs((interp), TCLOO_VERSION) +#ifndef USE_TCL_STUBS +# define TclOOInitializeStubs(interp, version) (TCLOO_PATCHLEVEL) +#endif + /* * These are opaque types. */ @@ -96,6 +99,15 @@ typedef struct { */ #define TCL_OO_METHOD_VERSION_CURRENT 1 + +/* + * Visibility constants for the flags parameter to Tcl_NewMethod and + * Tcl_NewInstanceMethod. + */ + +#define TCL_OO_METHOD_PUBLIC 1 +#define TCL_OO_METHOD_UNEXPORTED 0 +#define TCL_OO_METHOD_PRIVATE 0x20 /* * The type of some object (or class) metadata. This describes how to delete @@ -130,6 +142,9 @@ typedef struct { #include "tclOODecls.h" +#ifdef __cplusplus +} +#endif #endif /* diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index f8cd1a4..13c98f4 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -4,7 +4,7 @@ * This file contains implementations of the "simple" commands and * methods from the object-system core. * - * Copyright (c) 2005-2012 by Donal K. Fellows + * Copyright (c) 2005-2013 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -17,16 +17,11 @@ #include "tclOOInt.h" static inline Tcl_Object *AddConstructionFinalizer(Tcl_Interp *interp); -static int AfterNRDestructor(ClientData data[], - Tcl_Interp *interp, int result); -static int DecrRefsPostClassConstructor(ClientData data[], - Tcl_Interp *interp, int result); -static int FinalizeConstruction(ClientData data[], - Tcl_Interp *interp, int result); -static int FinalizeEval(ClientData data[], - Tcl_Interp *interp, int result); -static int RestoreFrame(ClientData data[], - Tcl_Interp *interp, int result); +static Tcl_NRPostProc AfterNRDestructor; +static Tcl_NRPostProc DecrRefsPostClassConstructor; +static Tcl_NRPostProc FinalizeConstruction; +static Tcl_NRPostProc FinalizeEval; +static Tcl_NRPostProc NextRestoreFrame; /* * ---------------------------------------------------------------------- @@ -88,7 +83,7 @@ TclOO_Class_Constructor( Tcl_Obj *const *objv) { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); - Tcl_Obj *invoke[3]; + Tcl_Obj **invoke, *nameObj; if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -99,9 +94,21 @@ TclOO_Class_Constructor( } /* + * Make the class definition delegate. This is special; it doesn't reenter + * here (and the class definition delegate doesn't run any constructors). + */ + + nameObj = Tcl_NewStringObj(oPtr->namespacePtr->fullName, -1); + Tcl_AppendToObj(nameObj, ":: oo ::delegate", -1); + Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->fPtr->classCls, + TclGetString(nameObj), NULL, -1, NULL, -1); + Tcl_DecrRefCount(nameObj); + + /* * Delegate to [oo::define] to do the work. */ + invoke = ckalloc(3 * sizeof(Tcl_Obj *)); invoke[0] = oPtr->fPtr->defineName; invoke[1] = TclOOObjectName(interp, oPtr); invoke[2] = objv[objc-1]; @@ -115,7 +122,7 @@ TclOO_Class_Constructor( Tcl_IncrRefCount(invoke[1]); Tcl_IncrRefCount(invoke[2]); TclNRAddCallback(interp, DecrRefsPostClassConstructor, - invoke[0], invoke[1], invoke[2], NULL); + invoke, oPtr, NULL, NULL); /* * Tricky point: do not want the extra reported level in the Tcl stack @@ -131,10 +138,28 @@ DecrRefsPostClassConstructor( Tcl_Interp *interp, int result) { - TclDecrRefCount((Tcl_Obj *) data[0]); - TclDecrRefCount((Tcl_Obj *) data[1]); - TclDecrRefCount((Tcl_Obj *) data[2]); - return result; + Tcl_Obj **invoke = data[0]; + Object *oPtr = data[1]; + Tcl_InterpState saved; + int code; + + TclDecrRefCount(invoke[0]); + TclDecrRefCount(invoke[1]); + TclDecrRefCount(invoke[2]); + invoke[0] = Tcl_NewStringObj("::oo::MixinClassDelegates", -1); + invoke[1] = TclOOObjectName(interp, oPtr); + Tcl_IncrRefCount(invoke[0]); + Tcl_IncrRefCount(invoke[1]); + saved = Tcl_SaveInterpState(interp, result); + code = Tcl_EvalObjv(interp, 2, invoke, 0); + TclDecrRefCount(invoke[0]); + TclDecrRefCount(invoke[1]); + ckfree(invoke); + if (code != TCL_OK) { + Tcl_DiscardInterpState(saved); + return code; + } + return Tcl_RestoreInterpState(interp, saved); } /* @@ -348,7 +373,8 @@ TclOO_Object_Destroy( } if (!(oPtr->flags & DESTRUCTOR_CALLED)) { oPtr->flags |= DESTRUCTOR_CALLED; - contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL); + contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL, + NULL); if (contextPtr != NULL) { contextPtr->callPtr->flags |= DESTRUCTOR; contextPtr->skip = 0; @@ -403,7 +429,6 @@ TclOO_Object_Eval( register const int skip = Tcl_ObjectContextSkippedArgs(context); CallFrame *framePtr, **framePtrPtr = &framePtr; Tcl_Obj *scriptPtr; - int result; CmdFrame *invoker; if (objc-1 < skip) { @@ -416,11 +441,8 @@ TclOO_Object_Eval( * command(s). */ - result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, + (void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, Tcl_GetObjectNamespace(object), 0); - if (result != TCL_OK) { - return TCL_ERROR; - } framePtr->objc = objc; framePtr->objv = objv; /* Reference counts do not need to be * incremented here. */ @@ -504,9 +526,12 @@ TclOO_Object_Unknown( Tcl_Obj *const *objv) /* The actual arguments. */ { CallContext *contextPtr = (CallContext *) context; + Object *callerObj = NULL; + Class *callerCls = NULL; Object *oPtr = contextPtr->oPtr; const char **methodNames; int numMethodNames, i, skip = Tcl_ObjectContextSkippedArgs(context); + CallFrame *framePtr = ((Interp *) interp)->varFramePtr; Tcl_Obj *errorMsg; /* @@ -521,10 +546,31 @@ TclOO_Object_Unknown( } /* + * Determine if the calling context should know about extra private + * methods, and if so, which. + */ + + if (framePtr->isProcCallFrame & FRAME_IS_METHOD) { + CallContext *callerContext = framePtr->clientData; + Method *mPtr = callerContext->callPtr->chain[ + callerContext->index].mPtr; + + if (mPtr->declaringObjectPtr) { + if (oPtr == mPtr->declaringObjectPtr) { + callerObj = mPtr->declaringObjectPtr; + } + } else { + if (TclOOIsReachable(mPtr->declaringClassPtr, oPtr->selfCls)) { + callerCls = mPtr->declaringClassPtr; + } + } + } + + /* * Get the list of methods that we want to know about. */ - numMethodNames = TclOOGetSortedMethodList(oPtr, + numMethodNames = TclOOGetSortedMethodList(oPtr, callerObj, callerCls, contextPtr->callPtr->flags & PUBLIC_METHOD, &methodNames); /* @@ -689,6 +735,7 @@ TclOO_Object_VarName( { Var *varPtr, *aryVar; Tcl_Obj *varNamePtr, *argPtr; + CallFrame *framePtr = ((Interp *) interp)->varFramePtr; const char *arg; if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { @@ -714,6 +761,58 @@ TclOO_Object_VarName( Tcl_Namespace *namespacePtr = Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context)); + /* + * Private method handling. [TIP 500] + * + * If we're in a context that can see some private methods of an + * object, we may need to precede a variable name with its prefix. + * This is a little tricky as we need to check through the inheritance + * hierarchy when the method was declared by a class to see if the + * current object is an instance of that class. + */ + + if (framePtr->isProcCallFrame & FRAME_IS_METHOD) { + Object *oPtr = (Object *) Tcl_ObjectContextObject(context); + CallContext *callerContext = framePtr->clientData; + Method *mPtr = callerContext->callPtr->chain[ + callerContext->index].mPtr; + PrivateVariableMapping *pvPtr; + int i; + + if (mPtr->declaringObjectPtr == oPtr) { + FOREACH_STRUCT(pvPtr, oPtr->privateVariables) { + if (!strcmp(Tcl_GetString(pvPtr->variableObj), + Tcl_GetString(argPtr))) { + argPtr = pvPtr->fullNameObj; + break; + } + } + } else if (mPtr->declaringClassPtr && + mPtr->declaringClassPtr->privateVariables.num) { + Class *clsPtr = mPtr->declaringClassPtr; + int isInstance = TclOOIsReachable(clsPtr, oPtr->selfCls); + Class *mixinCls; + + if (!isInstance) { + FOREACH(mixinCls, oPtr->mixins) { + if (TclOOIsReachable(clsPtr, mixinCls)) { + isInstance = 1; + break; + } + } + } + if (isInstance) { + FOREACH_STRUCT(pvPtr, clsPtr->privateVariables) { + if (!strcmp(Tcl_GetString(pvPtr->variableObj), + Tcl_GetString(argPtr))) { + argPtr = pvPtr->fullNameObj; + break; + } + } + } + } + } + varNamePtr = Tcl_NewStringObj(namespacePtr->fullName, -1); Tcl_AppendToObj(varNamePtr, "::", 2); Tcl_AppendObjToObj(varNamePtr, argPtr); @@ -734,26 +833,16 @@ TclOO_Object_VarName( varNamePtr = Tcl_NewObj(); if (aryVar != NULL) { - Tcl_HashEntry *hPtr; - Tcl_HashSearch search; - Tcl_GetVariableFullName(interp, (Tcl_Var) aryVar, varNamePtr); /* * WARNING! This code pokes inside the implementation of hash tables! */ - hPtr = Tcl_FirstHashEntry((Tcl_HashTable *) aryVar->value.tablePtr, - &search); - while (hPtr != NULL) { - if (varPtr == Tcl_GetHashValue(hPtr)) { - Tcl_AppendToObj(varNamePtr, "(", -1); - Tcl_AppendObjToObj(varNamePtr, hPtr->key.objPtr); - Tcl_AppendToObj(varNamePtr, ")", -1); - break; - } - hPtr = Tcl_NextHashEntry(&search); - } + Tcl_AppendToObj(varNamePtr, "(", -1); + Tcl_AppendObjToObj(varNamePtr, ((VarInHash *) + varPtr)->entry.key.objPtr); + Tcl_AppendToObj(varNamePtr, ")", -1); } else { Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, varNamePtr); } @@ -804,7 +893,7 @@ TclOONextObjCmd( * that this is like [uplevel 1] and not [eval]. */ - TclNRAddCallback(interp, RestoreFrame, framePtr, NULL, NULL, NULL); + TclNRAddCallback(interp, NextRestoreFrame, framePtr, NULL,NULL,NULL); iPtr->varFramePtr = framePtr->callerVarPtr; return TclNRObjectContextInvokeNext(interp, context, objc, objv, 1); } @@ -822,6 +911,7 @@ TclOONextToObjCmd( CallContext *contextPtr; int i; Tcl_Object object; + const char *methodType; /* * Start with sanity checks on the calling context to make sure that we @@ -873,8 +963,8 @@ TclOONextToObjCmd( * context. Note that this is like [uplevel 1] and not [eval]. */ - TclNRAddCallback(interp, RestoreFrame, framePtr, contextPtr, - INT2PTR(contextPtr->index), NULL); + TclNRAddCallback(interp, NextRestoreFrame, framePtr, + contextPtr, INT2PTR(contextPtr->index), NULL); contextPtr->index = i-1; iPtr->varFramePtr = framePtr->callerVarPtr; return TclNRObjectContextInvokeNext(interp, @@ -887,24 +977,35 @@ TclOONextToObjCmd( * is on the chain but unreachable, or not on the chain at all. */ + if (contextPtr->callPtr->flags & CONSTRUCTOR) { + methodType = "constructor"; + } else if (contextPtr->callPtr->flags & DESTRUCTOR) { + methodType = "destructor"; + } else { + methodType = "method"; + } + for (i=contextPtr->index ; i>=0 ; i--) { struct MInvoke *miPtr = contextPtr->callPtr->chain + i; if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "method implementation by \"%s\" not reachable from here", - TclGetString(objv[1]))); + "%s implementation by \"%s\" not reachable from here", + methodType, TclGetString(objv[1]))); + Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_REACHABLE", + NULL); return TCL_ERROR; } } Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "method has no non-filter implementation by \"%s\"", - TclGetString(objv[1]))); + "%s has no non-filter implementation by \"%s\"", + methodType, TclGetString(objv[1]))); + Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_THERE", NULL); return TCL_ERROR; } static int -RestoreFrame( +NextRestoreFrame( ClientData data[], Tcl_Interp *interp, int result) @@ -1176,8 +1277,9 @@ TclOOCopyObjectCmd( { Tcl_Object oPtr, o2Ptr; - if (objc < 2 || objc > 3) { - Tcl_WrongNumArgs(interp, 1, objv, "sourceName ?targetName?"); + if (objc < 2 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, + "sourceName ?targetName? ?targetNamespace?"); return TCL_ERROR; } @@ -1197,24 +1299,32 @@ TclOOCopyObjectCmd( if (objc == 2) { o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, NULL, NULL); } else { - const char *name; - Tcl_DString buffer; + const char *name, *namespaceName; name = TclGetString(objv[2]); - Tcl_DStringInit(&buffer); - if (name[0]!=':' || name[1]!=':') { - Interp *iPtr = (Interp *) interp; + if (name[0] == '\0') { + name = NULL; + } - if (iPtr->varFramePtr != NULL) { - Tcl_DStringAppend(&buffer, - iPtr->varFramePtr->nsPtr->fullName, -1); + /* + * Choose a unique namespace name if the user didn't supply one. + */ + + namespaceName = NULL; + if (objc == 4) { + namespaceName = TclGetString(objv[3]); + + if (namespaceName[0] == '\0') { + namespaceName = NULL; + } else if (Tcl_FindNamespace(interp, namespaceName, NULL, + 0) != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s refers to an existing namespace", namespaceName)); + return TCL_ERROR; } - TclDStringAppendLiteral(&buffer, "::"); - Tcl_DStringAppend(&buffer, name, -1); - name = Tcl_DStringValue(&buffer); } - o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, name, NULL); - Tcl_DStringFree(&buffer); + + o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, name, namespaceName); } if (o2Ptr == NULL) { diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 26fd09f..bc84da0 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -38,6 +38,34 @@ struct ChainBuilder { #define DEFINITE_PUBLIC 0x200000 #define KNOWN_STATE (DEFINITE_PROTECTED | DEFINITE_PUBLIC) #define SPECIAL (CONSTRUCTOR | DESTRUCTOR | FORCE_UNKNOWN) +#define BUILDING_MIXINS 0x400000 +#define TRAVERSED_MIXIN 0x800000 +#define OBJECT_MIXIN 0x1000000 +#define MIXIN_CONSISTENT(flags) \ + (((flags) & OBJECT_MIXIN) || \ + !((flags) & BUILDING_MIXINS) == !((flags) & TRAVERSED_MIXIN)) + +/* + * Note that the flag bit PRIVATE_METHOD has a confusing name; it's just for + * Itcl's special type of private. + */ + +#define IS_PUBLIC(mPtr) \ + (((mPtr)->flags & PUBLIC_METHOD) != 0) +#define IS_UNEXPORTED(mPtr) \ + (((mPtr)->flags & SCOPE_FLAGS) == 0) +#define IS_ITCLPRIVATE(mPtr) \ + (((mPtr)->flags & PRIVATE_METHOD) != 0) +#define IS_PRIVATE(mPtr) \ + (((mPtr)->flags & TRUE_PRIVATE_METHOD) != 0) +#define WANT_PUBLIC(flags) \ + (((flags) & PUBLIC_METHOD) != 0) +#define WANT_UNEXPORTED(flags) \ + (((flags) & (PRIVATE_METHOD | TRUE_PRIVATE_METHOD)) == 0) +#define WANT_ITCLPRIVATE(flags) \ + (((flags) & PRIVATE_METHOD) != 0) +#define WANT_PRIVATE(flags) \ + (((flags) & TRUE_PRIVATE_METHOD) != 0) /* * Function declarations for things defined in this file. @@ -45,34 +73,48 @@ struct ChainBuilder { static void AddClassFiltersToCallContext(Object *const oPtr, Class *clsPtr, struct ChainBuilder *const cbPtr, - Tcl_HashTable *const doneFilters); + Tcl_HashTable *const doneFilters, int flags); static void AddClassMethodNames(Class *clsPtr, const int flags, - Tcl_HashTable *const namesPtr); + Tcl_HashTable *const namesPtr, + Tcl_HashTable *const examinedClassesPtr); static inline void AddMethodToCallChain(Method *const mPtr, struct ChainBuilder *const cbPtr, Tcl_HashTable *const doneFilters, + Class *const filterDecl, int flags); +static inline int AddInstancePrivateToCallContext(Object *const oPtr, + Tcl_Obj *const methodNameObj, + struct ChainBuilder *const cbPtr, int flags); +static inline void AddStandardMethodName(int flags, Tcl_Obj *namePtr, + Method *mPtr, Tcl_HashTable *namesPtr); +static inline void AddPrivateMethodNames(Tcl_HashTable *methodsTablePtr, + Tcl_HashTable *namesPtr); +static inline int AddSimpleChainToCallContext(Object *const oPtr, + Class *const contextCls, + Tcl_Obj *const methodNameObj, + struct ChainBuilder *const cbPtr, + Tcl_HashTable *const doneFilters, int flags, Class *const filterDecl); -static inline void AddSimpleChainToCallContext(Object *const oPtr, +static int AddPrivatesFromClassChainToCallContext(Class *classPtr, + Class *const contextCls, Tcl_Obj *const methodNameObj, struct ChainBuilder *const cbPtr, Tcl_HashTable *const doneFilters, int flags, Class *const filterDecl); -static void AddSimpleClassChainToCallContext(Class *classPtr, +static int AddSimpleClassChainToCallContext(Class *classPtr, Tcl_Obj *const methodNameObj, struct ChainBuilder *const cbPtr, Tcl_HashTable *const doneFilters, int flags, Class *const filterDecl); static int CmpStr(const void *ptr1, const void *ptr2); static void DupMethodNameRep(Tcl_Obj *srcPtr, Tcl_Obj *dstPtr); -static int FinalizeMethodRefs(ClientData data[], - Tcl_Interp *interp, int result); +static Tcl_NRPostProc FinalizeMethodRefs; static void FreeMethodNameRep(Tcl_Obj *objPtr); static inline int IsStillValid(CallChain *callPtr, Object *oPtr, int flags, int reuseMask); -static int ResetFilterFlags(ClientData data[], - Tcl_Interp *interp, int result); -static int SetFilterFlags(ClientData data[], - Tcl_Interp *interp, int result); +static Tcl_NRPostProc ResetFilterFlags; +static Tcl_NRPostProc SetFilterFlags; +static int SortMethodNames(Tcl_HashTable *namesPtr, int flags, + const char ***stringsPtr); static inline void StashCallChain(Tcl_Obj *objPtr, CallChain *callPtr); /* @@ -106,7 +148,12 @@ TclOODeleteContext( TclOODeleteChain(contextPtr->callPtr); if (oPtr != NULL) { TclStackFree(oPtr->fPtr->interp, contextPtr); - DelRef(oPtr); + + /* + * Corresponding AddRef() in TclOO.c/TclOOObjectCmdCore + */ + + TclOODecrRefCount(oPtr); } } @@ -150,7 +197,7 @@ void TclOODeleteChain( CallChain *callPtr) { - if (--callPtr->refCount >= 1) { + if (callPtr == NULL || callPtr->refCount-- > 1) { return; } if (callPtr->chain != callPtr->staticChain) { @@ -176,6 +223,7 @@ StashCallChain( CallChain *callPtr) { callPtr->refCount++; + TclGetString(objPtr); TclFreeIntRep(objPtr); objPtr->typePtr = &methodNameType; objPtr->internalRep.twoPtrValue.ptr1 = callPtr; @@ -228,7 +276,7 @@ FreeMethodNameRep( * TclOOInvokeContext -- * * Invokes a single step along a method call-chain context. Note that the - * invokation of a step along the chain can cause further steps along the + * invocation of a step along the chain can cause further steps along the * chain to be invoked. Note that this function is written to be as light * in stack usage as possible. * @@ -356,6 +404,14 @@ FinalizeMethodRefs( int TclOOGetSortedMethodList( Object *oPtr, /* The object to get the method names for. */ + Object *contextObj, /* From what context object we are inquiring. + * NULL when the context shouldn't see + * object-level private methods. Note that + * flags can override this. */ + Class *contextCls, /* From what context class we are inquiring. + * NULL when the context shouldn't see + * class-level private methods. Note that + * flags can override this. */ int flags, /* Whether we just want the public method * names. */ const char ***stringsPtr) /* Where to write a pointer to the array of @@ -363,15 +419,18 @@ TclOOGetSortedMethodList( { Tcl_HashTable names; /* Tcl_Obj* method name to "wanted in list" * mapping. */ + Tcl_HashTable examinedClasses; + /* Used to track what classes have been looked + * at. Is set-like in nature and keyed by + * pointer to class. */ FOREACH_HASH_DECLS; - int i; + int i, numStrings; Class *mixinPtr; Tcl_Obj *namePtr; Method *mPtr; - int isWantedIn; - void *isWanted; Tcl_InitObjHashTable(&names); + Tcl_InitHashTable(&examinedClasses, TCL_ONE_WORD_KEYS); /* * Name the bits used in the names table values. @@ -385,18 +444,13 @@ TclOOGetSortedMethodList( if (oPtr->methodsPtr) { FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) { - int isNew; - - if ((mPtr->flags & PRIVATE_METHOD) && !(flags & PRIVATE_METHOD)) { + if (IS_PRIVATE(mPtr)) { continue; } - hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew); - if (isNew) { - isWantedIn = ((!(flags & PUBLIC_METHOD) - || mPtr->flags & PUBLIC_METHOD) ? IN_LIST : 0); - isWantedIn |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 0); - Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn)); + if (IS_UNEXPORTED(mPtr) && !WANT_UNEXPORTED(flags)) { + continue; } + AddStandardMethodName(flags, namePtr, mPtr, &names); } } @@ -404,81 +458,46 @@ TclOOGetSortedMethodList( * Process method names due to private methods on the object's class. */ - if (flags & PRIVATE_METHOD) { + if (WANT_UNEXPORTED(flags)) { FOREACH_HASH(namePtr, mPtr, &oPtr->selfCls->classMethods) { - if (mPtr->flags & PRIVATE_METHOD) { - int isNew; - - hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew); - if (isNew) { - isWantedIn = IN_LIST; - if (mPtr->typePtr == NULL) { - isWantedIn |= NO_IMPLEMENTATION; - } - Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn)); - } else if (mPtr->typePtr != NULL) { - isWantedIn = PTR2INT(Tcl_GetHashValue(hPtr)); - if (isWantedIn & NO_IMPLEMENTATION) { - isWantedIn &= ~NO_IMPLEMENTATION; - Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn)); - } - } + if (IS_UNEXPORTED(mPtr)) { + AddStandardMethodName(flags, namePtr, mPtr, &names); } } } /* + * Process method names due to private methods on the context's object or + * class. Which must be correct if either are not NULL. + */ + + if (contextObj && contextObj->methodsPtr) { + AddPrivateMethodNames(contextObj->methodsPtr, &names); + } + if (contextCls) { + AddPrivateMethodNames(&contextCls->classMethods, &names); + } + + /* * Process (normal) method names from the class hierarchy and the mixin * hierarchy. */ - AddClassMethodNames(oPtr->selfCls, flags, &names); + AddClassMethodNames(oPtr->selfCls, flags, &names, &examinedClasses); FOREACH(mixinPtr, oPtr->mixins) { - AddClassMethodNames(mixinPtr, flags, &names); + AddClassMethodNames(mixinPtr, flags | TRAVERSED_MIXIN, &names, + &examinedClasses); } /* - * See how many (visible) method names there are. If none, we do not (and - * should not) try to sort the list of them. + * Tidy up, sort the names and resolve finally whether we really want + * them (processing export layering). */ - i = 0; - if (names.numEntries != 0) { - const char **strings; - - /* - * We need to build the list of methods to sort. We will be using - * qsort() for this, because it is very unlikely that the list will be - * heavily sorted when it is long enough to matter. - */ - - strings = ckalloc(sizeof(char *) * names.numEntries); - FOREACH_HASH(namePtr, isWanted, &names) { - if (!(flags & PUBLIC_METHOD) || (PTR2INT(isWanted) & IN_LIST)) { - if (PTR2INT(isWanted) & NO_IMPLEMENTATION) { - continue; - } - strings[i++] = TclGetString(namePtr); - } - } - - /* - * Note that 'i' may well be less than names.numEntries when we are - * dealing with public method names. - */ - - if (i > 0) { - if (i > 1) { - qsort((void *) strings, (unsigned) i, sizeof(char *), CmpStr); - } - *stringsPtr = strings; - } else { - ckfree(strings); - } - } - + Tcl_DeleteHashTable(&examinedClasses); + numStrings = SortMethodNames(&names, flags, stringsPtr); Tcl_DeleteHashTable(&names); - return i; + return numStrings; } int @@ -491,64 +510,117 @@ TclOOGetSortedClassMethodList( { Tcl_HashTable names; /* Tcl_Obj* method name to "wanted in list" * mapping. */ - FOREACH_HASH_DECLS; - int i; - Tcl_Obj *namePtr; - void *isWanted; + Tcl_HashTable examinedClasses; + /* Used to track what classes have been looked + * at. Is set-like in nature and keyed by + * pointer to class. */ + int numStrings; Tcl_InitObjHashTable(&names); + Tcl_InitHashTable(&examinedClasses, TCL_ONE_WORD_KEYS); /* * Process method names from the class hierarchy and the mixin hierarchy. */ - AddClassMethodNames(clsPtr, flags, &names); + AddClassMethodNames(clsPtr, flags, &names, &examinedClasses); + Tcl_DeleteHashTable(&examinedClasses); + + /* + * Process private method names if we should. [TIP 500] + */ + + if (WANT_PRIVATE(flags)) { + AddPrivateMethodNames(&clsPtr->classMethods, &names); + flags &= ~TRUE_PRIVATE_METHOD; + } + + /* + * Tidy up, sort the names and resolve finally whether we really want + * them (processing export layering). + */ + + numStrings = SortMethodNames(&names, flags, stringsPtr); + Tcl_DeleteHashTable(&names); + return numStrings; +} + +/* + * ---------------------------------------------------------------------- + * + * SortMethodNames -- + * + * Shared helper for TclOOGetSortedMethodList etc. that knows the method + * sorting rules. + * + * Returns: + * The length of the sorted list. + * + * ---------------------------------------------------------------------- + */ + +static int +SortMethodNames( + Tcl_HashTable *namesPtr, /* The table of names; unsorted, but contains + * whether the names are wanted and under what + * circumstances. */ + int flags, /* Whether we are looking for unexported + * methods. Full private methods are handled + * on insertion to the table. */ + const char ***stringsPtr) /* Where to store the sorted list of strings + * that we produce. ckalloced() */ +{ + const char **strings; + FOREACH_HASH_DECLS; + Tcl_Obj *namePtr; + void *isWanted; + int i = 0; /* * See how many (visible) method names there are. If none, we do not (and * should not) try to sort the list of them. */ - i = 0; - if (names.numEntries != 0) { - const char **strings; + if (namesPtr->numEntries == 0) { + *stringsPtr = NULL; + return 0; + } - /* - * We need to build the list of methods to sort. We will be using - * qsort() for this, because it is very unlikely that the list will be - * heavily sorted when it is long enough to matter. - */ + /* + * We need to build the list of methods to sort. We will be using qsort() + * for this, because it is very unlikely that the list will be heavily + * sorted when it is long enough to matter. + */ - strings = ckalloc(sizeof(char *) * names.numEntries); - FOREACH_HASH(namePtr, isWanted, &names) { - if (!(flags & PUBLIC_METHOD) || (PTR2INT(isWanted) & IN_LIST)) { - if (PTR2INT(isWanted) & NO_IMPLEMENTATION) { - continue; - } - strings[i++] = TclGetString(namePtr); + strings = ckalloc(sizeof(char *) * namesPtr->numEntries); + FOREACH_HASH(namePtr, isWanted, namesPtr) { + if (!WANT_PUBLIC(flags) || (PTR2INT(isWanted) & IN_LIST)) { + if (PTR2INT(isWanted) & NO_IMPLEMENTATION) { + continue; } + strings[i++] = TclGetString(namePtr); } + } - /* - * Note that 'i' may well be less than names.numEntries when we are - * dealing with public method names. - */ + /* + * Note that 'i' may well be less than names.numEntries when we are + * dealing with public method names. We don't sort unless there's at least + * two method names. + */ - if (i > 0) { - if (i > 1) { - qsort((void *) strings, (unsigned) i, sizeof(char *), CmpStr); - } - *stringsPtr = strings; - } else { - ckfree(strings); + if (i > 0) { + if (i > 1) { + qsort((void *) strings, (unsigned) i, sizeof(char *), CmpStr); } + *stringsPtr = strings; + } else { + ckfree(strings); + *stringsPtr = NULL; } - - Tcl_DeleteHashTable(&names); return i; } -/* Comparator for GetSortedMethodList */ +/* Comparator for SortMethodNames */ static int CmpStr( const void *ptr1, @@ -557,7 +629,7 @@ CmpStr( const char **strPtr1 = (const char **) ptr1; const char **strPtr2 = (const char **) ptr2; - return TclpUtfNcmp2(*strPtr1, *strPtr2, strlen(*strPtr1)+1); + return TclpUtfNcmp2(*strPtr1, *strPtr2, strlen(*strPtr1) + 1); } /* @@ -577,14 +649,30 @@ AddClassMethodNames( Class *clsPtr, /* Class to get method names from. */ const int flags, /* Whether we are interested in just the * public method names. */ - Tcl_HashTable *const namesPtr) + Tcl_HashTable *const namesPtr, /* Reference to the hash table to put the * information in. The hash table maps the * Tcl_Obj * method name to an integral value * describing whether the method is wanted. * This ensures that public/private override - * semantics are handled correctly.*/ + * semantics are handled correctly. */ + Tcl_HashTable *const examinedClassesPtr) + /* Hash table that tracks what classes have + * already been looked at. The keys are the + * pointers to the classes, and the values are + * immaterial. */ { + int i; + + /* + * If we've already started looking at this class, stop working on it now + * to prevent repeated work. + */ + + if (Tcl_FindHashEntry(examinedClassesPtr, (char *) clsPtr)) { + return; + } + /* * Scope all declarations so that the compiler can stand a good chance of * making the recursive step highly efficient. We also hand-implement the @@ -592,39 +680,33 @@ AddClassMethodNames( * tail-recursion optimization usefully. */ - if (clsPtr->mixins.num != 0) { - Class *mixinPtr; - int i; - - /* TODO: Beware of infinite loops! */ - FOREACH(mixinPtr, clsPtr->mixins) { - AddClassMethodNames(mixinPtr, flags, namesPtr); - } - } - while (1) { FOREACH_HASH_DECLS; Tcl_Obj *namePtr; Method *mPtr; + int isNew; - FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) { - int isNew; - - hPtr = Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew); - if (isNew) { - int isWanted = (!(flags & PUBLIC_METHOD) - || (mPtr->flags & PUBLIC_METHOD)) ? IN_LIST : 0; + (void) Tcl_CreateHashEntry(examinedClassesPtr, (char *) clsPtr, + &isNew); + if (!isNew) { + break; + } - Tcl_SetHashValue(hPtr, INT2PTR(isWanted)); - } else if ((PTR2INT(Tcl_GetHashValue(hPtr)) & NO_IMPLEMENTATION) - && mPtr->typePtr != NULL) { - int isWanted = PTR2INT(Tcl_GetHashValue(hPtr)); + if (clsPtr->mixins.num != 0) { + Class *mixinPtr; - isWanted &= ~NO_IMPLEMENTATION; - Tcl_SetHashValue(hPtr, INT2PTR(isWanted)); + FOREACH(mixinPtr, clsPtr->mixins) { + if (mixinPtr != clsPtr) { + AddClassMethodNames(mixinPtr, flags|TRAVERSED_MIXIN, + namesPtr, examinedClassesPtr); + } } } + FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) { + AddStandardMethodName(flags, namePtr, mPtr, namesPtr); + } + if (clsPtr->superclasses.num != 1) { break; } @@ -632,12 +714,111 @@ AddClassMethodNames( } if (clsPtr->superclasses.num != 0) { Class *superPtr; - int i; FOREACH(superPtr, clsPtr->superclasses) { - AddClassMethodNames(superPtr, flags, namesPtr); + AddClassMethodNames(superPtr, flags, namesPtr, + examinedClassesPtr); + } + } +} + +/* + * ---------------------------------------------------------------------- + * + * AddPrivateMethodNames, AddStandardMethodName -- + * + * Factored-out helpers for the sorted name list production functions. + * + * ---------------------------------------------------------------------- + */ + +static inline void +AddPrivateMethodNames( + Tcl_HashTable *methodsTablePtr, + Tcl_HashTable *namesPtr) +{ + FOREACH_HASH_DECLS; + Method *mPtr; + Tcl_Obj *namePtr; + + FOREACH_HASH(namePtr, mPtr, methodsTablePtr) { + if (IS_PRIVATE(mPtr)) { + int isNew; + + hPtr = Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew); + Tcl_SetHashValue(hPtr, INT2PTR(IN_LIST)); + } + } +} + +static inline void +AddStandardMethodName( + int flags, + Tcl_Obj *namePtr, + Method *mPtr, + Tcl_HashTable *namesPtr) +{ + if (!IS_PRIVATE(mPtr)) { + int isNew; + Tcl_HashEntry *hPtr = + Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew); + + if (isNew) { + int isWanted = (!WANT_PUBLIC(flags) || IS_PUBLIC(mPtr)) + ? IN_LIST : 0; + + isWanted |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 0); + Tcl_SetHashValue(hPtr, INT2PTR(isWanted)); + } else if ((PTR2INT(Tcl_GetHashValue(hPtr)) & NO_IMPLEMENTATION) + && mPtr->typePtr != NULL) { + int isWanted = PTR2INT(Tcl_GetHashValue(hPtr)); + + isWanted &= ~NO_IMPLEMENTATION; + Tcl_SetHashValue(hPtr, INT2PTR(isWanted)); + } + } +} + +#undef IN_LIST +#undef NO_IMPLEMENTATION + +/* + * ---------------------------------------------------------------------- + * + * AddInstancePrivateToCallContext -- + * + * Add private methods from the instance. Called when the calling Tcl + * context is a TclOO method declared by an object that is the same as + * the current object. Returns true iff a private method was actually + * found and added to the call chain (as this suppresses caching). + * + * ---------------------------------------------------------------------- + */ + +static inline int +AddInstancePrivateToCallContext( + Object *const oPtr, /* Object to add call chain entries for. */ + Tcl_Obj *const methodName, /* Name of method to add the call chain + * entries for. */ + struct ChainBuilder *const cbPtr, + /* Where to add the call chain entries. */ + int flags) /* What sort of call chain are we building. */ +{ + Tcl_HashEntry *hPtr; + Method *mPtr; + int donePrivate = 0; + + if (oPtr->methodsPtr) { + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodName); + if (hPtr != NULL) { + mPtr = Tcl_GetHashValue(hPtr); + if (IS_PRIVATE(mPtr)) { + AddMethodToCallChain(mPtr, cbPtr, NULL, NULL, flags); + donePrivate = 1; + } } } + return donePrivate; } /* @@ -648,14 +829,17 @@ AddClassMethodNames( * The core of the call-chain construction engine, this handles calling a * particular method on a particular object. Note that filters and * unknown handling are already handled by the logic that uses this - * function. + * function. Returns true if a private method was one of those found. * * ---------------------------------------------------------------------- */ -static inline void +static inline int AddSimpleChainToCallContext( Object *const oPtr, /* Object to add call chain entries for. */ + Class *const contextCls, /* Context class; the currently considered + * class is equal to this, private methods may + * also be added. [TIP 500] */ Tcl_Obj *const methodNameObj, /* Name of method to add the call chain * entries for. */ @@ -669,44 +853,62 @@ AddSimpleChainToCallContext( * NULL, either the filter was declared by the * object or this isn't a filter. */ { - int i; + int i, foundPrivate = 0, blockedUnexported = 0; + Tcl_HashEntry *hPtr; + Method *mPtr; if (!(flags & (KNOWN_STATE | SPECIAL)) && oPtr->methodsPtr) { - Tcl_HashEntry *hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, - (char *) methodNameObj); + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodNameObj); if (hPtr != NULL) { - Method *mPtr = Tcl_GetHashValue(hPtr); - - if (flags & PUBLIC_METHOD) { - if (!(mPtr->flags & PUBLIC_METHOD)) { - return; + mPtr = Tcl_GetHashValue(hPtr); + if (!IS_PRIVATE(mPtr)) { + if (WANT_PUBLIC(flags)) { + if (!IS_PUBLIC(mPtr)) { + blockedUnexported = 1; + } else { + flags |= DEFINITE_PUBLIC; + } } else { - flags |= DEFINITE_PUBLIC; + flags |= DEFINITE_PROTECTED; } - } else { - flags |= DEFINITE_PROTECTED; } } } if (!(flags & SPECIAL)) { - Tcl_HashEntry *hPtr; Class *mixinPtr; FOREACH(mixinPtr, oPtr->mixins) { - AddSimpleClassChainToCallContext(mixinPtr, methodNameObj, cbPtr, - doneFilters, flags, filterDecl); + if (contextCls) { + foundPrivate |= AddPrivatesFromClassChainToCallContext( + mixinPtr, contextCls, methodNameObj, cbPtr, + doneFilters, flags|TRAVERSED_MIXIN, filterDecl); + } + foundPrivate |= AddSimpleClassChainToCallContext(mixinPtr, + methodNameObj, cbPtr, doneFilters, + flags | TRAVERSED_MIXIN, filterDecl); } - if (oPtr->methodsPtr) { + if (oPtr->methodsPtr && !blockedUnexported) { hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char*) methodNameObj); if (hPtr != NULL) { - AddMethodToCallChain(Tcl_GetHashValue(hPtr), cbPtr, - doneFilters, filterDecl); + mPtr = Tcl_GetHashValue(hPtr); + if (!IS_PRIVATE(mPtr)) { + AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, + flags); + } } } } - AddSimpleClassChainToCallContext(oPtr->selfCls, methodNameObj, cbPtr, - doneFilters, flags, filterDecl); + if (contextCls) { + foundPrivate |= AddPrivatesFromClassChainToCallContext(oPtr->selfCls, + contextCls, methodNameObj, cbPtr, doneFilters, flags, + filterDecl); + } + if (!blockedUnexported) { + foundPrivate |= AddSimpleClassChainToCallContext(oPtr->selfCls, + methodNameObj, cbPtr, doneFilters, flags, filterDecl); + } + return foundPrivate; } /* @@ -732,9 +934,15 @@ AddMethodToCallChain( * processed. If NULL, not processing filters. * Note that this function does not update * this hashtable. */ - Class *const filterDecl) /* The class that declared the filter. If + Class *const filterDecl, /* The class that declared the filter. If * NULL, either the filter was declared by the * object or this isn't a filter. */ + int flags) /* Used to check if we're mixin-consistent + * only. Mixin-consistent means that either + * we're looking to add things from a mixin + * and we have passed a mixin, or we're not + * looking to add things from a mixin and have + * not passed a mixin. */ { register CallChain *callPtr = cbPtr->callChainPtr; int i; @@ -743,9 +951,11 @@ AddMethodToCallChain( * Return if this is just an entry used to record whether this is a public * method. If so, there's nothing real to call and so nothing to add to * the call chain. + * + * This is also where we enforce mixin-consistency. */ - if (mPtr == NULL || mPtr->typePtr == NULL) { + if (mPtr == NULL || mPtr->typePtr == NULL || !MIXIN_CONSISTENT(flags)) { return; } @@ -761,8 +971,8 @@ AddMethodToCallChain( * should be sufficient for [incr Tcl] support though. */ - if (!(callPtr->flags & PRIVATE_METHOD) - && (mPtr->flags & PRIVATE_METHOD) + if (!WANT_UNEXPORTED(callPtr->flags) + && IS_UNEXPORTED(mPtr) && (mPtr->declaringClassPtr != NULL) && (mPtr->declaringClassPtr != cbPtr->oPtr->selfCls)) { return; @@ -780,7 +990,7 @@ AddMethodToCallChain( * Call chain semantics states that methods come as *late* in the * call chain as possible. This is done by copying down the * following methods. Note that this does not change the number of - * method invokations in the call chain; it just rearranges them. + * method invocations in the call chain; it just rearranges them. */ Class *declCls = callPtr->chain[i].filterDeclarer; @@ -803,7 +1013,7 @@ AddMethodToCallChain( if (callPtr->numChain == CALL_CHAIN_STATIC_SIZE) { callPtr->chain = - ckalloc(sizeof(struct MInvoke) * (callPtr->numChain+1)); + ckalloc(sizeof(struct MInvoke) * (callPtr->numChain + 1)); memcpy(callPtr->chain, callPtr->staticChain, sizeof(struct MInvoke) * callPtr->numChain); } else if (callPtr->numChain > CALL_CHAIN_STATIC_SIZE) { @@ -850,6 +1060,7 @@ InitCallChain( * ---------------------------------------------------------------------- * * IsStillValid -- + * * Calculates whether the given call chain can be used for executing a * method for the given object. The condition on a chain from a cached * location being reusable is: @@ -885,7 +1096,7 @@ IsStillValid( * TclOOGetCallContext -- * * Responsible for constructing the call context, an ordered list of all - * method implementations to be called as part of a method invokation. + * method implementations to be called as part of a method invocation. * This method is central to the whole operation of the OO system. * * ---------------------------------------------------------------------- @@ -901,6 +1112,12 @@ TclOOGetCallContext( * Only the bits PUBLIC_METHOD, CONSTRUCTOR, * PRIVATE_METHOD, DESTRUCTOR and * FILTER_HANDLING are useful. */ + Object *contextObj, /* Context object; when equal to oPtr, it + * means that private methods may also be + * added. [TIP 500] */ + Class *contextCls, /* Context class; the currently considered + * class is equal to this, private methods may + * also be added. [TIP 500] */ Tcl_Obj *cacheInThisObj) /* What object to cache in, or NULL if it is * to be in the same object as the * methodNameObj. */ @@ -908,7 +1125,7 @@ TclOOGetCallContext( CallContext *contextPtr; CallChain *callPtr; struct ChainBuilder cb; - int i, count, doFilters; + int i, count, doFilters, donePrivate = 0; Tcl_HashEntry *hPtr; Tcl_HashTable doneFilters; @@ -948,7 +1165,7 @@ TclOOGetCallContext( * the object, and in the class). */ - const int reuseMask = ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD); + const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD); if (cacheInThisObj->typePtr == &methodNameType) { callPtr = cacheInThisObj->internalRep.twoPtrValue.ptr1; @@ -1000,8 +1217,11 @@ TclOOGetCallContext( */ if (flags & FORCE_UNKNOWN) { - AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj, - &cb, NULL, 0, NULL); + AddSimpleChainToCallContext(oPtr, NULL, + oPtr->fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS, + NULL); + AddSimpleChainToCallContext(oPtr, NULL, + oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; callPtr->epoch = -1; if (callPtr->numChain == 0) { @@ -1024,22 +1244,39 @@ TclOOGetCallContext( doFilters = 1; Tcl_InitObjHashTable(&doneFilters); FOREACH(mixinPtr, oPtr->mixins) { - AddClassFiltersToCallContext(oPtr, mixinPtr, &cb, &doneFilters); + AddClassFiltersToCallContext(oPtr, mixinPtr, &cb, &doneFilters, + TRAVERSED_MIXIN|BUILDING_MIXINS|OBJECT_MIXIN); + AddClassFiltersToCallContext(oPtr, mixinPtr, &cb, &doneFilters, + OBJECT_MIXIN); } FOREACH(filterObj, oPtr->filters) { - AddSimpleChainToCallContext(oPtr, filterObj, &cb, &doneFilters, 0, - NULL); + donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls, + filterObj, &cb, &doneFilters, BUILDING_MIXINS, NULL); + donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls, + filterObj, &cb, &doneFilters, 0, NULL); } - AddClassFiltersToCallContext(oPtr, oPtr->selfCls, &cb, &doneFilters); + AddClassFiltersToCallContext(oPtr, oPtr->selfCls, &cb, &doneFilters, + BUILDING_MIXINS); + AddClassFiltersToCallContext(oPtr, oPtr->selfCls, &cb, &doneFilters, + 0); Tcl_DeleteHashTable(&doneFilters); } count = cb.filterLength = callPtr->numChain; /* - * Add the actual method implementations. + * Add the actual method implementations. We have to do this twice to + * handle class mixins right. */ - AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL, flags, NULL); + if (oPtr == contextObj) { + donePrivate |= AddInstancePrivateToCallContext(oPtr, methodNameObj, + &cb, flags); + donePrivate |= (contextObj->flags & HAS_PRIVATE_METHODS); + } + donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls, + methodNameObj, &cb, NULL, flags|BUILDING_MIXINS, NULL); + donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls, + methodNameObj, &cb, NULL, flags, NULL); /* * Check to see if the method has no implementation. If so, we probably @@ -1057,15 +1294,18 @@ TclOOGetCallContext( TclOODeleteChain(callPtr); return NULL; } - AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj, - &cb, NULL, 0, NULL); + AddSimpleChainToCallContext(oPtr, NULL, + oPtr->fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS, + NULL); + AddSimpleChainToCallContext(oPtr, NULL, + oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; callPtr->epoch = -1; if (count == callPtr->numChain) { TclOODeleteChain(callPtr); return NULL; } - } else if (doFilters) { + } else if (doFilters && !donePrivate) { if (hPtr == NULL) { if (oPtr->flags & USE_CLASS_CACHE) { if (oPtr->selfCls->classChainCache == NULL) { @@ -1106,6 +1346,11 @@ TclOOGetCallContext( returnContext: contextPtr = TclStackAlloc(oPtr->fPtr->interp, sizeof(CallContext)); contextPtr->oPtr = oPtr; + + /* + * Corresponding TclOODecrRefCount() in TclOODeleteContext + */ + AddRef(oPtr); contextPtr->callPtr = callPtr; contextPtr->skip = 2; @@ -1166,8 +1411,7 @@ TclOOGetStereotypeCallChain( hPtr = Tcl_FindHashEntry(clsPtr->classChainCache, (char *) methodNameObj); if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) { - const int reuseMask = - ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD); + const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD); callPtr = Tcl_GetHashValue(hPtr); if (IsStillValid(callPtr, &obj, flags, reuseMask)) { @@ -1201,7 +1445,9 @@ TclOOGetStereotypeCallChain( */ Tcl_InitObjHashTable(&doneFilters); - AddClassFiltersToCallContext(&obj, clsPtr, &cb, &doneFilters); + AddClassFiltersToCallContext(&obj, clsPtr, &cb, &doneFilters, + BUILDING_MIXINS); + AddClassFiltersToCallContext(&obj, clsPtr, &cb, &doneFilters, 0); Tcl_DeleteHashTable(&doneFilters); count = cb.filterLength = callPtr->numChain; @@ -1209,7 +1455,10 @@ TclOOGetStereotypeCallChain( * Add the actual method implementations. */ - AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL, flags, NULL); + AddSimpleChainToCallContext(&obj, NULL, methodNameObj, &cb, NULL, + flags|BUILDING_MIXINS, NULL); + AddSimpleChainToCallContext(&obj, NULL, methodNameObj, &cb, NULL, flags, + NULL); /* * Check to see if the method has no implementation. If so, we probably @@ -1218,8 +1467,10 @@ TclOOGetStereotypeCallChain( */ if (count == callPtr->numChain) { - AddSimpleChainToCallContext(&obj, fPtr->unknownMethodNameObj, &cb, - NULL, 0, NULL); + AddSimpleChainToCallContext(&obj, NULL, fPtr->unknownMethodNameObj, + &cb, NULL, BUILDING_MIXINS, NULL); + AddSimpleChainToCallContext(&obj, NULL, fPtr->unknownMethodNameObj, + &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; callPtr->epoch = -1; if (count == callPtr->numChain) { @@ -1259,12 +1510,15 @@ AddClassFiltersToCallContext( Class *clsPtr, /* Class to get the filters from. */ struct ChainBuilder *const cbPtr, /* Context to fill with call chain entries. */ - Tcl_HashTable *const doneFilters) + Tcl_HashTable *const doneFilters, /* Where to record what filters have been * processed. Keys are objects, values are * ignored. */ + int flags) /* Whether we've gone along a mixin link + * yet. */ { - int i; + int i, clearedFlags = + flags & ~(TRAVERSED_MIXIN|OBJECT_MIXIN|BUILDING_MIXINS); Class *superPtr, *mixinPtr; Tcl_Obj *filterObj; @@ -1279,7 +1533,8 @@ AddClassFiltersToCallContext( */ FOREACH(mixinPtr, clsPtr->mixins) { - AddClassFiltersToCallContext(oPtr, mixinPtr, cbPtr, doneFilters); + AddClassFiltersToCallContext(oPtr, mixinPtr, cbPtr, doneFilters, + flags|TRAVERSED_MIXIN); } /* @@ -1288,13 +1543,18 @@ AddClassFiltersToCallContext( * override how filters work to extend their behaviour. */ - FOREACH(filterObj, clsPtr->filters) { - int isNew; + if (MIXIN_CONSISTENT(flags)) { + FOREACH(filterObj, clsPtr->filters) { + int isNew; - (void) Tcl_CreateHashEntry(doneFilters, (char *) filterObj, &isNew); - if (isNew) { - AddSimpleChainToCallContext(oPtr, filterObj, cbPtr, doneFilters, - 0, clsPtr); + (void) Tcl_CreateHashEntry(doneFilters, (char *) filterObj, + &isNew); + if (isNew) { + AddSimpleChainToCallContext(oPtr, NULL, filterObj, cbPtr, + doneFilters, clearedFlags|BUILDING_MIXINS, clsPtr); + AddSimpleChainToCallContext(oPtr, NULL, filterObj, cbPtr, + doneFilters, clearedFlags, clsPtr); + } } } @@ -1308,7 +1568,8 @@ AddClassFiltersToCallContext( goto tailRecurse; default: FOREACH(superPtr, clsPtr->superclasses) { - AddClassFiltersToCallContext(oPtr, superPtr, cbPtr, doneFilters); + AddClassFiltersToCallContext(oPtr, superPtr, cbPtr, doneFilters, + flags); } case 0: return; @@ -1318,6 +1579,87 @@ AddClassFiltersToCallContext( /* * ---------------------------------------------------------------------- * + * AddPrivatesFromClassChainToCallContext -- + * + * Helper for AddSimpleChainToCallContext that is used to find private + * methds and add them to the call chain. Returns true when a private + * method is found and added. [TIP 500] + * + * ---------------------------------------------------------------------- + */ + +static int +AddPrivatesFromClassChainToCallContext( + Class *classPtr, /* Class to add the call chain entries for. */ + Class *const contextCls, /* Context class; the currently considered + * class is equal to this, private methods may + * also be added. */ + Tcl_Obj *const methodName, /* Name of method to add the call chain + * entries for. */ + struct ChainBuilder *const cbPtr, + /* Where to add the call chain entries. */ + Tcl_HashTable *const doneFilters, + /* Where to record what call chain entries + * have been processed. */ + int flags, /* What sort of call chain are we building. */ + Class *const filterDecl) /* The class that declared the filter. If + * NULL, either the filter was declared by the + * object or this isn't a filter. */ +{ + int i; + Class *superPtr; + + /* + * We hard-code the tail-recursive form. It's by far the most common case + * *and* it is much more gentle on the stack. + * + * Note that mixins must be processed before the main class hierarchy. + * [Bug 1998221] + */ + + tailRecurse: + FOREACH(superPtr, classPtr->mixins) { + if (AddPrivatesFromClassChainToCallContext(superPtr, contextCls, + methodName, cbPtr, doneFilters, flags|TRAVERSED_MIXIN, + filterDecl)) { + return 1; + } + } + + if (classPtr == contextCls) { + Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods, + (char *) methodName); + + if (hPtr != NULL) { + register Method *mPtr = Tcl_GetHashValue(hPtr); + + if (IS_PRIVATE(mPtr)) { + AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, + flags); + return 1; + } + } + } + + switch (classPtr->superclasses.num) { + case 1: + classPtr = classPtr->superclasses.list[0]; + goto tailRecurse; + default: + FOREACH(superPtr, classPtr->superclasses) { + if (AddPrivatesFromClassChainToCallContext(superPtr, contextCls, + methodName, cbPtr, doneFilters, flags, filterDecl)) { + return 1; + } + } + case 0: + return 0; + } +} + +/* + * ---------------------------------------------------------------------- + * * AddSimpleClassChainToCallContext -- * * Construct a call-chain from a class hierarchy. @@ -1325,7 +1667,7 @@ AddClassFiltersToCallContext( * ---------------------------------------------------------------------- */ -static void +static int AddSimpleClassChainToCallContext( Class *classPtr, /* Class to add the call chain entries for. */ Tcl_Obj *const methodNameObj, @@ -1341,7 +1683,7 @@ AddSimpleClassChainToCallContext( * NULL, either the filter was declared by the * object or this isn't a filter. */ { - int i; + int i, privateDanger = 0; Class *superPtr; /* @@ -1354,36 +1696,42 @@ AddSimpleClassChainToCallContext( tailRecurse: FOREACH(superPtr, classPtr->mixins) { - AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr, - doneFilters, flags, filterDecl); + privateDanger |= AddSimpleClassChainToCallContext(superPtr, + methodNameObj, cbPtr, doneFilters, flags | TRAVERSED_MIXIN, + filterDecl); } if (flags & CONSTRUCTOR) { AddMethodToCallChain(classPtr->constructorPtr, cbPtr, doneFilters, - filterDecl); + filterDecl, flags); } else if (flags & DESTRUCTOR) { AddMethodToCallChain(classPtr->destructorPtr, cbPtr, doneFilters, - filterDecl); + filterDecl, flags); } else { Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods, (char *) methodNameObj); + if (classPtr->flags & HAS_PRIVATE_METHODS) { + privateDanger |= 1; + } if (hPtr != NULL) { register Method *mPtr = Tcl_GetHashValue(hPtr); - if (!(flags & KNOWN_STATE)) { - if (flags & PUBLIC_METHOD) { - if (mPtr->flags & PUBLIC_METHOD) { + if (!IS_PRIVATE(mPtr)) { + if (!(flags & KNOWN_STATE)) { + if (flags & PUBLIC_METHOD) { + if (!IS_PUBLIC(mPtr)) { + return privateDanger; + } flags |= DEFINITE_PUBLIC; } else { - return; + flags |= DEFINITE_PROTECTED; } - } else { - flags |= DEFINITE_PROTECTED; } + AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, + flags); } - AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl); } } @@ -1393,11 +1741,11 @@ AddSimpleClassChainToCallContext( goto tailRecurse; default: FOREACH(superPtr, classPtr->superclasses) { - AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr, - doneFilters, flags, filterDecl); + privateDanger |= AddSimpleClassChainToCallContext(superPtr, + methodNameObj, cbPtr, doneFilters, flags, filterDecl); } case 0: - return; + return privateDanger; } } @@ -1417,7 +1765,7 @@ TclOORenderCallChain( Tcl_Interp *interp, CallChain *callPtr) { - Tcl_Obj *filterLiteral, *methodLiteral, *objectLiteral; + Tcl_Obj *filterLiteral, *methodLiteral, *objectLiteral, *privateLiteral; Tcl_Obj *resultObj, *descObjs[4], **objv; Foundation *fPtr = TclOOGetFoundation(interp); int i; @@ -1426,17 +1774,19 @@ TclOORenderCallChain( * Allocate the literals (potentially) used in our description. */ - filterLiteral = Tcl_NewStringObj("filter", -1); + TclNewLiteralStringObj(filterLiteral, "filter"); Tcl_IncrRefCount(filterLiteral); - methodLiteral = Tcl_NewStringObj("method", -1); + TclNewLiteralStringObj(methodLiteral, "method"); Tcl_IncrRefCount(methodLiteral); - objectLiteral = Tcl_NewStringObj("object", -1); + TclNewLiteralStringObj(objectLiteral, "object"); Tcl_IncrRefCount(objectLiteral); + TclNewLiteralStringObj(privateLiteral, "private"); + Tcl_IncrRefCount(privateLiteral); /* * Do the actual construction of the descriptions. They consist of a list * of triples that describe the details of how a method is understood. For - * each triple, the first word is the type of invokation ("method" is + * each triple, the first word is the type of invocation ("method" is * normal, "unknown" is special because it adds the method name as an * extra argument when handled by some method types, and "filter" is * special because it's a filter method). The second word is the name of @@ -1449,16 +1799,15 @@ TclOORenderCallChain( for (i=0 ; i<callPtr->numChain ; i++) { struct MInvoke *miPtr = &callPtr->chain[i]; - descObjs[0] = miPtr->isFilter - ? filterLiteral - : callPtr->flags & OO_UNKNOWN_METHOD - ? fPtr->unknownMethodNameObj - : methodLiteral; - descObjs[1] = callPtr->flags & CONSTRUCTOR - ? fPtr->constructorName - : callPtr->flags & DESTRUCTOR - ? fPtr->destructorName - : miPtr->mPtr->namePtr; + descObjs[0] = + miPtr->isFilter ? filterLiteral : + callPtr->flags & OO_UNKNOWN_METHOD ? fPtr->unknownMethodNameObj : + IS_PRIVATE(miPtr->mPtr) ? privateLiteral : + methodLiteral; + descObjs[1] = + callPtr->flags & CONSTRUCTOR ? fPtr->constructorName : + callPtr->flags & DESTRUCTOR ? fPtr->destructorName : + miPtr->mPtr->namePtr; descObjs[2] = miPtr->mPtr->declaringClassPtr ? Tcl_GetObjectName(interp, (Tcl_Object) miPtr->mPtr->declaringClassPtr->thisPtr) @@ -1476,6 +1825,7 @@ TclOORenderCallChain( Tcl_DecrRefCount(filterLiteral); Tcl_DecrRefCount(methodLiteral); Tcl_DecrRefCount(objectLiteral); + Tcl_DecrRefCount(privateLiteral); /* * Finish building the description and return it. diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index 58871c6..928d07e 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -5,100 +5,119 @@ #ifndef _TCLOODECLS #define _TCLOODECLS +#ifndef TCLAPI +# ifdef BUILD_tcl +# define TCLAPI extern DLLEXPORT +# else +# define TCLAPI extern DLLIMPORT +# endif +#endif + +#ifdef USE_TCL_STUBS +# undef USE_TCLOO_STUBS +# define USE_TCLOO_STUBS +#endif + /* !BEGIN!: Do not edit below this line. */ +#ifdef __cplusplus +extern "C" { +#endif + /* * Exported function declarations: */ /* 0 */ -TCLOOAPI Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, +TCLAPI Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp, Tcl_Object sourceObject, const char *targetName, const char *targetNamespaceName); /* 1 */ -TCLOOAPI Tcl_Object Tcl_GetClassAsObject(Tcl_Class clazz); +TCLAPI Tcl_Object Tcl_GetClassAsObject(Tcl_Class clazz); /* 2 */ -TCLOOAPI Tcl_Class Tcl_GetObjectAsClass(Tcl_Object object); +TCLAPI Tcl_Class Tcl_GetObjectAsClass(Tcl_Object object); /* 3 */ -TCLOOAPI Tcl_Command Tcl_GetObjectCommand(Tcl_Object object); +TCLAPI Tcl_Command Tcl_GetObjectCommand(Tcl_Object object); /* 4 */ -TCLOOAPI Tcl_Object Tcl_GetObjectFromObj(Tcl_Interp *interp, +TCLAPI Tcl_Object Tcl_GetObjectFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 5 */ -TCLOOAPI Tcl_Namespace * Tcl_GetObjectNamespace(Tcl_Object object); +TCLAPI Tcl_Namespace * Tcl_GetObjectNamespace(Tcl_Object object); /* 6 */ -TCLOOAPI Tcl_Class Tcl_MethodDeclarerClass(Tcl_Method method); +TCLAPI Tcl_Class Tcl_MethodDeclarerClass(Tcl_Method method); /* 7 */ -TCLOOAPI Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method); +TCLAPI Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method); /* 8 */ -TCLOOAPI int Tcl_MethodIsPublic(Tcl_Method method); +TCLAPI int Tcl_MethodIsPublic(Tcl_Method method); /* 9 */ -TCLOOAPI int Tcl_MethodIsType(Tcl_Method method, +TCLAPI int Tcl_MethodIsType(Tcl_Method method, const Tcl_MethodType *typePtr, ClientData *clientDataPtr); /* 10 */ -TCLOOAPI Tcl_Obj * Tcl_MethodName(Tcl_Method method); +TCLAPI Tcl_Obj * Tcl_MethodName(Tcl_Method method); /* 11 */ -TCLOOAPI Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, +TCLAPI Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, - int isPublic, const Tcl_MethodType *typePtr, + int flags, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */ -TCLOOAPI Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, - Tcl_Obj *nameObj, int isPublic, +TCLAPI Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, + Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, ClientData clientData); /* 13 */ -TCLOOAPI Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, +TCLAPI Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, int objc, Tcl_Obj *const *objv, int skip); /* 14 */ -TCLOOAPI int Tcl_ObjectDeleted(Tcl_Object object); +TCLAPI int Tcl_ObjectDeleted(Tcl_Object object); /* 15 */ -TCLOOAPI int Tcl_ObjectContextIsFiltering( +TCLAPI int Tcl_ObjectContextIsFiltering( Tcl_ObjectContext context); /* 16 */ -TCLOOAPI Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context); +TCLAPI Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context); /* 17 */ -TCLOOAPI Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context); +TCLAPI Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context); /* 18 */ -TCLOOAPI int Tcl_ObjectContextSkippedArgs( +TCLAPI int Tcl_ObjectContextSkippedArgs( Tcl_ObjectContext context); /* 19 */ -TCLOOAPI ClientData Tcl_ClassGetMetadata(Tcl_Class clazz, +TCLAPI ClientData Tcl_ClassGetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr); /* 20 */ -TCLOOAPI void Tcl_ClassSetMetadata(Tcl_Class clazz, +TCLAPI void Tcl_ClassSetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 21 */ -TCLOOAPI ClientData Tcl_ObjectGetMetadata(Tcl_Object object, +TCLAPI ClientData Tcl_ObjectGetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr); /* 22 */ -TCLOOAPI void Tcl_ObjectSetMetadata(Tcl_Object object, +TCLAPI void Tcl_ObjectSetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 23 */ -TCLOOAPI int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, +TCLAPI int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv, int skip); /* 24 */ -TCLOOAPI Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper( +TCLAPI Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper( Tcl_Object object); /* 25 */ -TCLOOAPI void Tcl_ObjectSetMethodNameMapper(Tcl_Object object, +TCLAPI void Tcl_ObjectSetMethodNameMapper(Tcl_Object object, Tcl_ObjectMapMethodNameProc *mapMethodNameProc); /* 26 */ -TCLOOAPI void Tcl_ClassSetConstructor(Tcl_Interp *interp, +TCLAPI void Tcl_ClassSetConstructor(Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 27 */ -TCLOOAPI void Tcl_ClassSetDestructor(Tcl_Interp *interp, +TCLAPI void Tcl_ClassSetDestructor(Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 28 */ -TCLOOAPI Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp, +TCLAPI Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp, Tcl_Object object); +/* 29 */ +TCLAPI int Tcl_MethodIsPrivate(Tcl_Method method); typedef struct { const struct TclOOIntStubs *tclOOIntStubs; @@ -119,8 +138,8 @@ typedef struct TclOOStubs { int (*tcl_MethodIsPublic) (Tcl_Method method); /* 8 */ int (*tcl_MethodIsType) (Tcl_Method method, const Tcl_MethodType *typePtr, ClientData *clientDataPtr); /* 9 */ Tcl_Obj * (*tcl_MethodName) (Tcl_Method method); /* 10 */ - Tcl_Method (*tcl_NewInstanceMethod) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 11 */ - Tcl_Method (*tcl_NewMethod) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */ + Tcl_Method (*tcl_NewInstanceMethod) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, ClientData clientData); /* 11 */ + Tcl_Method (*tcl_NewMethod) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */ Tcl_Object (*tcl_NewObjectInstance) (Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, int objc, Tcl_Obj *const *objv, int skip); /* 13 */ int (*tcl_ObjectDeleted) (Tcl_Object object); /* 14 */ int (*tcl_ObjectContextIsFiltering) (Tcl_ObjectContext context); /* 15 */ @@ -137,12 +156,11 @@ typedef struct TclOOStubs { void (*tcl_ClassSetConstructor) (Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 26 */ void (*tcl_ClassSetDestructor) (Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 27 */ Tcl_Obj * (*tcl_GetObjectName) (Tcl_Interp *interp, Tcl_Object object); /* 28 */ + int (*tcl_MethodIsPrivate) (Tcl_Method method); /* 29 */ } TclOOStubs; -#ifdef __cplusplus -extern "C" { -#endif extern const TclOOStubs *tclOOStubsPtr; + #ifdef __cplusplus } #endif @@ -211,8 +229,11 @@ extern const TclOOStubs *tclOOStubsPtr; (tclOOStubsPtr->tcl_ClassSetDestructor) /* 27 */ #define Tcl_GetObjectName \ (tclOOStubsPtr->tcl_GetObjectName) /* 28 */ +#define Tcl_MethodIsPrivate \ + (tclOOStubsPtr->tcl_MethodIsPrivate) /* 29 */ #endif /* defined(USE_TCLOO_STUBS) */ /* !END!: Do not edit above this line. */ + #endif /* _TCLOODECLS */ diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index f0983cc..3c27236 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -4,7 +4,7 @@ * This file contains the implementation of the ::oo::define command, * part of the object-system core (NB: not Tcl_Obj, but ::oo). * - * Copyright (c) 2006-2012 by Donal K. Fellows + * Copyright (c) 2006-2013 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -17,6 +17,12 @@ #include "tclOOInt.h" /* + * The actual value used to mark private declaration frames. + */ + +#define PRIVATE_FRAME (FRAME_IS_OO_DEFINE | FRAME_IS_PRIVATE_DEFINE) + +/* * The maximum length of fully-qualified object name to use in an errorinfo * message. Longer than this will be curtailed. */ @@ -47,8 +53,11 @@ struct DeclaredSlot { static inline void BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr); static Tcl_Command FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj, Tcl_Namespace *const namespacePtr); -static void GenerateErrorInfo(Tcl_Interp *interp, Object *oPtr, +static inline void GenerateErrorInfo(Tcl_Interp *interp, Object *oPtr, Tcl_Obj *savedNameObj, const char *typeOfSubject); +static inline int MagicDefinitionInvoke(Tcl_Interp *interp, + Tcl_Namespace *nsPtr, int cmdIndex, + int objc, Tcl_Obj *const *objv); static inline Class * GetClassInOuterContext(Tcl_Interp *interp, Tcl_Obj *className, const char *errMsg); static inline int InitDefineContext(Tcl_Interp *interp, @@ -115,11 +124,41 @@ static const struct DeclaredSlot slots[] = { SLOT("objdefine::variable", ObjVarsGet, ObjVarsSet), {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}} }; + +/* + * How to build the in-namespace name of a private variable. This is a pattern + * used with Tcl_ObjPrintf(). + */ + +#define PRIVATE_VARIABLE_PATTERN "%d : %s" + +/* + * ---------------------------------------------------------------------- + * + * IsPrivateDefine -- + * + * Extracts whether the current context is handling private definitions. + * + * ---------------------------------------------------------------------- + */ + +static inline int +IsPrivateDefine( + Tcl_Interp *interp) +{ + Interp *iPtr = (Interp *) interp; + + if (!iPtr->varFramePtr) { + return 0; + } + return iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME; +} /* * ---------------------------------------------------------------------- * * BumpGlobalEpoch -- + * * Utility that ensures that call chains that are invalid will get thrown * away at an appropriate time. Note that exactly which epoch gets * advanced will depend on exactly what the class is tangled up in; in @@ -164,6 +203,7 @@ BumpGlobalEpoch( * ---------------------------------------------------------------------- * * RecomputeClassCacheFlag -- + * * Determine whether the object is prototypical of its class, and hence * able to use the class's method chain cache. * @@ -186,6 +226,7 @@ RecomputeClassCacheFlag( * ---------------------------------------------------------------------- * * TclOOObjectSetFilters -- + * * Install a list of filter method names into an object. * * ---------------------------------------------------------------------- @@ -244,6 +285,7 @@ TclOOObjectSetFilters( * ---------------------------------------------------------------------- * * TclOOClassSetFilters -- + * * Install a list of filter method names into a class. * * ---------------------------------------------------------------------- @@ -306,6 +348,7 @@ TclOOClassSetFilters( * ---------------------------------------------------------------------- * * TclOOObjectSetMixins -- + * * Install a list of mixin classes into an object. * * ---------------------------------------------------------------------- @@ -324,6 +367,7 @@ TclOOObjectSetMixins( if (oPtr->mixins.num != 0) { FOREACH(mixinPtr, oPtr->mixins) { TclOORemoveFromInstances(oPtr, mixinPtr); + TclOODecrRefCount(mixinPtr->thisPtr); } ckfree(oPtr->mixins.list); oPtr->mixins.num = 0; @@ -332,9 +376,10 @@ TclOOObjectSetMixins( } else { if (oPtr->mixins.num != 0) { FOREACH(mixinPtr, oPtr->mixins) { - if (mixinPtr != oPtr->selfCls) { + if (mixinPtr && mixinPtr != oPtr->selfCls) { TclOORemoveFromInstances(oPtr, mixinPtr); } + TclOODecrRefCount(mixinPtr->thisPtr); } oPtr->mixins.list = ckrealloc(oPtr->mixins.list, sizeof(Class *) * numMixins); @@ -347,6 +392,8 @@ TclOOObjectSetMixins( FOREACH(mixinPtr, oPtr->mixins) { if (mixinPtr != oPtr->selfCls) { TclOOAddToInstances(oPtr, mixinPtr); + /* For the new copy created by memcpy */ + AddRef(mixinPtr->thisPtr); } } } @@ -357,6 +404,7 @@ TclOOObjectSetMixins( * ---------------------------------------------------------------------- * * TclOOClassSetMixins -- + * * Install a list of mixin classes into a class. * * ---------------------------------------------------------------------- @@ -376,6 +424,7 @@ TclOOClassSetMixins( if (classPtr->mixins.num != 0) { FOREACH(mixinPtr, classPtr->mixins) { TclOORemoveFromMixinSubs(classPtr, mixinPtr); + TclOODecrRefCount(mixinPtr->thisPtr); } ckfree(classPtr->mixins.list); classPtr->mixins.num = 0; @@ -384,6 +433,7 @@ TclOOClassSetMixins( if (classPtr->mixins.num != 0) { FOREACH(mixinPtr, classPtr->mixins) { TclOORemoveFromMixinSubs(classPtr, mixinPtr); + TclOODecrRefCount(mixinPtr->thisPtr); } classPtr->mixins.list = ckrealloc(classPtr->mixins.list, sizeof(Class *) * numMixins); @@ -394,6 +444,8 @@ TclOOClassSetMixins( memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins); FOREACH(mixinPtr, classPtr->mixins) { TclOOAddToMixinSubs(classPtr, mixinPtr); + /* For the new copy created by memcpy */ + AddRef(mixinPtr->thisPtr); } } BumpGlobalEpoch(interp, classPtr); @@ -402,7 +454,125 @@ TclOOClassSetMixins( /* * ---------------------------------------------------------------------- * + * InstallStandardVariableMapping, InstallPrivateVariableMapping -- + * + * Helpers for installing standard and private variable maps. + * + * ---------------------------------------------------------------------- + */ +static inline void +InstallStandardVariableMapping( + VariableNameList *vnlPtr, + int varc, + Tcl_Obj *const *varv) +{ + Tcl_Obj *variableObj; + int i, n, created; + Tcl_HashTable uniqueTable; + + for (i=0 ; i<varc ; i++) { + Tcl_IncrRefCount(varv[i]); + } + FOREACH(variableObj, *vnlPtr) { + Tcl_DecrRefCount(variableObj); + } + if (i != varc) { + if (varc == 0) { + ckfree(vnlPtr->list); + } else if (i) { + vnlPtr->list = ckrealloc(vnlPtr->list, sizeof(Tcl_Obj *) * varc); + } else { + vnlPtr->list = ckalloc(sizeof(Tcl_Obj *) * varc); + } + } + vnlPtr->num = 0; + if (varc > 0) { + Tcl_InitObjHashTable(&uniqueTable); + for (i=n=0 ; i<varc ; i++) { + Tcl_CreateHashEntry(&uniqueTable, varv[i], &created); + if (created) { + vnlPtr->list[n++] = varv[i]; + } else { + Tcl_DecrRefCount(varv[i]); + } + } + vnlPtr->num = n; + + /* + * Shouldn't be necessary, but maintain num/list invariant. + */ + + if (n != varc) { + vnlPtr->list = ckrealloc(vnlPtr->list, sizeof(Tcl_Obj *) * n); + } + Tcl_DeleteHashTable(&uniqueTable); + } +} + +static inline void +InstallPrivateVariableMapping( + PrivateVariableList *pvlPtr, + int varc, + Tcl_Obj *const *varv, + int creationEpoch) +{ + PrivateVariableMapping *privatePtr; + int i, n, created; + Tcl_HashTable uniqueTable; + + for (i=0 ; i<varc ; i++) { + Tcl_IncrRefCount(varv[i]); + } + FOREACH_STRUCT(privatePtr, *pvlPtr) { + Tcl_DecrRefCount(privatePtr->variableObj); + Tcl_DecrRefCount(privatePtr->fullNameObj); + } + if (i != varc) { + if (varc == 0) { + ckfree(pvlPtr->list); + } else if (i) { + pvlPtr->list = ckrealloc(pvlPtr->list, + sizeof(PrivateVariableMapping) * varc); + } else { + pvlPtr->list = ckalloc(sizeof(PrivateVariableMapping) * varc); + } + } + + pvlPtr->num = 0; + if (varc > 0) { + Tcl_InitObjHashTable(&uniqueTable); + for (i=n=0 ; i<varc ; i++) { + Tcl_CreateHashEntry(&uniqueTable, varv[i], &created); + if (created) { + privatePtr = &(pvlPtr->list[n++]); + privatePtr->variableObj = varv[i]; + privatePtr->fullNameObj = Tcl_ObjPrintf( + PRIVATE_VARIABLE_PATTERN, + creationEpoch, Tcl_GetString(varv[i])); + Tcl_IncrRefCount(privatePtr->fullNameObj); + } else { + Tcl_DecrRefCount(varv[i]); + } + } + pvlPtr->num = n; + + /* + * Shouldn't be necessary, but maintain num/list invariant. + */ + + if (n != varc) { + pvlPtr->list = ckrealloc(pvlPtr->list, + sizeof(PrivateVariableMapping) * n); + } + Tcl_DeleteHashTable(&uniqueTable); + } +} + +/* + * ---------------------------------------------------------------------- + * * RenameDeleteMethod -- + * * Core of the code to rename and delete methods. * * ---------------------------------------------------------------------- @@ -492,6 +662,7 @@ RenameDeleteMethod( * ---------------------------------------------------------------------- * * TclOOUnknownDefinition -- + * * Handles what happens when an unknown command is encountered during the * processing of a definition script. Works by finding a command in the * operating definition namespace that the requested command is a unique @@ -523,7 +694,7 @@ TclOOUnknownDefinition( return TCL_ERROR; } - soughtStr = Tcl_GetStringFromObj(objv[1], &soughtLen); + soughtStr = TclGetStringFromObj(objv[1], &soughtLen); if (soughtLen == 0) { goto noMatch; } @@ -570,6 +741,7 @@ TclOOUnknownDefinition( * ---------------------------------------------------------------------- * * FindCommand -- + * * Specialized version of Tcl_FindCommand that handles command prefixes * and disallows namespace magic. * @@ -583,7 +755,7 @@ FindCommand( Tcl_Namespace *const namespacePtr) { int length; - const char *nameStr, *string = Tcl_GetStringFromObj(stringObj, &length); + const char *nameStr, *string = TclGetStringFromObj(stringObj, &length); register Namespace *const nsPtr = (Namespace *) namespacePtr; FOREACH_HASH_DECLS; Tcl_Command cmd, cmd2; @@ -630,6 +802,7 @@ FindCommand( * ---------------------------------------------------------------------- * * InitDefineContext -- + * * Does the magic incantations necessary to push the special stack frame * used when processing object definitions. It is up to the caller to * dispose of the frame (with TclPopStackFrame) when finished. @@ -646,7 +819,6 @@ InitDefineContext( Tcl_Obj *const objv[]) { CallFrame *framePtr, **framePtrPtr = &framePtr; - int result; if (namespacePtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -656,13 +828,12 @@ InitDefineContext( return TCL_ERROR; } - /* framePtrPtr is needed to satisfy GCC 3.3's strict aliasing rules */ + /* + * framePtrPtr is needed to satisfy GCC 3.3's strict aliasing rules. + */ - result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, + (void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, namespacePtr, FRAME_IS_OO_DEFINE); - if (result != TCL_OK) { - return TCL_ERROR; - } framePtr->clientData = oPtr; framePtr->objc = objc; framePtr->objv = objv; /* Reference counts do not need to be @@ -674,6 +845,7 @@ InitDefineContext( * ---------------------------------------------------------------------- * * TclOOGetDefineCmdContext -- + * * Extracts the magic token from the current stack frame, or returns NULL * (and leaves an error message) otherwise. * @@ -688,7 +860,8 @@ TclOOGetDefineCmdContext( Tcl_Object object; if ((iPtr->varFramePtr == NULL) - || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE)) { + || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE + && iPtr->varFramePtr->isProcCallFrame != PRIVATE_FRAME)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "this command may only be called from within the context of" " an ::oo::define or ::oo::objdefine command", -1)); @@ -710,6 +883,7 @@ TclOOGetDefineCmdContext( * ---------------------------------------------------------------------- * * GetClassInOuterContext -- + * * Wrapper round Tcl_GetObjectFromObj to perform the lookup in the * context that called oo::define (or equivalent). Note that this may * have to go up multiple levels to get the level that we started doing @@ -728,7 +902,8 @@ GetClassInOuterContext( Object *oPtr; CallFrame *savedFramePtr = iPtr->varFramePtr; - while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE) { + while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE + || iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME) { if (iPtr->varFramePtr->callerVarPtr == NULL) { Tcl_Panic("getting outer context when already in global context"); } @@ -752,12 +927,13 @@ GetClassInOuterContext( * ---------------------------------------------------------------------- * * GenerateErrorInfo -- + * * Factored out code to generate part of the error trace messages. * * ---------------------------------------------------------------------- */ -static void +static inline void GenerateErrorInfo( Tcl_Interp *interp, /* Where to store the error info trace. */ Object *oPtr, /* What object (or class) was being configured @@ -776,7 +952,7 @@ GenerateErrorInfo( int length; Tcl_Obj *realNameObj = Tcl_ObjectDeleted((Tcl_Object) oPtr) ? savedNameObj : TclOOObjectName(interp, oPtr); - const char *objName = Tcl_GetStringFromObj(realNameObj, &length); + const char *objName = TclGetStringFromObj(realNameObj, &length); int limit = OBJNAME_LENGTH_IN_ERRORINFO_LIMIT; int overflow = (length > limit); @@ -789,7 +965,72 @@ GenerateErrorInfo( /* * ---------------------------------------------------------------------- * + * MagicDefinitionInvoke -- + * + * Part of the implementation of the "oo::define" and "oo::objdefine" + * commands that is used to implement the more-than-one-argument case, + * applying ensemble-like tricks with dispatch so that error messages are + * clearer. Doesn't handle the management of the stack frame. + * + * ---------------------------------------------------------------------- + */ + +static inline int +MagicDefinitionInvoke( + Tcl_Interp *interp, + Tcl_Namespace *nsPtr, + int cmdIndex, + int objc, + Tcl_Obj *const *objv) +{ + Tcl_Obj *objPtr, *obj2Ptr, **objs; + Tcl_Command cmd; + int isRoot, dummy, result, offset = cmdIndex + 1; + + /* + * More than one argument: fire them through the ensemble processing + * engine so that everything appears to be good and proper in error + * messages. Note that we cannot just concatenate and send through + * Tcl_EvalObjEx, as that doesn't do ensemble processing, and we cannot go + * through Tcl_EvalObjv without the extra work to pre-find the command, as + * that finds command names in the wrong namespace at the moment. Ugly! + */ + + isRoot = TclInitRewriteEnsemble(interp, offset, 1, objv); + + /* + * Build the list of arguments using a Tcl_Obj as a workspace. See + * comments above for why these contortions are necessary. + */ + + objPtr = Tcl_NewObj(); + obj2Ptr = Tcl_NewObj(); + cmd = FindCommand(interp, objv[cmdIndex], nsPtr); + if (cmd == NULL) { + /* punt this case! */ + Tcl_AppendObjToObj(obj2Ptr, objv[cmdIndex]); + } else { + Tcl_GetCommandFullName(interp, cmd, obj2Ptr); + } + Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr); + /* TODO: overflow? */ + Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-offset, objv+offset); + Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs); + + result = Tcl_EvalObjv(interp, objc-cmdIndex, objs, TCL_EVAL_INVOKE); + if (isRoot) { + TclResetRewriteEnsemble(interp, 1); + } + Tcl_DecrRefCount(objPtr); + + return result; +} + +/* + * ---------------------------------------------------------------------- + * * TclOODefineObjCmd -- + * * Implementation of the "oo::define" command. Works by effectively doing * the same as 'namespace eval', but with extra magic applied so that the * object to be modified is known to the commands in the target @@ -807,8 +1048,8 @@ TclOODefineObjCmd( Tcl_Obj *const *objv) { Foundation *fPtr = TclOOGetFoundation(interp); - int result; Object *oPtr; + int result; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "className arg ?arg ...?"); @@ -848,56 +1089,9 @@ TclOODefineObjCmd( } TclDecrRefCount(objNameObj); } else { - Tcl_Obj *objPtr, *obj2Ptr, **objs; - Interp *iPtr = (Interp *) interp; - Tcl_Command cmd; - int dummy; - - /* - * More than one argument: fire them through the ensemble processing - * engine so that everything appears to be good and proper in error - * messages. Note that we cannot just concatenate and send through - * Tcl_EvalObjEx, as that doesn't do ensemble processing, and we - * cannot go through Tcl_EvalObjv without the extra work to pre-find - * the command, as that finds command names in the wrong namespace at - * the moment. Ugly! - */ - - if (iPtr->ensembleRewrite.sourceObjs == NULL) { - iPtr->ensembleRewrite.sourceObjs = objv; - iPtr->ensembleRewrite.numRemovedObjs = 3; - iPtr->ensembleRewrite.numInsertedObjs = 1; - } else { - int ni = iPtr->ensembleRewrite.numInsertedObjs; - if (ni < 3) { - iPtr->ensembleRewrite.numRemovedObjs += 3 - ni; - } else { - iPtr->ensembleRewrite.numInsertedObjs -= 2; - } - } - - /* - * Build the list of arguments using a Tcl_Obj as a workspace. See - * comments above for why these contortions are necessary. - */ - - objPtr = Tcl_NewObj(); - obj2Ptr = Tcl_NewObj(); - cmd = FindCommand(interp, objv[2], fPtr->defineNs); - if (cmd == NULL) { - /* punt this case! */ - Tcl_AppendObjToObj(obj2Ptr, objv[2]); - } else { - Tcl_GetCommandFullName(interp, cmd, obj2Ptr); - } - Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr); - Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-3, objv+3); - Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs); - - result = Tcl_EvalObjv(interp, objc-2, objs, TCL_EVAL_INVOKE); - Tcl_DecrRefCount(objPtr); + result = MagicDefinitionInvoke(interp, fPtr->defineNs, 2, objc, objv); } - DelRef(oPtr); + TclOODecrRefCount(oPtr); /* * Restore the previous "current" namespace. @@ -911,6 +1105,7 @@ TclOODefineObjCmd( * ---------------------------------------------------------------------- * * TclOOObjDefObjCmd -- + * * Implementation of the "oo::objdefine" command. Works by effectively * doing the same as 'namespace eval', but with extra magic applied so * that the object to be modified is known to the commands in the target @@ -928,8 +1123,8 @@ TclOOObjDefObjCmd( Tcl_Obj *const *objv) { Foundation *fPtr = TclOOGetFoundation(interp); - int result; Object *oPtr; + int result; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "objectName arg ?arg ...?"); @@ -962,56 +1157,9 @@ TclOOObjDefObjCmd( } TclDecrRefCount(objNameObj); } else { - Tcl_Obj *objPtr, *obj2Ptr, **objs; - Interp *iPtr = (Interp *) interp; - Tcl_Command cmd; - int dummy; - - /* - * More than one argument: fire them through the ensemble processing - * engine so that everything appears to be good and proper in error - * messages. Note that we cannot just concatenate and send through - * Tcl_EvalObjEx, as that doesn't do ensemble processing, and we - * cannot go through Tcl_EvalObjv without the extra work to pre-find - * the command, as that finds command names in the wrong namespace at - * the moment. Ugly! - */ - - if (iPtr->ensembleRewrite.sourceObjs == NULL) { - iPtr->ensembleRewrite.sourceObjs = objv; - iPtr->ensembleRewrite.numRemovedObjs = 3; - iPtr->ensembleRewrite.numInsertedObjs = 1; - } else { - int ni = iPtr->ensembleRewrite.numInsertedObjs; - if (ni < 3) { - iPtr->ensembleRewrite.numRemovedObjs += 3 - ni; - } else { - iPtr->ensembleRewrite.numInsertedObjs -= 2; - } - } - - /* - * Build the list of arguments using a Tcl_Obj as a workspace. See - * comments above for why these contortions are necessary. - */ - - objPtr = Tcl_NewObj(); - obj2Ptr = Tcl_NewObj(); - cmd = FindCommand(interp, objv[2], fPtr->objdefNs); - if (cmd == NULL) { - /* punt this case! */ - Tcl_AppendObjToObj(obj2Ptr, objv[2]); - } else { - Tcl_GetCommandFullName(interp, cmd, obj2Ptr); - } - Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr); - Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-3, objv+3); - Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs); - - result = Tcl_EvalObjv(interp, objc-2, objs, TCL_EVAL_INVOKE); - Tcl_DecrRefCount(objPtr); + result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 2, objc, objv); } - DelRef(oPtr); + TclOODecrRefCount(oPtr); /* * Restore the previous "current" namespace. @@ -1025,6 +1173,7 @@ TclOOObjDefObjCmd( * ---------------------------------------------------------------------- * * TclOODefineSelfObjCmd -- + * * Implementation of the "self" subcommand of the "oo::define" command. * Works by effectively doing the same as 'namespace eval', but with * extra magic applied so that the object to be modified is known to the @@ -1042,19 +1191,21 @@ TclOODefineSelfObjCmd( Tcl_Obj *const *objv) { Foundation *fPtr = TclOOGetFoundation(interp); - int result; Object *oPtr; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?"); - return TCL_ERROR; - } + int result, private; oPtr = (Object *) TclOOGetDefineCmdContext(interp); if (oPtr == NULL) { return TCL_ERROR; } + if (objc < 2) { + Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr)); + return TCL_OK; + } + + private = IsPrivateDefine(interp); + /* * Make the oo::objdefine namespace the current namespace and evaluate the * command(s). @@ -1063,6 +1214,9 @@ TclOODefineSelfObjCmd( if (InitDefineContext(interp, fPtr->objdefNs, oPtr, objc,objv) != TCL_OK){ return TCL_ERROR; } + if (private) { + ((Interp *) interp)->varFramePtr->isProcCallFrame = PRIVATE_FRAME; + } AddRef(oPtr); if (objc == 2) { @@ -1070,68 +1224,128 @@ TclOODefineSelfObjCmd( Tcl_IncrRefCount(objNameObj); result = TclEvalObjEx(interp, objv[1], 0, - ((Interp *)interp)->cmdFramePtr, 2); + ((Interp *)interp)->cmdFramePtr, 1); if (result == TCL_ERROR) { GenerateErrorInfo(interp, oPtr, objNameObj, "class object"); } TclDecrRefCount(objNameObj); } else { - Tcl_Obj *objPtr, *obj2Ptr, **objs; - Interp *iPtr = (Interp *) interp; - Tcl_Command cmd; - int dummy; + result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 1, objc, objv); + } + TclOODecrRefCount(oPtr); - /* - * More than one argument: fire them through the ensemble processing - * engine so that everything appears to be good and proper in error - * messages. Note that we cannot just concatenate and send through - * Tcl_EvalObjEx, as that doesn't do ensemble processing, and we - * cannot go through Tcl_EvalObjv without the extra work to pre-find - * the command, as that finds command names in the wrong namespace at - * the moment. Ugly! - */ + /* + * Restore the previous "current" namespace. + */ - if (iPtr->ensembleRewrite.sourceObjs == NULL) { - iPtr->ensembleRewrite.sourceObjs = objv; - iPtr->ensembleRewrite.numRemovedObjs = 2; - iPtr->ensembleRewrite.numInsertedObjs = 1; - } else { - int ni = iPtr->ensembleRewrite.numInsertedObjs; - if (ni < 2) { - iPtr->ensembleRewrite.numRemovedObjs += 2 - ni; - } else { - iPtr->ensembleRewrite.numInsertedObjs -= 1; - } - } + TclPopStackFrame(interp); + return result; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOODefineObjSelfObjCmd -- + * + * Implementation of the "self" subcommand of the "oo::objdefine" + * command. + * + * ---------------------------------------------------------------------- + */ - /* - * Build the list of arguments using a Tcl_Obj as a workspace. See - * comments above for why these contortions are necessary. - */ +int +TclOODefineObjSelfObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr; - objPtr = Tcl_NewObj(); - obj2Ptr = Tcl_NewObj(); - cmd = FindCommand(interp, objv[1], fPtr->objdefNs); - if (cmd == NULL) { - /* punt this case! */ - Tcl_AppendObjToObj(obj2Ptr, objv[1]); - } else { - Tcl_GetCommandFullName(interp, cmd, obj2Ptr); - } - Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr); - Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-2, objv+2); - Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs); + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return TCL_ERROR; + } - result = Tcl_EvalObjv(interp, objc-1, objs, TCL_EVAL_INVOKE); - Tcl_DecrRefCount(objPtr); + oPtr = (Object *) TclOOGetDefineCmdContext(interp); + if (oPtr == NULL) { + return TCL_ERROR; + } + + Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr)); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOODefinePrivateObjCmd -- + * + * Implementation of the "private" subcommand of the "oo::define" + * and "oo::objdefine" commands. + * + * ---------------------------------------------------------------------- + */ + +int +TclOODefinePrivateObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + int isInstancePrivate = (clientData != NULL); + /* Just so that we can generate the correct + * error message depending on the context of + * usage of this function. */ + Interp *iPtr = (Interp *) interp; + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + int saved; /* The saved flag. We restore it on exit so + * that [private private ...] doesn't make + * things go weird. */ + int result; + + if (oPtr == NULL) { + return TCL_ERROR; + } + if (objc == 1) { + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(IsPrivateDefine(interp))); + return TCL_OK; } - DelRef(oPtr); /* - * Restore the previous "current" namespace. + * Change the frame type flag while evaluating the body. */ - TclPopStackFrame(interp); + saved = iPtr->varFramePtr->isProcCallFrame; + iPtr->varFramePtr->isProcCallFrame = PRIVATE_FRAME; + + /* + * Evaluate the body; standard pattern. + */ + + AddRef(oPtr); + if (objc == 2) { + Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr); + + Tcl_IncrRefCount(objNameObj); + result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1); + if (result == TCL_ERROR) { + GenerateErrorInfo(interp, oPtr, objNameObj, + isInstancePrivate ? "object" : "class"); + } + TclDecrRefCount(objNameObj); + } else { + result = MagicDefinitionInvoke(interp, TclGetCurrentNamespace(interp), + 1, objc, objv); + } + TclOODecrRefCount(oPtr); + + /* + * Restore the frame type flag to what it was previously. + */ + + iPtr->varFramePtr->isProcCallFrame = saved; return result; } @@ -1139,6 +1353,7 @@ TclOODefineSelfObjCmd( * ---------------------------------------------------------------------- * * TclOODefineClassObjCmd -- + * * Implementation of the "class" subcommand of the "oo::objdefine" * command. * @@ -1154,7 +1369,6 @@ TclOODefineClassObjCmd( { Object *oPtr; Class *clsPtr; - Foundation *fPtr = TclOOGetFoundation(interp); /* * Parse the context to get the object to operate on. @@ -1191,20 +1405,6 @@ TclOODefineClassObjCmd( return TCL_ERROR; } - /* - * Apply semantic checks. In particular, classes and non-classes are not - * interchangable (too complicated to do the conversion!) so we must - * produce an error if any attempt is made to swap from one to the other. - */ - - if ((oPtr->classPtr==NULL) == TclOOIsReachable(fPtr->classCls, clsPtr)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "may not change a %sclass object into a %sclass object", - (oPtr->classPtr==NULL ? "non-" : ""), - (oPtr->classPtr==NULL ? "" : "non-"))); - Tcl_SetErrorCode(interp, "TCL", "OO", "TRANSMUTATION", NULL); - return TCL_ERROR; - } /* * Set the object's class. @@ -1212,8 +1412,11 @@ TclOODefineClassObjCmd( if (oPtr->selfCls != clsPtr) { TclOORemoveFromInstances(oPtr, oPtr->selfCls); + TclOODecrRefCount(oPtr->selfCls->thisPtr); oPtr->selfCls = clsPtr; + AddRef(oPtr->selfCls->thisPtr); TclOOAddToInstances(oPtr, oPtr->selfCls); + if (oPtr->classPtr != NULL) { BumpGlobalEpoch(interp, oPtr->classPtr); } else { @@ -1227,6 +1430,7 @@ TclOODefineClassObjCmd( * ---------------------------------------------------------------------- * * TclOODefineConstructorObjCmd -- + * * Implementation of the "constructor" subcommand of the "oo::define" * command. * @@ -1261,7 +1465,7 @@ TclOODefineConstructorObjCmd( } clsPtr = oPtr->classPtr; - Tcl_GetStringFromObj(objv[2], &bodyLength); + TclGetStringFromObj(objv[2], &bodyLength); if (bodyLength > 0) { /* * Create the method structure. @@ -1295,6 +1499,7 @@ TclOODefineConstructorObjCmd( * ---------------------------------------------------------------------- * * TclOODefineDeleteMethodObjCmd -- + * * Implementation of the "deletemethod" subcommand of the "oo::define" * and "oo::objdefine" commands. * @@ -1351,6 +1556,7 @@ TclOODefineDeleteMethodObjCmd( * ---------------------------------------------------------------------- * * TclOODefineDestructorObjCmd -- + * * Implementation of the "destructor" subcommand of the "oo::define" * command. * @@ -1380,7 +1586,7 @@ TclOODefineDestructorObjCmd( } clsPtr = oPtr->classPtr; - Tcl_GetStringFromObj(objv[1], &bodyLength); + TclGetStringFromObj(objv[1], &bodyLength); if (bodyLength > 0) { /* * Create the method structure. @@ -1415,6 +1621,7 @@ TclOODefineDestructorObjCmd( * ---------------------------------------------------------------------- * * TclOODefineExportObjCmd -- + * * Implementation of the "export" subcommand of the "oo::define" and * "oo::objdefine" commands. * @@ -1485,8 +1692,9 @@ TclOODefineExportObjCmd( } else { mPtr = Tcl_GetHashValue(hPtr); } - if (isNew || !(mPtr->flags & PUBLIC_METHOD)) { + if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) { mPtr->flags |= PUBLIC_METHOD; + mPtr->flags &= ~TRUE_PRIVATE_METHOD; changed = 1; } } @@ -1509,6 +1717,7 @@ TclOODefineExportObjCmd( * ---------------------------------------------------------------------- * * TclOODefineForwardObjCmd -- + * * Implementation of the "forward" subcommand of the "oo::define" and * "oo::objdefine" commands. * @@ -1545,6 +1754,9 @@ TclOODefineForwardObjCmd( } isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*") ? PUBLIC_METHOD : 0; + if (IsPrivateDefine(interp)) { + isPublic = TRUE_PRIVATE_METHOD; + } /* * Create the method structure. @@ -1569,6 +1781,7 @@ TclOODefineForwardObjCmd( * ---------------------------------------------------------------------- * * TclOODefineMethodObjCmd -- + * * Implementation of the "method" subcommand of the "oo::define" and * "oo::objdefine" commands. * @@ -1603,6 +1816,9 @@ TclOODefineMethodObjCmd( } isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*") ? PUBLIC_METHOD : 0; + if (IsPrivateDefine(interp)) { + isPublic = TRUE_PRIVATE_METHOD; + } /* * Create the method by using the right back-end API. @@ -1625,70 +1841,8 @@ TclOODefineMethodObjCmd( /* * ---------------------------------------------------------------------- * - * TclOODefineMixinObjCmd -- - * Implementation of the "mixin" subcommand of the "oo::define" and - * "oo::objdefine" commands. - * - * ---------------------------------------------------------------------- - */ - -int -TclOODefineMixinObjCmd( - ClientData clientData, - Tcl_Interp *interp, - const int objc, - Tcl_Obj *const *objv) -{ - int isInstanceMixin = (clientData != NULL); - Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Class **mixins; - int i; - - if (oPtr == NULL) { - return TCL_ERROR; - } - if (!isInstanceMixin && !oPtr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to misuse API", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); - return TCL_ERROR; - } - mixins = TclStackAlloc(interp, sizeof(Class *) * (objc-1)); - - for (i=1 ; i<objc ; i++) { - Class *clsPtr = GetClassInOuterContext(interp, objv[i], - "may only mix in classes"); - - if (clsPtr == NULL) { - goto freeAndError; - } - if (!isInstanceMixin && TclOOIsReachable(oPtr->classPtr, clsPtr)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "may not mix a class into itself", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL); - goto freeAndError; - } - mixins[i-1] = clsPtr; - } - - if (isInstanceMixin) { - TclOOObjectSetMixins(oPtr, objc-1, mixins); - } else { - TclOOClassSetMixins(interp, oPtr->classPtr, objc-1, mixins); - } - - TclStackFree(interp, mixins); - return TCL_OK; - - freeAndError: - TclStackFree(interp, mixins); - return TCL_ERROR; -} - -/* - * ---------------------------------------------------------------------- - * * TclOODefineRenameMethodObjCmd -- + * * Implementation of the "renamemethod" subcommand of the "oo::define" * and "oo::objdefine" commands. * @@ -1745,6 +1899,7 @@ TclOODefineRenameMethodObjCmd( * ---------------------------------------------------------------------- * * TclOODefineUnexportObjCmd -- + * * Implementation of the "unexport" subcommand of the "oo::define" and * "oo::objdefine" commands. * @@ -1815,8 +1970,8 @@ TclOODefineUnexportObjCmd( } else { mPtr = Tcl_GetHashValue(hPtr); } - if (isNew || mPtr->flags & PUBLIC_METHOD) { - mPtr->flags &= ~PUBLIC_METHOD; + if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) { + mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD); changed = 1; } } @@ -1839,6 +1994,7 @@ TclOODefineUnexportObjCmd( * ---------------------------------------------------------------------- * * Tcl_ClassSetConstructor, Tcl_ClassSetDestructor -- + * * How to install a constructor or destructor into a class; API to call * from C. * @@ -1893,6 +2049,7 @@ Tcl_ClassSetDestructor( * ---------------------------------------------------------------------- * * TclOODefineSlots -- + * * Create the "::oo::Slot" class and its standard instances. Class * definition is empty at the stage (added by scripting). * @@ -1936,6 +2093,7 @@ TclOODefineSlots( * ---------------------------------------------------------------------- * * ClassFilterGet, ClassFilterSet -- + * * Implementation of the "filter" slot accessors of the "oo::define" * command. * @@ -2015,6 +2173,7 @@ ClassFilterSet( * ---------------------------------------------------------------------- * * ClassMixinGet, ClassMixinSet -- + * * Implementation of the "mixin" slot accessors of the "oo::define" * command. * @@ -2096,6 +2255,7 @@ ClassMixinSet( mixins[i] = GetClassInOuterContext(interp, mixinv[i], "may only mix in classes"); if (mixins[i] == NULL) { + i--; goto freeAndError; } if (TclOOIsReachable(oPtr->classPtr, mixins[i])) { @@ -2119,6 +2279,7 @@ ClassMixinSet( * ---------------------------------------------------------------------- * * ClassSuperGet, ClassSuperSet -- + * * Implementation of the "superclass" slot accessors of the "oo::define" * command. * @@ -2213,16 +2374,19 @@ ClassSuperSet( if (superc == 0) { superclasses = ckrealloc(superclasses, sizeof(Class *)); - superclasses[0] = oPtr->fPtr->objectCls; - superc = 1; if (TclOOIsReachable(oPtr->fPtr->classCls, oPtr->classPtr)) { superclasses[0] = oPtr->fPtr->classCls; + } else { + superclasses[0] = oPtr->fPtr->objectCls; } + superc = 1; + AddRef(superclasses[0]->thisPtr); } else { for (i=0 ; i<superc ; i++) { superclasses[i] = GetClassInOuterContext(interp, superv[i], "only a class can be a superclass"); if (superclasses[i] == NULL) { + i--; goto failedAfterAlloc; } for (j=0 ; j<i ; j++) { @@ -2239,9 +2403,19 @@ ClassSuperSet( "attempt to form circular dependency graph", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL); failedAfterAlloc: - ckfree((char *) superclasses); + for (; i > 0; i--) { + TclOODecrRefCount(superclasses[i]->thisPtr); + } + ckfree(superclasses); return TCL_ERROR; } + + /* + * Corresponding TclOODecrRefCount() is near the end of this + * function. + */ + + AddRef(superclasses[i]->thisPtr); } } @@ -2255,8 +2429,9 @@ ClassSuperSet( if (oPtr->classPtr->superclasses.num != 0) { FOREACH(superPtr, oPtr->classPtr->superclasses) { TclOORemoveFromSubclasses(oPtr->classPtr, superPtr); + TclOODecrRefCount(superPtr->thisPtr); } - ckfree((char *) oPtr->classPtr->superclasses.list); + ckfree(oPtr->classPtr->superclasses.list); } oPtr->classPtr->superclasses.list = superclasses; oPtr->classPtr->superclasses.num = superc; @@ -2272,6 +2447,7 @@ ClassSuperSet( * ---------------------------------------------------------------------- * * ClassVarsGet, ClassVarsSet -- + * * Implementation of the "variable" slot accessors of the "oo::define" * command. * @@ -2287,7 +2463,7 @@ ClassVarsGet( Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Obj *resultObj, *variableObj; + Tcl_Obj *resultObj; int i; if (Tcl_ObjectContextSkippedArgs(context) != objc) { @@ -2305,8 +2481,18 @@ ClassVarsGet( } resultObj = Tcl_NewObj(); - FOREACH(variableObj, oPtr->classPtr->variables) { - Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + if (IsPrivateDefine(interp)) { + PrivateVariableMapping *privatePtr; + + FOREACH_STRUCT(privatePtr, oPtr->classPtr->privateVariables) { + Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj); + } + } else { + Tcl_Obj *variableObj; + + FOREACH(variableObj, oPtr->classPtr->variables) { + Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + } } Tcl_SetObjResult(interp, resultObj); return TCL_OK; @@ -2322,7 +2508,7 @@ ClassVarsSet( { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); int varc; - Tcl_Obj **varv, *variableObj; + Tcl_Obj **varv; int i; if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { @@ -2345,7 +2531,7 @@ ClassVarsSet( } for (i=0 ; i<varc ; i++) { - const char *varName = Tcl_GetString(varv[i]); + const char *varName = TclGetString(varv[i]); if (strstr(varName, "::") != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -2363,49 +2549,11 @@ ClassVarsSet( } } - for (i=0 ; i<varc ; i++) { - Tcl_IncrRefCount(varv[i]); - } - FOREACH(variableObj, oPtr->classPtr->variables) { - Tcl_DecrRefCount(variableObj); - } - if (i != varc) { - if (varc == 0) { - ckfree((char *) oPtr->classPtr->variables.list); - } else if (i) { - oPtr->classPtr->variables.list = (Tcl_Obj **) - ckrealloc((char *) oPtr->classPtr->variables.list, - sizeof(Tcl_Obj *) * varc); - } else { - oPtr->classPtr->variables.list = (Tcl_Obj **) - ckalloc(sizeof(Tcl_Obj *) * varc); - } - } - - oPtr->classPtr->variables.num = 0; - if (varc > 0) { - int created, n; - Tcl_HashTable uniqueTable; - - Tcl_InitObjHashTable(&uniqueTable); - for (i=n=0 ; i<varc ; i++) { - Tcl_CreateHashEntry(&uniqueTable, varv[i], &created); - if (created) { - oPtr->classPtr->variables.list[n++] = varv[i]; - } else { - Tcl_DecrRefCount(varv[i]); - } - } - oPtr->classPtr->variables.num = n; - - /* - * Shouldn't be necessary, but maintain num/list invariant. - */ - - oPtr->classPtr->variables.list = (Tcl_Obj **) - ckrealloc((char *) oPtr->classPtr->variables.list, - sizeof(Tcl_Obj *) * n); - Tcl_DeleteHashTable(&uniqueTable); + if (IsPrivateDefine(interp)) { + InstallPrivateVariableMapping(&oPtr->classPtr->privateVariables, + varc, varv, oPtr->classPtr->thisPtr->creationEpoch); + } else { + InstallStandardVariableMapping(&oPtr->classPtr->variables, varc, varv); } return TCL_OK; } @@ -2414,6 +2562,7 @@ ClassVarsSet( * ---------------------------------------------------------------------- * * ObjectFilterGet, ObjectFilterSet -- + * * Implementation of the "filter" slot accessors of the "oo::objdefine" * command. * @@ -2481,6 +2630,7 @@ ObjFilterSet( * ---------------------------------------------------------------------- * * ObjectMixinGet, ObjectMixinSet -- + * * Implementation of the "mixin" slot accessors of the "oo::objdefine" * command. * @@ -2510,8 +2660,10 @@ ObjMixinGet( resultObj = Tcl_NewObj(); FOREACH(mixinPtr, oPtr->mixins) { - Tcl_ListObjAppendElement(NULL, resultObj, - TclOOObjectName(interp, mixinPtr->thisPtr)); + if (mixinPtr) { + Tcl_ListObjAppendElement(NULL, resultObj, + TclOOObjectName(interp, mixinPtr->thisPtr)); + } } Tcl_SetObjResult(interp, resultObj); return TCL_OK; @@ -2564,6 +2716,7 @@ ObjMixinSet( * ---------------------------------------------------------------------- * * ObjectVarsGet, ObjectVarsSet -- + * * Implementation of the "variable" slot accessors of the "oo::objdefine" * command. * @@ -2579,7 +2732,7 @@ ObjVarsGet( Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Obj *resultObj, *variableObj; + Tcl_Obj *resultObj; int i; if (Tcl_ObjectContextSkippedArgs(context) != objc) { @@ -2591,8 +2744,18 @@ ObjVarsGet( } resultObj = Tcl_NewObj(); - FOREACH(variableObj, oPtr->variables) { - Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + if (IsPrivateDefine(interp)) { + PrivateVariableMapping *privatePtr; + + FOREACH_STRUCT(privatePtr, oPtr->privateVariables) { + Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj); + } + } else { + Tcl_Obj *variableObj; + + FOREACH(variableObj, oPtr->variables) { + Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + } } Tcl_SetObjResult(interp, resultObj); return TCL_OK; @@ -2608,7 +2771,7 @@ ObjVarsSet( { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); int varc, i; - Tcl_Obj **varv, *variableObj; + Tcl_Obj **varv; if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -2624,7 +2787,7 @@ ObjVarsSet( } for (i=0 ; i<varc ; i++) { - const char *varName = Tcl_GetString(varv[i]); + const char *varName = TclGetString(varv[i]); if (strstr(varName, "::") != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -2641,49 +2804,12 @@ ObjVarsSet( return TCL_ERROR; } } - for (i=0 ; i<varc ; i++) { - Tcl_IncrRefCount(varv[i]); - } - - FOREACH(variableObj, oPtr->variables) { - Tcl_DecrRefCount(variableObj); - } - if (i != varc) { - if (varc == 0) { - ckfree((char *) oPtr->variables.list); - } else if (i) { - oPtr->variables.list = (Tcl_Obj **) - ckrealloc((char *) oPtr->variables.list, - sizeof(Tcl_Obj *) * varc); - } else { - oPtr->variables.list = (Tcl_Obj **) - ckalloc(sizeof(Tcl_Obj *) * varc); - } - } - oPtr->variables.num = 0; - if (varc > 0) { - int created, n; - Tcl_HashTable uniqueTable; - Tcl_InitObjHashTable(&uniqueTable); - for (i=n=0 ; i<varc ; i++) { - Tcl_CreateHashEntry(&uniqueTable, varv[i], &created); - if (created) { - oPtr->variables.list[n++] = varv[i]; - } else { - Tcl_DecrRefCount(varv[i]); - } - } - oPtr->variables.num = n; - - /* - * Shouldn't be necessary, but maintain num/list invariant. - */ - - oPtr->variables.list = (Tcl_Obj **) - ckrealloc((char *) oPtr->variables.list, - sizeof(Tcl_Obj *) * n); - Tcl_DeleteHashTable(&uniqueTable); + if (IsPrivateDefine(interp)) { + InstallPrivateVariableMapping(&oPtr->privateVariables, varc, varv, + oPtr->creationEpoch); + } else { + InstallStandardVariableMapping(&oPtr->variables, varc, varv); } return TCL_OK; } diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index 3217f98..fe433e4 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -22,6 +22,7 @@ static Tcl_ObjCmdProc InfoObjectClassCmd; static Tcl_ObjCmdProc InfoObjectDefnCmd; static Tcl_ObjCmdProc InfoObjectFiltersCmd; static Tcl_ObjCmdProc InfoObjectForwardCmd; +static Tcl_ObjCmdProc InfoObjectIdCmd; static Tcl_ObjCmdProc InfoObjectIsACmd; static Tcl_ObjCmdProc InfoObjectMethodsCmd; static Tcl_ObjCmdProc InfoObjectMethodTypeCmd; @@ -50,6 +51,7 @@ static Tcl_ObjCmdProc InfoClassVariablesCmd; static const EnsembleImplMap infoObjectCmds[] = { {"call", InfoObjectCallCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"class", InfoObjectClassCmd, TclCompileInfoObjectClassCmd, NULL, NULL, 0}, + {"creationid", InfoObjectIdCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"definition", InfoObjectDefnCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"filters", InfoObjectFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"forward", InfoObjectForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, @@ -58,7 +60,7 @@ static const EnsembleImplMap infoObjectCmds[] = { {"methodtype", InfoObjectMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"mixins", InfoObjectMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"namespace", InfoObjectNsCmd, TclCompileInfoObjectNamespaceCmd, NULL, NULL, 0}, - {"variables", InfoObjectVariablesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"variables", InfoObjectVariablesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {"vars", InfoObjectVarsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} }; @@ -80,7 +82,7 @@ static const EnsembleImplMap infoClassCmds[] = { {"mixins", InfoClassMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"subclasses", InfoClassSubsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {"superclasses", InfoClassSupersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"variables", InfoClassVariablesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"variables", InfoClassVariablesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} }; @@ -196,6 +198,9 @@ InfoObjectClassCmd( } FOREACH(mixinPtr, oPtr->mixins) { + if (!mixinPtr) { + continue; + } if (TclOOIsReachable(o2clsPtr, mixinPtr)) { Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); return TCL_OK; @@ -401,7 +406,7 @@ InfoObjectIsACmd( IsClass, IsMetaclass, IsMixin, IsObject, IsType }; Object *oPtr, *o2Ptr; - int idx, i; + int idx, i, result = 0; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "category objName ?arg ...?"); @@ -412,93 +417,88 @@ InfoObjectIsACmd( return TCL_ERROR; } - if (idx == IsObject) { - int ok = (Tcl_GetObjectFromObj(interp, objv[2]) != NULL); - - if (!ok) { - Tcl_ResetResult(interp); - } - Tcl_SetObjResult(interp, Tcl_NewIntObj(ok ? 1 : 0)); - return TCL_OK; - } - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); - if (oPtr == NULL) { - return TCL_ERROR; - } + /* + * Now we know what test we are doing, we can check we've got the right + * number of arguments. + */ switch ((enum IsACats) idx) { + case IsObject: case IsClass: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "objName"); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewIntObj(oPtr->classPtr ? 1 : 0)); - return TCL_OK; case IsMetaclass: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "objName"); return TCL_ERROR; } - if (oPtr->classPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); - } else { - Class *classCls = TclOOGetFoundation(interp)->classCls; - - Tcl_SetObjResult(interp, Tcl_NewIntObj( - TclOOIsReachable(classCls, oPtr->classPtr) ? 1 : 0)); - } - return TCL_OK; + break; case IsMixin: + case IsType: if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "objName className"); return TCL_ERROR; } + break; + } + + /* + * Perform the check. Note that we can guarantee that we will not fail + * from here on; "failures" result in a false-TCL_OK result. + */ + + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); + if (oPtr == NULL) { + goto failPrecondition; + } + + switch ((enum IsACats) idx) { + case IsObject: + result = 1; + break; + case IsClass: + result = (oPtr->classPtr != NULL); + break; + case IsMetaclass: + if (oPtr->classPtr != NULL) { + result = TclOOIsReachable(TclOOGetFoundation(interp)->classCls, + oPtr->classPtr); + } + break; + case IsMixin: o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[3]); if (o2Ptr == NULL) { - return TCL_ERROR; + goto failPrecondition; } - if (o2Ptr->classPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "non-classes cannot be mixins", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "NONCLASS", NULL); - return TCL_ERROR; - } else { + if (o2Ptr->classPtr != NULL) { Class *mixinPtr; FOREACH(mixinPtr, oPtr->mixins) { - if (mixinPtr == o2Ptr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); - return TCL_OK; + if (!mixinPtr) { + continue; + } + if (TclOOIsReachable(o2Ptr->classPtr, mixinPtr)) { + result = 1; + break; } } } - Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); - return TCL_OK; + break; case IsType: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "objName className"); - return TCL_ERROR; - } o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[3]); if (o2Ptr == NULL) { - return TCL_ERROR; - } - if (o2Ptr->classPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "non-classes cannot be types", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "NONCLASS", NULL); - return TCL_ERROR; + goto failPrecondition; } - if (TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls)) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); - } else { - Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); + if (o2Ptr->classPtr != NULL) { + result = TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls); } - return TCL_OK; - case IsObject: - Tcl_Panic("unexpected fallthrough"); + break; } - return TCL_ERROR; + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); + return TCL_OK; + + failPrecondition: + Tcl_ResetResult(interp); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); + return TCL_OK; } /* @@ -519,15 +519,22 @@ InfoObjectMethodsCmd( Tcl_Obj *const objv[]) { Object *oPtr; - int flag = PUBLIC_METHOD, recurse = 0; + int flag = PUBLIC_METHOD, recurse = 0, scope = -1; FOREACH_HASH_DECLS; Tcl_Obj *namePtr, *resultObj; Method *mPtr; static const char *const options[] = { - "-all", "-localprivate", "-private", NULL + "-all", "-localprivate", "-private", "-scope", NULL }; enum Options { - OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE + OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE, OPT_SCOPE + }; + static const char *const scopes[] = { + "private", "public", "unexported" + }; + enum Scopes { + SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED, + SCOPE_LOCALPRIVATE }; if (objc < 2) { @@ -556,14 +563,45 @@ InfoObjectMethodsCmd( case OPT_PRIVATE: flag = 0; break; + case OPT_SCOPE: + if (++i >= objc) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "missing option for -scope")); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", + NULL); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[i], scopes, "scope", 0, + &scope) != TCL_OK) { + return TCL_ERROR; + } + break; } } } + if (scope != -1) { + recurse = 0; + switch (scope) { + case SCOPE_PRIVATE: + flag = TRUE_PRIVATE_METHOD; + break; + case SCOPE_PUBLIC: + flag = PUBLIC_METHOD; + break; + case SCOPE_LOCALPRIVATE: + flag = PRIVATE_METHOD; + break; + case SCOPE_UNEXPORTED: + flag = 0; + break; + } + } resultObj = Tcl_NewObj(); if (recurse) { const char **names; - int i, numNames = TclOOGetSortedMethodList(oPtr, flag, &names); + int i, numNames = TclOOGetSortedMethodList(oPtr, NULL, NULL, flag, + &names); for (i=0 ; i<numNames ; i++) { Tcl_ListObjAppendElement(NULL, resultObj, @@ -574,7 +612,7 @@ InfoObjectMethodsCmd( } } else if (oPtr->methodsPtr) { FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) { - if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) { + if (mPtr->typePtr && (mPtr->flags & SCOPE_FLAGS) == flag) { Tcl_ListObjAppendElement(NULL, resultObj, namePtr); } } @@ -673,6 +711,9 @@ InfoObjectMixinsCmd( resultObj = Tcl_NewObj(); FOREACH(mixinPtr, oPtr->mixins) { + if (!mixinPtr) { + continue; + } Tcl_ListObjAppendElement(NULL, resultObj, TclOOObjectName(interp, mixinPtr->thisPtr)); } @@ -683,6 +724,38 @@ InfoObjectMixinsCmd( /* * ---------------------------------------------------------------------- * + * InfoObjectIdCmd -- + * + * Implements [info object creationid $objName] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoObjectIdCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Object *oPtr; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "objName"); + return TCL_ERROR; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + + Tcl_SetObjResult(interp, Tcl_NewIntObj(oPtr->creationEpoch)); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * * InfoObjectNsCmd -- * * Implements [info object namespace $objName] @@ -718,7 +791,7 @@ InfoObjectNsCmd( * * InfoObjectVariablesCmd -- * - * Implements [info object variables $objName] + * Implements [info object variables $objName ?-private?] * * ---------------------------------------------------------------------- */ @@ -731,21 +804,37 @@ InfoObjectVariablesCmd( Tcl_Obj *const objv[]) { Object *oPtr; - Tcl_Obj *variableObj, *resultObj; - int i; + Tcl_Obj *resultObj; + int i, private = 0; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "objName"); + if (objc != 2 && objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "objName ?-private?"); return TCL_ERROR; } + if (objc == 3) { + if (strcmp("-private", Tcl_GetString(objv[2])) != 0) { + return TCL_ERROR; + } + private = 1; + } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); if (oPtr == NULL) { return TCL_ERROR; } resultObj = Tcl_NewObj(); - FOREACH(variableObj, oPtr->variables) { - Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + if (private) { + PrivateVariableMapping *privatePtr; + + FOREACH_STRUCT(privatePtr, oPtr->privateVariables) { + Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj); + } + } else { + Tcl_Obj *variableObj; + + FOREACH(variableObj, oPtr->variables) { + Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + } } Tcl_SetObjResult(interp, resultObj); return TCL_OK; @@ -1127,7 +1216,7 @@ InfoClassInstancesCmd( * * InfoClassMethodsCmd -- * - * Implements [info class methods $clsName ?-private?] + * Implements [info class methods $clsName ?options...?] * * ---------------------------------------------------------------------- */ @@ -1139,15 +1228,21 @@ InfoClassMethodsCmd( int objc, Tcl_Obj *const objv[]) { - int flag = PUBLIC_METHOD, recurse = 0; + int flag = PUBLIC_METHOD, recurse = 0, scope = -1; Tcl_Obj *namePtr, *resultObj; Method *mPtr; Class *clsPtr; static const char *const options[] = { - "-all", "-localprivate", "-private", NULL + "-all", "-localprivate", "-private", "-scope", NULL }; enum Options { - OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE + OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE, OPT_SCOPE + }; + static const char *const scopes[] = { + "private", "public", "unexported" + }; + enum Scopes { + SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED }; if (objc < 2) { @@ -1176,9 +1271,36 @@ InfoClassMethodsCmd( case OPT_PRIVATE: flag = 0; break; + case OPT_SCOPE: + if (++i >= objc) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "missing option for -scope")); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", + NULL); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[i], scopes, "scope", 0, + &scope) != TCL_OK) { + return TCL_ERROR; + } + break; } } } + if (scope != -1) { + recurse = 0; + switch (scope) { + case SCOPE_PRIVATE: + flag = TRUE_PRIVATE_METHOD; + break; + case SCOPE_PUBLIC: + flag = PUBLIC_METHOD; + break; + case SCOPE_UNEXPORTED: + flag = 0; + break; + } + } resultObj = Tcl_NewObj(); if (recurse) { @@ -1196,7 +1318,7 @@ InfoClassMethodsCmd( FOREACH_HASH_DECLS; FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) { - if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) { + if (mPtr->typePtr && (mPtr->flags & SCOPE_FLAGS) == flag) { Tcl_ListObjAppendElement(NULL, resultObj, namePtr); } } @@ -1289,6 +1411,9 @@ InfoClassMixinsCmd( resultObj = Tcl_NewObj(); FOREACH(mixinPtr, clsPtr->mixins) { + if (!mixinPtr) { + continue; + } Tcl_ListObjAppendElement(NULL, resultObj, TclOOObjectName(interp, mixinPtr->thisPtr)); } @@ -1395,7 +1520,7 @@ InfoClassSupersCmd( * * InfoClassVariablesCmd -- * - * Implements [info class variables $clsName] + * Implements [info class variables $clsName ?-private?] * * ---------------------------------------------------------------------- */ @@ -1408,21 +1533,37 @@ InfoClassVariablesCmd( Tcl_Obj *const objv[]) { Class *clsPtr; - Tcl_Obj *variableObj, *resultObj; - int i; + Tcl_Obj *resultObj; + int i, private = 0; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "className"); + if (objc != 2 && objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "className ?-private?"); return TCL_ERROR; } + if (objc == 3) { + if (strcmp("-private", Tcl_GetString(objv[2])) != 0) { + return TCL_ERROR; + } + private = 1; + } clsPtr = GetClassFromObj(interp, objv[1]); if (clsPtr == NULL) { return TCL_ERROR; } resultObj = Tcl_NewObj(); - FOREACH(variableObj, clsPtr->variables) { - Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + if (private) { + PrivateVariableMapping *privatePtr; + + FOREACH_STRUCT(privatePtr, clsPtr->privateVariables) { + Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj); + } + } else { + Tcl_Obj *variableObj; + + FOREACH(variableObj, clsPtr->variables) { + Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + } } Tcl_SetObjResult(interp, resultObj); return TCL_OK; @@ -1461,7 +1602,8 @@ InfoObjectCallCmd( * Get the call context and render its call chain. */ - contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL); + contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL, NULL, + NULL); if (contextPtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot construct any call chain", -1)); diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index ab54964..1f30fed 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -122,15 +122,21 @@ typedef struct ForwardMethod { Tcl_Obj *prefixObj; /* The list of values to use to replace the * object and method name with. Will be a * non-empty list. */ - int fullyQualified; /* If 1, the command name is fully qualified - * and we should let the default Tcl mechanism - * handle the command lookup because it is - * more efficient. If 0, we need to do a - * specialized lookup based on the current - * object's namespace. */ } ForwardMethod; /* + * Structure used in private variable mappings. Describes the mapping of a + * single variable from the user's local name to the system's storage name. + * [TIP #500] + */ + +typedef struct { + Tcl_Obj *variableObj; /* Name used within methods. This is the part + * that is properly under user control. */ + Tcl_Obj *fullNameObj; /* Name used at the instance namespace level. */ +} PrivateVariableMapping; + +/* * Helper definitions that declare a "list" array. The two varieties are * either optimized for simplicity (in the case that the whole array is * typically assigned at once) or efficiency (in the case that the array is @@ -148,6 +154,13 @@ typedef struct ForwardMethod { struct { int num, size; listType_t *list; } /* + * These types are needed in function arguments. + */ + +typedef LIST_STATIC(Tcl_Obj *) VariableNameList; +typedef LIST_STATIC(PrivateVariableMapping) PrivateVariableList; + +/* * Now, the definition of what an object actually is. */ @@ -155,8 +168,8 @@ typedef struct Object { struct Foundation *fPtr; /* The basis for the object system. Putting * this here allows the avoidance of quite a * lot of hash lookups on the critical path - * for object invokation and creation. */ - Tcl_Namespace *namespacePtr;/* This object's tame namespace. */ + * for object invocation and creation. */ + Tcl_Namespace *namespacePtr;/* This object's namespace. */ Tcl_Command command; /* Reference to this object's public * command. */ Tcl_Command myCommand; /* Reference to this object's internal @@ -168,12 +181,12 @@ typedef struct Object { /* Classes mixed into this object. */ LIST_STATIC(Tcl_Obj *) filters; /* List of filter names. */ - struct Class *classPtr; /* All classes have this non-NULL; it points - * to the class structure. Everything else has - * this NULL. */ + struct Class *classPtr; /* This is non-NULL for all classes, and NULL + * for everything else. It points to the class + * structure. */ int refCount; /* Number of strong references to this object. * Note that there may be many more weak - * references; this mechanism is there to + * references; this mechanism exists to * avoid Tcl_Preserve. */ int flags; int creationEpoch; /* Unique value to make comparisons of objects @@ -192,13 +205,22 @@ typedef struct Object { Tcl_ObjectMapMethodNameProc *mapMethodNameProc; /* Function to allow remapping of method * names. For itcl-ng. */ - LIST_STATIC(Tcl_Obj *) variables; + VariableNameList variables; + PrivateVariableList privateVariables; + /* Configurations for the variable resolver + * used inside methods. */ + Tcl_Command myclassCommand; /* Reference to this object's class dispatcher + * command. */ } Object; #define OBJECT_DELETED 1 /* Flag to say that an object has been * destroyed. */ #define DESTRUCTOR_CALLED 2 /* Flag to say that the destructor has been * called. */ +#define CLASS_GONE 4 /* Obsolete. Indicates that the class of this + * object has been deleted, and so the object + * should not attempt to remove itself from its + * class. */ #define ROOT_OBJECT 0x1000 /* Flag to say that this object is the root of * the class hierarchy and should be treated * specially during teardown. */ @@ -216,6 +238,10 @@ typedef struct Object { * other spots). */ #define FORCE_UNKNOWN 0x10000 /* States that we are *really* looking up the * unknown method handler at that point. */ +#define HAS_PRIVATE_METHODS 0x20000 + /* Object/class has (or had) private methods, + * and so shouldn't be cached so + * aggressively. */ /* * And the definition of a class. Note that every class also has an associated @@ -225,10 +251,6 @@ typedef struct Object { typedef struct Class { Object *thisPtr; /* Reference to the object associated with * this class. */ - int refCount; /* Number of strong references to this class. - * Weak references are not counted; the - * purpose of this is to avoid Tcl_Preserve as - * that is quite slow. */ int flags; /* Assorted flags. */ LIST_STATIC(struct Class *) superclasses; /* List of superclasses, used for generation @@ -274,7 +296,10 @@ typedef struct Class { * object doesn't override with its own mixins * (and filters and method implementations for * when getting method chains). */ - LIST_STATIC(Tcl_Obj *) variables; + VariableNameList variables; + PrivateVariableList privateVariables; + /* Configurations for the variable resolver + * used inside methods. */ } Class; /* @@ -326,7 +351,7 @@ typedef struct Foundation { } Foundation; /* - * A call context structure is built when a method is called. They contain the + * A call context structure is built when a method is called. It contains the * chain of method implementations that are to be invoked by a particular * call, and the process of calling walks the chain, with the [next] command * proceeding to the next entry in the chain. @@ -337,7 +362,7 @@ typedef struct Foundation { struct MInvoke { Method *mPtr; /* Reference to the method implementation * record. */ - int isFilter; /* Whether this is a filter invokation. */ + int isFilter; /* Whether this is a filter invocation. */ Class *filterDeclarer; /* What class decided to add the filter; if * NULL, it was added by the object. */ }; @@ -376,10 +401,15 @@ typedef struct CallContext { #define PUBLIC_METHOD 0x01 /* This is a public (exported) method. */ #define PRIVATE_METHOD 0x02 /* This is a private (class's direct instances - * only) method. */ + * only) method. Supports itcl. */ #define OO_UNKNOWN_METHOD 0x04 /* This is an unknown method. */ #define CONSTRUCTOR 0x08 /* This is a constructor. */ #define DESTRUCTOR 0x10 /* This is a destructor. */ +#define TRUE_PRIVATE_METHOD 0x20 + /* This is a private method only accessible + * from other methods defined on this class + * or instance. [TIP #500] */ +#define SCOPE_FLAGS (PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD) /* * Structure containing definition information about basic class methods. @@ -434,6 +464,12 @@ MODULE_SCOPE int TclOODefineClassObjCmd(ClientData clientData, MODULE_SCOPE int TclOODefineSelfObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); +MODULE_SCOPE int TclOODefineObjSelfObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); +MODULE_SCOPE int TclOODefinePrivateObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); MODULE_SCOPE int TclOOUnknownDefinition(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); @@ -495,6 +531,11 @@ MODULE_SCOPE int TclNRNewObjectInstance(Tcl_Interp *interp, const char *nsNameStr, int objc, Tcl_Obj *const *objv, int skip, Tcl_Object *objectPtr); +MODULE_SCOPE Object * TclNewObjectInstanceCommon(Tcl_Interp *interp, + Class *classPtr, + const char *nameStr, + const char *nsNameStr); +MODULE_SCOPE int TclOODecrRefCount(Object *oPtr); MODULE_SCOPE int TclOODefineSlots(Foundation *fPtr); MODULE_SCOPE void TclOODeleteChain(CallChain *callPtr); MODULE_SCOPE void TclOODeleteChainCache(Tcl_HashTable *tablePtr); @@ -502,6 +543,7 @@ MODULE_SCOPE void TclOODeleteContext(CallContext *contextPtr); MODULE_SCOPE void TclOODelMethodRef(Method *method); MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr, Tcl_Obj *methodNameObj, int flags, + Object *contextObjPtr, Class *contextClsPtr, Tcl_Obj *cacheInThisObj); MODULE_SCOPE CallChain *TclOOGetStereotypeCallChain(Class *clsPtr, Tcl_Obj *methodNameObj, int flags); @@ -511,7 +553,8 @@ MODULE_SCOPE Proc * TclOOGetProcFromMethod(Method *mPtr); MODULE_SCOPE Tcl_Obj * TclOOGetMethodBody(Method *mPtr); MODULE_SCOPE int TclOOGetSortedClassMethodList(Class *clsPtr, int flags, const char ***stringsPtr); -MODULE_SCOPE int TclOOGetSortedMethodList(Object *oPtr, int flags, +MODULE_SCOPE int TclOOGetSortedMethodList(Object *oPtr, + Object *contextObj, Class *contextCls, int flags, const char ***stringsPtr); MODULE_SCOPE int TclOOInit(Tcl_Interp *interp); MODULE_SCOPE void TclOOInitInfo(Tcl_Interp *interp); @@ -524,10 +567,10 @@ MODULE_SCOPE int TclNRObjectContextInvokeNext(Tcl_Interp *interp, MODULE_SCOPE void TclOONewBasicMethod(Tcl_Interp *interp, Class *clsPtr, const DeclaredClassMethod *dcm); MODULE_SCOPE Tcl_Obj * TclOOObjectName(Tcl_Interp *interp, Object *oPtr); -MODULE_SCOPE void TclOORemoveFromInstances(Object *oPtr, Class *clsPtr); -MODULE_SCOPE void TclOORemoveFromMixinSubs(Class *subPtr, +MODULE_SCOPE int TclOORemoveFromInstances(Object *oPtr, Class *clsPtr); +MODULE_SCOPE int TclOORemoveFromMixinSubs(Class *subPtr, Class *mixinPtr); -MODULE_SCOPE void TclOORemoveFromSubclasses(Class *subPtr, +MODULE_SCOPE int TclOORemoveFromSubclasses(Class *subPtr, Class *superPtr); MODULE_SCOPE Tcl_Obj * TclOORenderCallChain(Tcl_Interp *interp, CallChain *callPtr); @@ -542,24 +585,38 @@ MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr); #include "tclOOIntDecls.h" /* + * Alternatives to Tcl_Preserve/Tcl_EventuallyFree/Tcl_Release. + */ + +#define AddRef(ptr) ((ptr)->refCount++) + +/* * A convenience macro for iterating through the lists used in the internal - * memory management of objects. This is a bit gnarly because we want to do - * the assignment of the picked-out value only when the body test succeeds, - * but we cannot rely on the assigned value being useful, forcing us to do - * some nasty stuff with the comma operator. The compiler's optimizer should - * be able to sort it all out! - * + * memory management of objects. * REQUIRES DECLARATION: int i; */ #define FOREACH(var,ary) \ - for(i=0 ; (i<(ary).num?((var=(ary).list[i]),1):0) ; i++) + for(i=0 ; i<(ary).num; i++) if ((ary).list[i] == NULL) { \ + continue; \ + } else if (var = (ary).list[i], 1) + +/* + * A variation where the array is an array of structs. There's no issue with + * possible NULLs; every element of the array will be iterated over and the + * varable set to a pointer to each of those elements in turn. + * REQUIRES DECLARATION: int i; + */ + +#define FOREACH_STRUCT(var,ary) \ + for(i=0 ; var=&((ary).list[i]), i<(ary).num; i++) /* * Convenience macros for iterating through hash tables. FOREACH_HASH_DECLS * sets up the declarations needed for the main macro, FOREACH_HASH, which * does the actual iteration. FOREACH_HASH_VALUE is a restricted version that * only iterates over values. + * REQUIRES DECLARATION: FOREACH_HASH_DECLS; */ #define FOREACH_HASH_DECLS \ @@ -588,17 +645,6 @@ MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr); } \ } while(0) -/* - * Alternatives to Tcl_Preserve/Tcl_EventuallyFree/Tcl_Release. - */ - -#define AddRef(ptr) ((ptr)->refCount++) -#define DelRef(ptr) do { \ - if (--(ptr)->refCount < 1) { \ - ckfree((char *) (ptr)); \ - } \ - } while(0) - #endif /* TCL_OO_INTERNAL_H */ /* diff --git a/generic/tclOOIntDecls.h b/generic/tclOOIntDecls.h index acafb18..74a8d81 100644 --- a/generic/tclOOIntDecls.h +++ b/generic/tclOOIntDecls.h @@ -7,51 +7,55 @@ /* !BEGIN!: Do not edit below this line. */ +#ifdef __cplusplus +extern "C" { +#endif + /* * Exported function declarations: */ /* 0 */ -TCLOOAPI Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp); +TCLAPI Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp); /* 1 */ -TCLOOAPI Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, +TCLAPI Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 2 */ -TCLOOAPI Tcl_Method TclOOMakeProcMethod(Tcl_Interp *interp, +TCLAPI Tcl_Method TclOOMakeProcMethod(Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, const char *namePtr, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 3 */ -TCLOOAPI Method * TclOONewProcInstanceMethod(Tcl_Interp *interp, +TCLAPI Method * TclOONewProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 4 */ -TCLOOAPI Method * TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr, +TCLAPI Method * TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 5 */ -TCLOOAPI int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, +TCLAPI int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv, int publicOnly, Class *startCls); /* 6 */ -TCLOOAPI int TclOOIsReachable(Class *targetPtr, Class *startPtr); +TCLAPI int TclOOIsReachable(Class *targetPtr, Class *startPtr); /* 7 */ -TCLOOAPI Method * TclOONewForwardMethod(Tcl_Interp *interp, +TCLAPI Method * TclOONewForwardMethod(Tcl_Interp *interp, Class *clsPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 8 */ -TCLOOAPI Method * TclOONewForwardInstanceMethod(Tcl_Interp *interp, +TCLAPI Method * TclOONewForwardInstanceMethod(Tcl_Interp *interp, Object *oPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 9 */ -TCLOOAPI Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, +TCLAPI Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, @@ -60,7 +64,7 @@ TCLOOAPI Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 10 */ -TCLOOAPI Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, +TCLAPI Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Class clsPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, @@ -69,22 +73,22 @@ TCLOOAPI Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 11 */ -TCLOOAPI int TclOOInvokeObject(Tcl_Interp *interp, +TCLAPI int TclOOInvokeObject(Tcl_Interp *interp, Tcl_Object object, Tcl_Class startCls, int publicPrivate, int objc, Tcl_Obj *const *objv); /* 12 */ -TCLOOAPI void TclOOObjectSetFilters(Object *oPtr, int numFilters, +TCLAPI void TclOOObjectSetFilters(Object *oPtr, int numFilters, Tcl_Obj *const *filters); /* 13 */ -TCLOOAPI void TclOOClassSetFilters(Tcl_Interp *interp, +TCLAPI void TclOOClassSetFilters(Tcl_Interp *interp, Class *classPtr, int numFilters, Tcl_Obj *const *filters); /* 14 */ -TCLOOAPI void TclOOObjectSetMixins(Object *oPtr, int numMixins, +TCLAPI void TclOOObjectSetMixins(Object *oPtr, int numMixins, Class *const *mixins); /* 15 */ -TCLOOAPI void TclOOClassSetMixins(Tcl_Interp *interp, +TCLAPI void TclOOClassSetMixins(Tcl_Interp *interp, Class *classPtr, int numMixins, Class *const *mixins); @@ -110,10 +114,8 @@ typedef struct TclOOIntStubs { void (*tclOOClassSetMixins) (Tcl_Interp *interp, Class *classPtr, int numMixins, Class *const *mixins); /* 15 */ } TclOOIntStubs; -#ifdef __cplusplus -extern "C" { -#endif extern const TclOOIntStubs *tclOOIntStubsPtr; + #ifdef __cplusplus } #endif @@ -160,4 +162,5 @@ extern const TclOOIntStubs *tclOOIntStubsPtr; #endif /* defined(USE_TCLOO_STUBS) */ /* !END!: Do not edit above this line. */ + #endif /* _TCLOOINTDECLS */ diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index b91fdfd..ad14a1a 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -70,10 +70,8 @@ static Tcl_Obj ** InitEnsembleRewrite(Tcl_Interp *interp, int objc, static int InvokeProcedureMethod(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); -static int FinalizeForwardCall(ClientData data[], Tcl_Interp *interp, - int result); -static int FinalizePMCall(ClientData data[], Tcl_Interp *interp, - int result); +static Tcl_NRPostProc FinalizeForwardCall; +static Tcl_NRPostProc FinalizePMCall; static int PushMethodCallFrame(Tcl_Interp *interp, CallContext *contextPtr, ProcedureMethod *pmPtr, int objc, Tcl_Obj *const *objv, @@ -188,7 +186,11 @@ Tcl_NewInstanceMethod( mPtr->declaringObjectPtr = oPtr; mPtr->declaringClassPtr = NULL; if (flags) { - mPtr->flags |= flags & (PUBLIC_METHOD | PRIVATE_METHOD); + mPtr->flags |= flags & + (PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD); + if (flags & TRUE_PRIVATE_METHOD) { + oPtr->flags |= HAS_PRIVATE_METHODS; + } } oPtr->epoch++; return (Tcl_Method) mPtr; @@ -252,7 +254,11 @@ Tcl_NewMethod( mPtr->declaringObjectPtr = NULL; mPtr->declaringClassPtr = clsPtr; if (flags) { - mPtr->flags |= flags & (PUBLIC_METHOD | PRIVATE_METHOD); + mPtr->flags |= flags & + (PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD); + if (flags & TRUE_PRIVATE_METHOD) { + clsPtr->flags |= HAS_PRIVATE_METHODS; + } } return (Tcl_Method) mPtr; @@ -272,7 +278,7 @@ void TclOODelMethodRef( Method *mPtr) { - if ((mPtr != NULL) && (--mPtr->refCount <= 0)) { + if ((mPtr != NULL) && (mPtr->refCount-- <= 1)) { if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) { mPtr->typePtr->deleteProc(mPtr->clientData); } @@ -720,7 +726,7 @@ InvokeProcedureMethod( Tcl_PopCallFrame(interp); TclStackFree(interp, fdPtr->framePtr); - if (--pmPtr->refCount < 1) { + if (pmPtr->refCount-- <= 1) { DeleteProcedureMethodRecord(pmPtr); } TclStackFree(interp, fdPtr); @@ -771,7 +777,7 @@ FinalizePMCall( * sensitive when it comes to performance! */ - if (--pmPtr->refCount < 1) { + if (pmPtr->refCount-- <= 1) { DeleteProcedureMethodRecord(pmPtr); } TclStackFree(interp, fdPtr); @@ -875,11 +881,8 @@ PushMethodCallFrame( * This operation may fail. */ - result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, + (void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, (Tcl_Namespace *) nsPtr, FRAME_IS_PROC|FRAME_IS_METHOD); - if (result != TCL_OK) { - goto failureReturn; - } fdPtr->framePtr->clientData = contextPtr; fdPtr->framePtr->objc = objc; @@ -933,7 +936,7 @@ PushMethodCallFrame( * variables used in methods. The compiled variable resolver is more * important, but both are needed as it is possible to have a variable * that is only referred to in ways that aren't compilable and we can't - * force LVT presence. [TIP #320] + * force LVT presence. [TIP #320, #500] * * ---------------------------------------------------------------------- */ @@ -961,7 +964,7 @@ ProcedureMethodVarResolver( { int result; Tcl_ResolvedVarInfo *rPtr = NULL; - + result = ProcedureMethodCompiledVarResolver(interp, varName, strlen(varName), contextNs, &rPtr); @@ -991,6 +994,7 @@ ProcedureMethodCompiledVarConnect( CallFrame *framePtr = iPtr->varFramePtr; CallContext *contextPtr; Tcl_Obj *variableObj; + PrivateVariableMapping *privateVar; Tcl_HashEntry *hPtr; int i, isNew, cacheIt, varLen, len; const char *match, *varName; @@ -1024,6 +1028,15 @@ ProcedureMethodCompiledVarConnect( varName = TclGetStringFromObj(infoPtr->variableObj, &varLen); if (contextPtr->callPtr->chain[contextPtr->index] .mPtr->declaringClassPtr != NULL) { + FOREACH_STRUCT(privateVar, contextPtr->callPtr->chain[contextPtr->index] + .mPtr->declaringClassPtr->privateVariables) { + match = TclGetStringFromObj(privateVar->variableObj, &len); + if ((len == varLen) && !memcmp(match, varName, len)) { + variableObj = privateVar->fullNameObj; + cacheIt = 0; + goto gotMatch; + } + } FOREACH(variableObj, contextPtr->callPtr->chain[contextPtr->index] .mPtr->declaringClassPtr->variables) { match = TclGetStringFromObj(variableObj, &len); @@ -1033,6 +1046,14 @@ ProcedureMethodCompiledVarConnect( } } } else { + FOREACH_STRUCT(privateVar, contextPtr->oPtr->privateVariables) { + match = TclGetStringFromObj(privateVar->variableObj, &len); + if ((len == varLen) && !memcmp(match, varName, len)) { + variableObj = privateVar->fullNameObj; + cacheIt = 1; + goto gotMatch; + } + } FOREACH(variableObj, contextPtr->oPtr->variables) { match = TclGetStringFromObj(variableObj, &len); if ((len == varLen) && !memcmp(match, varName, len)) { @@ -1171,7 +1192,7 @@ MethodErrorHandler( CallContext *contextPtr = ((Interp *) interp)->varFramePtr->clientData; Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; const char *objectName, *kindName, *methodName = - Tcl_GetStringFromObj(mPtr->namePtr, &nameLen); + TclGetStringFromObj(mPtr->namePtr, &nameLen); Object *declarerPtr; if (mPtr->declaringObjectPtr != NULL) { @@ -1278,7 +1299,7 @@ DeleteProcedureMethod( { register ProcedureMethod *pmPtr = clientData; - if (--pmPtr->refCount < 1) { + if (pmPtr->refCount-- <= 1) { DeleteProcedureMethodRecord(pmPtr); } } @@ -1290,11 +1311,58 @@ CloneProcedureMethod( ClientData *newClientData) { ProcedureMethod *pmPtr = clientData; - ProcedureMethod *pm2Ptr = ckalloc(sizeof(ProcedureMethod)); + ProcedureMethod *pm2Ptr; + Tcl_Obj *bodyObj, *argsObj; + CompiledLocal *localPtr; + + /* + * Copy the argument list. + */ + + argsObj = Tcl_NewObj(); + for (localPtr=pmPtr->procPtr->firstLocalPtr; localPtr!=NULL; + localPtr=localPtr->nextPtr) { + if (TclIsVarArgument(localPtr)) { + Tcl_Obj *argObj = Tcl_NewObj(); + + Tcl_ListObjAppendElement(NULL, argObj, + Tcl_NewStringObj(localPtr->name, -1)); + if (localPtr->defValuePtr != NULL) { + Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr); + } + Tcl_ListObjAppendElement(NULL, argsObj, argObj); + } + } + + /* + * Must strip the internal representation in order to ensure that any + * bound references to instance variables are removed. [Bug 3609693] + */ + + bodyObj = Tcl_DuplicateObj(pmPtr->procPtr->bodyPtr); + Tcl_GetString(bodyObj); + TclFreeIntRep(bodyObj); + /* + * Create the actual copy of the method record, manufacturing a new proc + * record. + */ + + pm2Ptr = ckalloc(sizeof(ProcedureMethod)); memcpy(pm2Ptr, pmPtr, sizeof(ProcedureMethod)); pm2Ptr->refCount = 1; - pm2Ptr->procPtr->refCount++; + Tcl_IncrRefCount(argsObj); + Tcl_IncrRefCount(bodyObj); + if (TclCreateProc(interp, NULL, "", argsObj, bodyObj, + &pm2Ptr->procPtr) != TCL_OK) { + Tcl_DecrRefCount(argsObj); + Tcl_DecrRefCount(bodyObj); + ckfree(pm2Ptr); + return TCL_ERROR; + } + Tcl_DecrRefCount(argsObj); + Tcl_DecrRefCount(bodyObj); + if (pmPtr->cloneClientdataProc) { pm2Ptr->clientData = pmPtr->cloneClientdataProc(pmPtr->clientData); } @@ -1305,7 +1373,7 @@ CloneProcedureMethod( /* * ---------------------------------------------------------------------- * - * TclOONewForwardMethod -- + * TclOONewForwardInstanceMethod -- * * Create a forwarded method for an object. * @@ -1323,7 +1391,6 @@ TclOONewForwardInstanceMethod( { int prefixLen; register ForwardMethod *fmPtr; - Tcl_Obj *cmdObj; if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) { return NULL; @@ -1337,8 +1404,6 @@ TclOONewForwardInstanceMethod( fmPtr = ckalloc(sizeof(ForwardMethod)); fmPtr->prefixObj = prefixObj; - Tcl_ListObjIndex(interp, prefixObj, 0, &cmdObj); - fmPtr->fullyQualified = (strncmp(TclGetString(cmdObj), "::", 2) == 0); Tcl_IncrRefCount(prefixObj); return (Method *) Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, nameObj, flags, &fwdMethodType, fmPtr); @@ -1365,7 +1430,6 @@ TclOONewForwardMethod( { int prefixLen; register ForwardMethod *fmPtr; - Tcl_Obj *cmdObj; if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) { return NULL; @@ -1379,8 +1443,6 @@ TclOONewForwardMethod( fmPtr = ckalloc(sizeof(ForwardMethod)); fmPtr->prefixObj = prefixObj; - Tcl_ListObjIndex(interp, prefixObj, 0, &cmdObj); - fmPtr->fullyQualified = (strncmp(TclGetString(cmdObj), "::", 2) == 0); Tcl_IncrRefCount(prefixObj); return (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj, flags, &fwdMethodType, fmPtr); @@ -1409,7 +1471,6 @@ InvokeForwardMethod( ForwardMethod *fmPtr = clientData; Tcl_Obj **argObjs, **prefixObjs; int numPrefixes, len, skip = contextPtr->skip; - Command *cmdPtr; /* * Build the real list of arguments to use. Note that we know that the @@ -1421,15 +1482,15 @@ InvokeForwardMethod( Tcl_ListObjGetElements(NULL, fmPtr->prefixObj, &numPrefixes, &prefixObjs); argObjs = InitEnsembleRewrite(interp, objc, objv, skip, numPrefixes, prefixObjs, &len); - - if (fmPtr->fullyQualified) { - cmdPtr = NULL; - } else { - cmdPtr = (Command *) Tcl_FindCommand(interp, TclGetString(argObjs[0]), - contextPtr->oPtr->namespacePtr, 0 /* normal lookup */); - } Tcl_NRAddCallback(interp, FinalizeForwardCall, argObjs, NULL, NULL, NULL); - return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_INVOKE, cmdPtr); + /* + * NOTE: The combination of direct set of iPtr->lookupNsPtr and the use + * of the TCL_EVAL_NOERR flag results in an evaluation configuration + * very much like TCL_EVAL_INVOKE. + */ + ((Interp *)interp)->lookupNsPtr + = (Namespace *) contextPtr->oPtr->namespacePtr; + return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_NOERR, NULL); } static int @@ -1439,7 +1500,7 @@ FinalizeForwardCall( int result) { Tcl_Obj **argObjs = data[0]; - + TclStackFree(interp, argObjs); return result; } @@ -1474,7 +1535,6 @@ CloneForwardMethod( ForwardMethod *fm2Ptr = ckalloc(sizeof(ForwardMethod)); fm2Ptr->prefixObj = fmPtr->prefixObj; - fm2Ptr->fullyQualified = fmPtr->fullyQualified; Tcl_IncrRefCount(fm2Ptr->prefixObj); *newClientData = fm2Ptr; return TCL_OK; @@ -1564,12 +1624,9 @@ InitEnsembleRewrite( int *lengthPtr) /* Where to write the resulting length of the * array of rewritten arguments. */ { - Interp *iPtr = (Interp *) interp; - int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL); - Tcl_Obj **argObjs; unsigned len = rewriteLength + objc - toRewrite; + Tcl_Obj **argObjs = TclStackAlloc(interp, sizeof(Tcl_Obj *) * len); - argObjs = TclStackAlloc(interp, sizeof(Tcl_Obj *) * len); memcpy(argObjs, rewriteObjs, rewriteLength * sizeof(Tcl_Obj *)); memcpy(argObjs + rewriteLength, objv + toRewrite, sizeof(Tcl_Obj *) * (objc - toRewrite)); @@ -1583,22 +1640,9 @@ InitEnsembleRewrite( * (and unavoidably). */ - if (isRootEnsemble) { - iPtr->ensembleRewrite.sourceObjs = objv; - iPtr->ensembleRewrite.numRemovedObjs = toRewrite; - iPtr->ensembleRewrite.numInsertedObjs = rewriteLength; - } else { - int numIns = iPtr->ensembleRewrite.numInsertedObjs; - - if (numIns < toRewrite) { - iPtr->ensembleRewrite.numRemovedObjs += toRewrite - numIns; - iPtr->ensembleRewrite.numInsertedObjs += rewriteLength - 1; - } else { - iPtr->ensembleRewrite.numInsertedObjs += - rewriteLength - toRewrite; - } + if (TclInitRewriteEnsemble(interp, toRewrite, rewriteLength, objv)) { + TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); } - *lengthPtr = len; return argObjs; } @@ -1655,6 +1699,13 @@ Tcl_MethodIsPublic( { return (((Method *)method)->flags & PUBLIC_METHOD) ? 1 : 0; } + +int +Tcl_MethodIsPrivate( + Tcl_Method method) +{ + return (((Method *)method)->flags & TRUE_PRIVATE_METHOD) ? 1 : 0; +} /* * Extended method construction for itcl-ng. diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h new file mode 100644 index 0000000..e63bd86 --- /dev/null +++ b/generic/tclOOScript.h @@ -0,0 +1,240 @@ +/* + * tclOOScript.h -- + * + * This file contains support scripts for TclOO. They are defined here so + * that the code can be definitely run even in safe interpreters; TclOO's + * core setup is safe. + * + * Copyright (c) 2012-2018 Donal K. Fellows + * Copyright (c) 2013 Andreas Kupries + * Copyright (c) 2017 Gerald Lester + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#ifndef TCL_OO_SCRIPT_H +#define TCL_OO_SCRIPT_H + +/* + * The scripted part of the definitions of TclOO. + * + * Compiled from generic/tclOOScript.tcl by tools/makeHeader.tcl, which + * contains the commented version of everything; *this* file is automatically + * generated. + */ + +static const char *tclOOSetupScript = +/* !BEGIN!: Do not edit below this line. */ +"::namespace eval ::oo {\n" +"\t::namespace path {}\n" +"\tnamespace eval Helpers {\n" +"\t\t::namespace path {}\n" +"\t\tproc callback {method args} {\n" +"\t\t\tlist [uplevel 1 {::namespace which my}] $method {*}$args\n" +"\t\t}\n" +"\t\tnamespace export callback\n" +"\t\tnamespace eval tmp {namespace import ::oo::Helpers::callback}\n" +"\t\tnamespace export -clear\n" +"\t\trename tmp::callback mymethod\n" +"\t\tnamespace delete tmp\n" +"\t\tproc classvariable {name args} {\n" +"\t\t\tset ns [info object namespace [uplevel 1 {self class}]]\n" +"\t\t\tforeach v [list $name {*}$args] {\n" +"\t\t\t\tif {[string match *(*) $v]} {\n" +"\t\t\t\t\tset reason \"can\'t create a scalar variable that looks like an array element\"\n" +"\t\t\t\t\treturn -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \\\n" +"\t\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n" +"\t\t\t\t}\n" +"\t\t\t\tif {[string match *::* $v]} {\n" +"\t\t\t\t\tset reason \"can\'t create a local variable with a namespace separator in it\"\n" +"\t\t\t\t\treturn -code error -errorcode {TCL UPVAR INVERTED} \\\n" +"\t\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n" +"\t\t\t\t}\n" +"\t\t\t\tlappend vs $v $v\n" +"\t\t\t}\n" +"\t\t\ttailcall namespace upvar $ns {*}$vs\n" +"\t\t}\n" +"\t\tproc link {args} {\n" +"\t\t\tset ns [uplevel 1 {::namespace current}]\n" +"\t\t\tforeach link $args {\n" +"\t\t\t\tif {[llength $link] == 2} {\n" +"\t\t\t\t\tlassign $link src dst\n" +"\t\t\t\t} elseif {[llength $link] == 1} {\n" +"\t\t\t\t\tlassign $link src\n" +"\t\t\t\t\tset dst $src\n" +"\t\t\t\t} else {\n" +"\t\t\t\t\treturn -code error -errorcode {TCLOO CMDLINK FORMAT} \\\n" +"\t\t\t\t\t\t\"bad link description; must only have one or two elements\"\n" +"\t\t\t\t}\n" +"\t\t\t\tif {![string match ::* $src]} {\n" +"\t\t\t\t\tset src [string cat $ns :: $src]\n" +"\t\t\t\t}\n" +"\t\t\t\tinterp alias {} $src {} ${ns}::my $dst\n" +"\t\t\t\ttrace add command ${ns}::my delete [list \\\n" +"\t\t\t\t\t::oo::UnlinkLinkedCommand $src]\n" +"\t\t\t}\n" +"\t\t\treturn\n" +"\t\t}\n" +"\t}\n" +"\tproc UnlinkLinkedCommand {cmd args} {\n" +"\t\tif {[namespace which $cmd] ne {}} {\n" +"\t\t\trename $cmd {}\n" +"\t\t}\n" +"\t}\n" +"\tproc DelegateName {class} {\n" +"\t\tstring cat [info object namespace $class] {:: oo ::delegate}\n" +"\t}\n" +"\tproc MixinClassDelegates {class} {\n" +"\t\tif {![info object isa class $class]} {\n" +"\t\t\treturn\n" +"\t\t}\n" +"\t\tset delegate [DelegateName $class]\n" +"\t\tif {![info object isa class $delegate]} {\n" +"\t\t\treturn\n" +"\t\t}\n" +"\t\tforeach c [info class superclass $class] {\n" +"\t\t\tset d [DelegateName $c]\n" +"\t\t\tif {![info object isa class $d]} {\n" +"\t\t\t\tcontinue\n" +"\t\t\t}\n" +"\t\t\tdefine $delegate superclass -append $d\n" +"\t\t}\n" +"\t\tobjdefine $class mixin -append $delegate\n" +"\t}\n" +"\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n" +"\t\tset originDelegate [DelegateName $originObject]\n" +"\t\tset targetDelegate [DelegateName $targetObject]\n" +"\t\tif {\n" +"\t\t\t[info object isa class $originDelegate]\n" +"\t\t\t&& ![info object isa class $targetDelegate]\n" +"\t\t} then {\n" +"\t\t\tcopy $originDelegate $targetDelegate\n" +"\t\t\tobjdefine $targetObject mixin -set \\\n" +"\t\t\t\t{*}[lmap c [info object mixin $targetObject] {\n" +"\t\t\t\t\tif {$c eq $originDelegate} {set targetDelegate} {set c}\n" +"\t\t\t\t}]\n" +"\t\t}\n" +"\t}\n" +"\tproc define::classmethod {name {args {}} {body {}}} {\n" +"\t\t::set argc [::llength [::info level 0]]\n" +"\t\t::if {$argc == 3} {\n" +"\t\t\t::return -code error -errorcode {TCL WRONGARGS} [::format \\\n" +"\t\t\t\t{wrong # args: should be \"%s name \?args body\?\"} \\\n" +"\t\t\t\t[::lindex [::info level 0] 0]]\n" +"\t\t}\n" +"\t\t::set cls [::uplevel 1 self]\n" +"\t\t::if {$argc == 4} {\n" +"\t\t\t::oo::define [::oo::DelegateName $cls] method $name $args $body\n" +"\t\t}\n" +"\t\t::tailcall forward $name myclass $name\n" +"\t}\n" +"\tproc define::initialise {body} {\n" +"\t\t::set clsns [::info object namespace [::uplevel 1 self]]\n" +"\t\t::tailcall apply [::list {} $body $clsns]\n" +"\t}\n" +"\tnamespace eval define {\n" +"\t\t::namespace export initialise\n" +"\t\t::namespace eval tmp {::namespace import ::oo::define::initialise}\n" +"\t\t::namespace export -clear\n" +"\t\t::rename tmp::initialise initialize\n" +"\t\t::namespace delete tmp\n" +"\t}\n" +"\tdefine Slot {\n" +"\t\tmethod Get {} {\n" +"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n" +"\t\t}\n" +"\t\tmethod Set list {\n" +"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n" +"\t\t}\n" +"\t\tmethod -set args {tailcall my Set $args}\n" +"\t\tmethod -append args {\n" +"\t\t\tset current [uplevel 1 [list [namespace which my] Get]]\n" +"\t\t\ttailcall my Set [list {*}$current {*}$args]\n" +"\t\t}\n" +"\t\tmethod -clear {} {tailcall my Set {}}\n" +"\t\tforward --default-operation my -append\n" +"\t\tmethod unknown {args} {\n" +"\t\t\tset def --default-operation\n" +"\t\t\tif {[llength $args] == 0} {\n" +"\t\t\t\ttailcall my $def\n" +"\t\t\t} elseif {![string match -* [lindex $args 0]]} {\n" +"\t\t\t\ttailcall my $def {*}$args\n" +"\t\t\t}\n" +"\t\t\tnext {*}$args\n" +"\t\t}\n" +"\t\texport -set -append -clear\n" +"\t\tunexport unknown destroy\n" +"\t}\n" +"\tobjdefine define::superclass forward --default-operation my -set\n" +"\tobjdefine define::mixin forward --default-operation my -set\n" +"\tobjdefine objdefine::mixin forward --default-operation my -set\n" +"\tdefine object method <cloned> {originObject} {\n" +"\t\tforeach p [info procs [info object namespace $originObject]::*] {\n" +"\t\t\tset args [info args $p]\n" +"\t\t\tset idx -1\n" +"\t\t\tforeach a $args {\n" +"\t\t\t\tif {[info default $p $a d]} {\n" +"\t\t\t\t\tlset args [incr idx] [list $a $d]\n" +"\t\t\t\t} else {\n" +"\t\t\t\t\tlset args [incr idx] [list $a]\n" +"\t\t\t\t}\n" +"\t\t\t}\n" +"\t\t\tset b [info body $p]\n" +"\t\t\tset p [namespace tail $p]\n" +"\t\t\tproc $p $args $b\n" +"\t\t}\n" +"\t\tforeach v [info vars [info object namespace $originObject]::*] {\n" +"\t\t\tupvar 0 $v vOrigin\n" +"\t\t\tnamespace upvar [namespace current] [namespace tail $v] vNew\n" +"\t\t\tif {[info exists vOrigin]} {\n" +"\t\t\t\tif {[array exists vOrigin]} {\n" +"\t\t\t\t\tarray set vNew [array get vOrigin]\n" +"\t\t\t\t} else {\n" +"\t\t\t\t\tset vNew $vOrigin\n" +"\t\t\t\t}\n" +"\t\t\t}\n" +"\t\t}\n" +"\t}\n" +"\tdefine class method <cloned> {originObject} {\n" +"\t\tnext $originObject\n" +"\t\t::oo::UpdateClassDelegatesAfterClone $originObject [self]\n" +"\t}\n" +"\tclass create singleton {\n" +"\t\tsuperclass class\n" +"\t\tvariable object\n" +"\t\tunexport create createWithNamespace\n" +"\t\tmethod new args {\n" +"\t\t\tif {![info exists object] || ![info object isa object $object]} {\n" +"\t\t\t\tset object [next {*}$args]\n" +"\t\t\t\t::oo::objdefine $object {\n" +"\t\t\t\t\tmethod destroy {} {\n" +"\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n" +"\t\t\t\t\t\t\t\"may not destroy a singleton object\"\n" +"\t\t\t\t\t}\n" +"\t\t\t\t\tmethod <cloned> {originObject} {\n" +"\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n" +"\t\t\t\t\t\t\t\"may not clone a singleton object\"\n" +"\t\t\t\t\t}\n" +"\t\t\t\t}\n" +"\t\t\t}\n" +"\t\t\treturn $object\n" +"\t\t}\n" +"\t}\n" +"\tclass create abstract {\n" +"\t\tsuperclass class\n" +"\t\tunexport create createWithNamespace new\n" +"\t}\n" +"}\n" +/* !END!: Do not edit above this line. */ +; + +#endif /* TCL_OO_SCRIPT_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclOOScript.tcl b/generic/tclOOScript.tcl new file mode 100644 index 0000000..d3706ce --- /dev/null +++ b/generic/tclOOScript.tcl @@ -0,0 +1,422 @@ +# tclOOScript.h -- +# +# This file contains support scripts for TclOO. They are defined here so +# that the code can be definitely run even in safe interpreters; TclOO's +# core setup is safe. +# +# Copyright (c) 2012-2018 Donal K. Fellows +# Copyright (c) 2013 Andreas Kupries +# Copyright (c) 2017 Gerald Lester +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +::namespace eval ::oo { + ::namespace path {} + + # + # Commands that are made available to objects by default. + # + namespace eval Helpers { + ::namespace path {} + + # ------------------------------------------------------------------ + # + # callback, mymethod -- + # + # Create a script prefix that calls a method on the current + # object. Same operation, two names. + # + # ------------------------------------------------------------------ + + proc callback {method args} { + list [uplevel 1 {::namespace which my}] $method {*}$args + } + + # Make the [callback] command appear as [mymethod] too. + namespace export callback + namespace eval tmp {namespace import ::oo::Helpers::callback} + namespace export -clear + rename tmp::callback mymethod + namespace delete tmp + + # ------------------------------------------------------------------ + # + # classvariable -- + # + # Link to a variable in the class of the current object. + # + # ------------------------------------------------------------------ + + proc classvariable {name args} { + # Get a reference to the class's namespace + set ns [info object namespace [uplevel 1 {self class}]] + # Double up the list of variable names + foreach v [list $name {*}$args] { + if {[string match *(*) $v]} { + set reason "can't create a scalar variable that looks like an array element" + return -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \ + [format {bad variable name "%s": %s} $v $reason] + } + if {[string match *::* $v]} { + set reason "can't create a local variable with a namespace separator in it" + return -code error -errorcode {TCL UPVAR INVERTED} \ + [format {bad variable name "%s": %s} $v $reason] + } + lappend vs $v $v + } + # Lastly, link the caller's local variables to the class's variables + tailcall namespace upvar $ns {*}$vs + } + + # ------------------------------------------------------------------ + # + # link -- + # + # Make a command that invokes a method on the current object. + # The name of the command and the name of the method match by + # default. + # + # ------------------------------------------------------------------ + + proc link {args} { + set ns [uplevel 1 {::namespace current}] + foreach link $args { + if {[llength $link] == 2} { + lassign $link src dst + } elseif {[llength $link] == 1} { + lassign $link src + set dst $src + } else { + return -code error -errorcode {TCLOO CMDLINK FORMAT} \ + "bad link description; must only have one or two elements" + } + if {![string match ::* $src]} { + set src [string cat $ns :: $src] + } + interp alias {} $src {} ${ns}::my $dst + trace add command ${ns}::my delete [list \ + ::oo::UnlinkLinkedCommand $src] + } + return + } + } + + # ---------------------------------------------------------------------- + # + # UnlinkLinkedCommand -- + # + # Callback used to remove linked command when the underlying mechanism + # that supports it is deleted. + # + # ---------------------------------------------------------------------- + + proc UnlinkLinkedCommand {cmd args} { + if {[namespace which $cmd] ne {}} { + rename $cmd {} + } + } + + # ---------------------------------------------------------------------- + # + # DelegateName -- + # + # Utility that gets the name of the class delegate for a class. It's + # trivial, but makes working with them much easier as delegate names are + # intentionally hard to create by accident. + # + # ---------------------------------------------------------------------- + + proc DelegateName {class} { + string cat [info object namespace $class] {:: oo ::delegate} + } + + # ---------------------------------------------------------------------- + # + # MixinClassDelegates -- + # + # Support code called *after* [oo::define] inside the constructor of a + # class that patches in the appropriate class delegates. + # + # ---------------------------------------------------------------------- + + proc MixinClassDelegates {class} { + if {![info object isa class $class]} { + return + } + set delegate [DelegateName $class] + if {![info object isa class $delegate]} { + return + } + foreach c [info class superclass $class] { + set d [DelegateName $c] + if {![info object isa class $d]} { + continue + } + define $delegate superclass -append $d + } + objdefine $class mixin -append $delegate + } + + # ---------------------------------------------------------------------- + # + # UpdateClassDelegatesAfterClone -- + # + # Support code that is like [MixinClassDelegates] except for when a + # class is cloned. + # + # ---------------------------------------------------------------------- + + proc UpdateClassDelegatesAfterClone {originObject targetObject} { + # Rebuild the class inheritance delegation class + set originDelegate [DelegateName $originObject] + set targetDelegate [DelegateName $targetObject] + if { + [info object isa class $originDelegate] + && ![info object isa class $targetDelegate] + } then { + copy $originDelegate $targetDelegate + objdefine $targetObject mixin -set \ + {*}[lmap c [info object mixin $targetObject] { + if {$c eq $originDelegate} {set targetDelegate} {set c} + }] + } + } + + # ---------------------------------------------------------------------- + # + # oo::define::classmethod -- + # + # Defines a class method. See define(n) for details. + # + # Note that the ::oo::define namespace is semi-public and a bit weird + # anyway, so we don't regard the namespace path as being under control: + # fully qualified names are used for everything. + # + # ---------------------------------------------------------------------- + + proc define::classmethod {name {args {}} {body {}}} { + # Create the method on the class if the caller gave arguments and body + ::set argc [::llength [::info level 0]] + ::if {$argc == 3} { + ::return -code error -errorcode {TCL WRONGARGS} [::format \ + {wrong # args: should be "%s name ?args body?"} \ + [::lindex [::info level 0] 0]] + } + ::set cls [::uplevel 1 self] + ::if {$argc == 4} { + ::oo::define [::oo::DelegateName $cls] method $name $args $body + } + # Make the connection by forwarding + ::tailcall forward $name myclass $name + } + + # ---------------------------------------------------------------------- + # + # oo::define::initialise, oo::define::initialize -- + # + # Do specific initialisation for a class. See define(n) for details. + # + # Note that the ::oo::define namespace is semi-public and a bit weird + # anyway, so we don't regard the namespace path as being under control: + # fully qualified names are used for everything. + # + # ---------------------------------------------------------------------- + + proc define::initialise {body} { + ::set clsns [::info object namespace [::uplevel 1 self]] + ::tailcall apply [::list {} $body $clsns] + } + + # Make the [initialise] definition appear as [initialize] too + namespace eval define { + ::namespace export initialise + ::namespace eval tmp {::namespace import ::oo::define::initialise} + ::namespace export -clear + ::rename tmp::initialise initialize + ::namespace delete tmp + } + + # ---------------------------------------------------------------------- + # + # Slot -- + # + # The class of slot operations, which are basically lists at the low + # level of TclOO; this provides a more consistent interface to them. + # + # ---------------------------------------------------------------------- + + define Slot { + # ------------------------------------------------------------------ + # + # Slot Get -- + # + # Basic slot getter. Retrieves the contents of the slot. + # Particular slots must provide concrete non-erroring + # implementation. + # + # ------------------------------------------------------------------ + + method Get {} { + return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented" + } + + # ------------------------------------------------------------------ + # + # Slot Set -- + # + # Basic slot setter. Sets the contents of the slot. Particular + # slots must provide concrete non-erroring implementation. + # + # ------------------------------------------------------------------ + + method Set list { + return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented" + } + + # ------------------------------------------------------------------ + # + # Slot -set, -append, -clear, --default-operation -- + # + # Standard public slot operations. If a slot can't figure out + # what method to call directly, it uses --default-operation. + # + # ------------------------------------------------------------------ + + method -set args {tailcall my Set $args} + method -append args { + set current [uplevel 1 [list [namespace which my] Get]] + tailcall my Set [list {*}$current {*}$args] + } + method -clear {} {tailcall my Set {}} + + # Default handling + forward --default-operation my -append + method unknown {args} { + set def --default-operation + if {[llength $args] == 0} { + tailcall my $def + } elseif {![string match -* [lindex $args 0]]} { + tailcall my $def {*}$args + } + next {*}$args + } + + # Set up what is exported and what isn't + export -set -append -clear + unexport unknown destroy + } + + # Set the default operation differently for these slots + objdefine define::superclass forward --default-operation my -set + objdefine define::mixin forward --default-operation my -set + objdefine objdefine::mixin forward --default-operation my -set + + # ---------------------------------------------------------------------- + # + # oo::object <cloned> -- + # + # Handler for cloning objects that clones basic bits (only!) of the + # object's namespace. Non-procedures, traces, sub-namespaces, etc. need + # more complex (and class-specific) handling. + # + # ---------------------------------------------------------------------- + + define object method <cloned> {originObject} { + # Copy over the procedures from the original namespace + foreach p [info procs [info object namespace $originObject]::*] { + set args [info args $p] + set idx -1 + foreach a $args { + if {[info default $p $a d]} { + lset args [incr idx] [list $a $d] + } else { + lset args [incr idx] [list $a] + } + } + set b [info body $p] + set p [namespace tail $p] + proc $p $args $b + } + # Copy over the variables from the original namespace + foreach v [info vars [info object namespace $originObject]::*] { + upvar 0 $v vOrigin + namespace upvar [namespace current] [namespace tail $v] vNew + if {[info exists vOrigin]} { + if {[array exists vOrigin]} { + array set vNew [array get vOrigin] + } else { + set vNew $vOrigin + } + } + } + # General commands, sub-namespaces and advancd variable config (traces, + # etc) are *not* copied over. Classes that want that should do it + # themselves. + } + + # ---------------------------------------------------------------------- + # + # oo::class <cloned> -- + # + # Handler for cloning classes, which fixes up the delegates. + # + # ---------------------------------------------------------------------- + + define class method <cloned> {originObject} { + next $originObject + # Rebuild the class inheritance delegation class + ::oo::UpdateClassDelegatesAfterClone $originObject [self] + } + + # ---------------------------------------------------------------------- + # + # oo::singleton -- + # + # A metaclass that is used to make classes that only permit one instance + # of them to exist. See singleton(n). + # + # ---------------------------------------------------------------------- + + class create singleton { + superclass class + variable object + unexport create createWithNamespace + method new args { + if {![info exists object] || ![info object isa object $object]} { + set object [next {*}$args] + ::oo::objdefine $object { + method destroy {} { + ::return -code error -errorcode {TCLOO SINGLETON} \ + "may not destroy a singleton object" + } + method <cloned> {originObject} { + ::return -code error -errorcode {TCLOO SINGLETON} \ + "may not clone a singleton object" + } + } + } + return $object + } + } + + # ---------------------------------------------------------------------- + # + # oo::abstract -- + # + # A metaclass that is used to make classes that can't be directly + # instantiated. See abstract(n). + # + # ---------------------------------------------------------------------- + + class create abstract { + superclass class + unexport create createWithNamespace new + } +} + +# Local Variables: +# mode: tcl +# c-basic-offset: 4 +# fill-column: 78 +# End: diff --git a/generic/tclOOStubInit.c b/generic/tclOOStubInit.c index 900ab22..5e235f4 100644 --- a/generic/tclOOStubInit.c +++ b/generic/tclOOStubInit.c @@ -73,6 +73,7 @@ const TclOOStubs tclOOStubs = { Tcl_ClassSetConstructor, /* 26 */ Tcl_ClassSetDestructor, /* 27 */ Tcl_GetObjectName, /* 28 */ + Tcl_MethodIsPrivate, /* 29 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclOOStubLib.c b/generic/tclOOStubLib.c index 921aced..a9fa212 100644 --- a/generic/tclOOStubLib.c +++ b/generic/tclOOStubLib.c @@ -27,6 +27,8 @@ const TclOOIntStubs *tclOOIntStubsPtr = NULL; *---------------------------------------------------------------------- */ +#undef TclOOInitializeStubs + MODULE_SCOPE const char * TclOOInitializeStubs( Tcl_Interp *interp, diff --git a/generic/tclObj.c b/generic/tclObj.c index 930e1fd..16ef7c3 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -37,7 +37,7 @@ Tcl_Obj *tclFreeObjList = NULL; * TclNewObj macro, however, so must be visible. */ -#ifdef TCL_THREADS +#if TCL_THREADS MODULE_SCOPE Tcl_Mutex tclObjMutex; Tcl_Mutex tclObjMutex; #endif @@ -49,9 +49,8 @@ Tcl_Mutex tclObjMutex; */ char tclEmptyString = '\0'; -char *tclEmptyStringRep = &tclEmptyString; -#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) +#if TCL_THREADS && defined(TCL_MEM_DEBUG) /* * Structure for tracking the source file and line number where a given * Tcl_Obj was allocated. We also track the pointer to the Tcl_Obj itself, @@ -76,7 +75,7 @@ typedef struct ObjData { * The structure defined below is used in this file only. */ -typedef struct ThreadSpecificData { +typedef struct { Tcl_HashTable *lineCLPtr; /* This table remembers for each Tcl_Obj * generated by a call to the function * TclSubstTokens() from a literal text @@ -88,7 +87,7 @@ typedef struct ThreadSpecificData { * tclCompile.h for the definition of this * structure, and for references to all * related places in the core. */ -#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) +#if TCL_THREADS && defined(TCL_MEM_DEBUG) Tcl_HashTable *objThreadMap;/* Thread local table that is used to check * that a Tcl_Obj was not allocated by some * other thread. */ @@ -157,7 +156,7 @@ typedef struct PendingObjData { /* * Macro to set up the local reference to the deletion context. */ -#ifndef TCL_THREADS +#if !TCL_THREADS static PendingObjData pendingObjData; #define ObjInitDeletionContext(contextPtr) \ PendingObjData *const contextPtr = &pendingObjData @@ -180,26 +179,26 @@ static Tcl_ThreadDataKey pendingObjDataKey; if ((bignum).used > 0x7fff) { \ mp_int *temp = (void *) ckalloc((unsigned) sizeof(mp_int)); \ *temp = bignum; \ - (objPtr)->internalRep.ptrAndLongRep.ptr = temp; \ - (objPtr)->internalRep.ptrAndLongRep.value = (unsigned long)(-1); \ + (objPtr)->internalRep.twoPtrValue.ptr1 = temp; \ + (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(-1); \ } else { \ if ((bignum).alloc > 0x7fff) { \ mp_shrink(&(bignum)); \ } \ - (objPtr)->internalRep.ptrAndLongRep.ptr = (void *) (bignum).dp; \ - (objPtr)->internalRep.ptrAndLongRep.value = ( ((bignum).sign << 30) \ + (objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (bignum).dp; \ + (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR( ((bignum).sign << 30) \ | ((bignum).alloc << 15) | ((bignum).used)); \ } #define UNPACK_BIGNUM(objPtr, bignum) \ - if ((objPtr)->internalRep.ptrAndLongRep.value == (unsigned long)(-1)) { \ - (bignum) = *((mp_int *) ((objPtr)->internalRep.ptrAndLongRep.ptr)); \ + if ((objPtr)->internalRep.twoPtrValue.ptr2 == INT2PTR(-1)) { \ + (bignum) = *((mp_int *) ((objPtr)->internalRep.twoPtrValue.ptr1)); \ } else { \ - (bignum).dp = (objPtr)->internalRep.ptrAndLongRep.ptr; \ - (bignum).sign = (objPtr)->internalRep.ptrAndLongRep.value >> 30; \ + (bignum).dp = (objPtr)->internalRep.twoPtrValue.ptr1; \ + (bignum).sign = PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) >> 30; \ (bignum).alloc = \ - ((objPtr)->internalRep.ptrAndLongRep.value >> 15) & 0x7fff; \ - (bignum).used = (objPtr)->internalRep.ptrAndLongRep.value & 0x7fff; \ + (PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) >> 15) & 0x7fff; \ + (bignum).used = PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) & 0x7fff; \ } /* @@ -211,9 +210,8 @@ static int SetDoubleFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static int SetIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfDouble(Tcl_Obj *objPtr); static void UpdateStringOfInt(Tcl_Obj *objPtr); -#ifndef TCL_WIDE_INT_IS_LONG -static void UpdateStringOfWideInt(Tcl_Obj *objPtr); -static int SetWideIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG) +static void UpdateStringOfOldInt(Tcl_Obj *objPtr); #endif static void FreeBignum(Tcl_Obj *objPtr); static void DupBignum(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); @@ -243,6 +241,7 @@ static int SetCmdNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); * implementations. */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 static const Tcl_ObjType oldBooleanType = { "boolean", /* name */ NULL, /* freeIntRepProc */ @@ -250,6 +249,7 @@ static const Tcl_ObjType oldBooleanType = { NULL, /* updateStringProc */ TclSetBooleanFromAny /* setFromAnyProc */ }; +#endif const Tcl_ObjType tclBooleanType = { "booleanString", /* name */ NULL, /* freeIntRepProc */ @@ -265,19 +265,23 @@ const Tcl_ObjType tclDoubleType = { SetDoubleFromAny /* setFromAnyProc */ }; const Tcl_ObjType tclIntType = { +#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 || defined(TCL_WIDE_INT_IS_LONG) "int", /* name */ +#else + "wideInt", /* name, keeping maximum compatibility with Tcl 8.6 on 32-bit platforms*/ +#endif NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ UpdateStringOfInt, /* updateStringProc */ SetIntFromAny /* setFromAnyProc */ }; -#ifndef TCL_WIDE_INT_IS_LONG -const Tcl_ObjType tclWideIntType = { - "wideInt", /* name */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG) +static const Tcl_ObjType oldIntType = { + "int", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ - UpdateStringOfWideInt, /* updateStringProc */ - SetWideIntFromAny /* setFromAnyProc */ + UpdateStringOfOldInt, /* updateStringProc */ + SetIntFromAny /* setFromAnyProc */ }; #endif const Tcl_ObjType tclBignumType = { @@ -320,7 +324,7 @@ const Tcl_HashKeyType tclObjHashKeyType = { * does allow them to delete a command when references to it are gone, which * is fragile but useful given their somewhat-OO style. Because of this, this * structure MUST NOT be const so that the C compiler puts the data in - * writable memory. [Bug 2558422] + * writable memory. [Bug 2558422] [Bug 07d13d99b0a9] * TODO: Provide a better API for those extensions so that they can coexist... */ @@ -345,23 +349,23 @@ typedef struct ResolvedCmdName { * reference (not the namespace that contains * the referenced command). NULL if the name * is fully qualified.*/ - long refNsId; /* refNsPtr's unique namespace id. Used to + unsigned long refNsId; /* refNsPtr's unique namespace id. Used to * verify that refNsPtr is still valid (e.g., * it's possible that the cmd's containing * namespace was deleted and a new one created * at the same address). */ - int refNsCmdEpoch; /* Value of the referencing namespace's + unsigned 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 + unsigned 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 + size_t refCount; /* Reference count: 1 for each cmdName object * that has a pointer to this ResolvedCmdName * structure as its internal rep. This * structure can be freed when refCount @@ -396,21 +400,21 @@ TclInitObjSubsystem(void) Tcl_RegisterObjType(&tclByteArrayType); Tcl_RegisterObjType(&tclDoubleType); - Tcl_RegisterObjType(&tclEndOffsetType); - Tcl_RegisterObjType(&tclIntType); Tcl_RegisterObjType(&tclStringType); Tcl_RegisterObjType(&tclListType); Tcl_RegisterObjType(&tclDictType); Tcl_RegisterObjType(&tclByteCodeType); - Tcl_RegisterObjType(&tclArraySearchType); Tcl_RegisterObjType(&tclCmdNameType); Tcl_RegisterObjType(&tclRegexpType); Tcl_RegisterObjType(&tclProcBodyType); /* For backward compatibility only ... */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 + Tcl_RegisterObjType(&tclIntType); +#if !defined(TCL_WIDE_INT_IS_LONG) + Tcl_RegisterObjType(&oldIntType); +#endif Tcl_RegisterObjType(&oldBooleanType); -#ifndef TCL_WIDE_INT_IS_LONG - Tcl_RegisterObjType(&tclWideIntType); #endif #ifdef TCL_COMPILE_STATS @@ -448,7 +452,7 @@ TclInitObjSubsystem(void) void TclFinalizeThreadObjects(void) { -#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) +#if TCL_THREADS && defined(TCL_MEM_DEBUG) Tcl_HashEntry *hPtr; Tcl_HashSearch hSearch; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -663,7 +667,7 @@ TclContinuationsEnterDerived( * better way which doesn't shimmer?) */ - Tcl_GetStringFromObj(objPtr, &length); + TclGetStringFromObj(objPtr, &length); end = start + length; /* First char after the word */ /* @@ -1005,7 +1009,7 @@ void TclDbDumpActiveObjects( FILE *outFile) { -#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) +#if TCL_THREADS && defined(TCL_MEM_DEBUG) Tcl_HashSearch hSearch; Tcl_HashEntry *hPtr; Tcl_HashTable *tablePtr; @@ -1061,11 +1065,11 @@ TclDbInitNewObj( * debugging. */ { objPtr->refCount = 0; - objPtr->bytes = tclEmptyStringRep; + objPtr->bytes = &tclEmptyString; objPtr->length = 0; objPtr->typePtr = NULL; -#ifdef TCL_THREADS +#if TCL_THREADS /* * Add entry to a thread local map used to check if a Tcl_Obj was * allocated by the currently executing thread. @@ -1301,6 +1305,39 @@ TclFreeObj( ObjInitDeletionContext(context); +#if TCL_THREADS + /* + * Check to make sure that the Tcl_Obj was allocated by the current + * thread. Don't do this check when shutting down since thread local + * storage can be finalized before the last Tcl_Obj is freed. + */ + + if (!TclInExit()) { + Tcl_HashTable *tablePtr; + Tcl_HashEntry *hPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + tablePtr = tsdPtr->objThreadMap; + if (!tablePtr) { + Tcl_Panic("TclFreeObj: object table not initialized"); + } + hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr); + if (hPtr) { + /* + * As the Tcl_Obj is going to be deleted we remove the entry. + */ + + ObjData *objData = Tcl_GetHashValue(hPtr); + + if (objData != NULL) { + ckfree(objData); + } + + Tcl_DeleteHashEntry(hPtr); + } + } +# endif + /* * Check for a double free of the same value. This is slightly tricky * because it is customary to free a Tcl_Obj when its refcount falls @@ -1595,32 +1632,30 @@ Tcl_GetString( register Tcl_Obj *objPtr) /* Object whose string rep byte pointer should * be returned. */ { - if (objPtr->bytes != NULL) { - return objPtr->bytes; - } - - /* - * Note we do not check for objPtr->typePtr == NULL. An invariant of - * a properly maintained Tcl_Obj is that at least one of objPtr->bytes - * and objPtr->typePtr must not be NULL. If broken extensions fail to - * maintain that invariant, we can crash here. - */ - - if (objPtr->typePtr->updateStringProc == NULL) { + if (objPtr->bytes == NULL) { /* - * Those Tcl_ObjTypes which choose not to define an updateStringProc - * must be written in such a way that (objPtr->bytes) never becomes - * NULL. This panic was added in Tcl 8.1. + * Note we do not check for objPtr->typePtr == NULL. An invariant + * of a properly maintained Tcl_Obj is that at least one of + * objPtr->bytes and objPtr->typePtr must not be NULL. If broken + * extensions fail to maintain that invariant, we can crash here. */ - Tcl_Panic("UpdateStringProc should not be invoked for type %s", - objPtr->typePtr->name); - } - objPtr->typePtr->updateStringProc(objPtr); - if (objPtr->bytes == NULL || objPtr->length < 0 - || objPtr->bytes[objPtr->length] != '\0') { - Tcl_Panic("UpdateStringProc for type '%s' " - "failed to create a valid string rep", objPtr->typePtr->name); + if (objPtr->typePtr->updateStringProc == NULL) { + /* + * Those Tcl_ObjTypes which choose not to define an + * updateStringProc must be written in such a way that + * (objPtr->bytes) never becomes NULL. + */ + Tcl_Panic("UpdateStringProc should not be invoked for type %s", + objPtr->typePtr->name); + } + objPtr->typePtr->updateStringProc(objPtr); + if (objPtr->bytes == NULL || objPtr->length < 0 + || objPtr->bytes[objPtr->length] != '\0') { + Tcl_Panic("UpdateStringProc for type '%s' " + "failed to create a valid string rep", + objPtr->typePtr->name); + } } return objPtr->bytes; } @@ -1656,8 +1691,31 @@ Tcl_GetStringFromObj( * rep's byte array length should * be stored. * If NULL, no length is stored. */ { - (void) TclGetString(objPtr); + if (objPtr->bytes == NULL) { + /* + * Note we do not check for objPtr->typePtr == NULL. An invariant + * of a properly maintained Tcl_Obj is that at least one of + * objPtr->bytes and objPtr->typePtr must not be NULL. If broken + * extensions fail to maintain that invariant, we can crash here. + */ + if (objPtr->typePtr->updateStringProc == NULL) { + /* + * Those Tcl_ObjTypes which choose not to define an + * updateStringProc must be written in such a way that + * (objPtr->bytes) never becomes NULL. + */ + Tcl_Panic("UpdateStringProc should not be invoked for type %s", + objPtr->typePtr->name); + } + objPtr->typePtr->updateStringProc(objPtr); + if (objPtr->bytes == NULL || objPtr->length < 0 + || objPtr->bytes[objPtr->length] != '\0') { + Tcl_Panic("UpdateStringProc for type '%s' " + "failed to create a valid string rep", + objPtr->typePtr->name); + } + } if (lengthPtr != NULL) { *lengthPtr = objPtr->length; } @@ -1701,7 +1759,7 @@ Tcl_InvalidateStringRep( * is coerced to 1. * * When TCL_MEM_DEBUG is defined, this function just returns the result - * of calling the debugging version Tcl_DbNewBooleanObj. + * of calling the debugging version Tcl_DbNewLongObj. * * Results: * The newly created object is returned. This object will have an invalid @@ -1720,7 +1778,7 @@ Tcl_Obj * Tcl_NewBooleanObj( register int boolValue) /* Boolean used to initialize new object. */ { - return Tcl_DbNewBooleanObj(boolValue, "unknown", 0); + return Tcl_DbNewLongObj(boolValue!=0, "unknown", 0); } #else /* if not TCL_MEM_DEBUG */ @@ -1731,7 +1789,7 @@ Tcl_NewBooleanObj( { register Tcl_Obj *objPtr; - TclNewBooleanObj(objPtr, boolValue); + TclNewIntObj(objPtr, boolValue!=0); return objPtr; } #endif /* TCL_MEM_DEBUG */ @@ -1762,6 +1820,7 @@ Tcl_NewBooleanObj( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_DbNewBooleanObj #ifdef TCL_MEM_DEBUG @@ -1778,7 +1837,7 @@ Tcl_DbNewBooleanObj( TclDbNewObj(objPtr, file, line); objPtr->bytes = NULL; - objPtr->internalRep.longValue = (boolValue? 1 : 0); + objPtr->internalRep.wideValue = (boolValue != 0); objPtr->typePtr = &tclIntType; return objPtr; } @@ -1825,8 +1884,9 @@ Tcl_SetBooleanObj( Tcl_Panic("%s called with shared object", "Tcl_SetBooleanObj"); } - TclSetBooleanObj(objPtr, boolValue); + TclSetIntObj(objPtr, boolValue!=0); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -1855,11 +1915,11 @@ Tcl_GetBooleanFromObj( { do { if (objPtr->typePtr == &tclIntType) { - *boolPtr = (objPtr->internalRep.longValue != 0); + *boolPtr = (objPtr->internalRep.wideValue != 0); return TCL_OK; } if (objPtr->typePtr == &tclBooleanType) { - *boolPtr = (int) objPtr->internalRep.longValue; + *boolPtr = objPtr->internalRep.longValue != 0; return TCL_OK; } if (objPtr->typePtr == &tclDoubleType) { @@ -1883,12 +1943,6 @@ Tcl_GetBooleanFromObj( *boolPtr = 1; return TCL_OK; } -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { - *boolPtr = (objPtr->internalRep.wideValue != 0); - return TCL_OK; - } -#endif } while ((ParseBoolean(objPtr) == TCL_OK) || (TCL_OK == TclParseNumber(interp, objPtr, "boolean value", NULL,-1,NULL,0))); return TCL_ERROR; @@ -1909,7 +1963,12 @@ Tcl_GetBooleanFromObj( * * Side effects: * If no error occurs, an integer 1 or 0 is stored as "objPtr"s internal - * representation and the type of "objPtr" is set to boolean. + * representation and the type of "objPtr" is set to boolean or int/wideInt. + * + * Warning: If the returned type is "wideInt" (32-bit platforms) and your + * platform is bigendian, you cannot use internalRep.longValue to distinguish + * between false and true. On Windows and most other platforms this still will + * work fine, but basically it is non-portable. * *---------------------------------------------------------------------- */ @@ -1927,8 +1986,7 @@ TclSetBooleanFromAny( if (objPtr->bytes == NULL) { if (objPtr->typePtr == &tclIntType) { - switch (objPtr->internalRep.longValue) { - case 0L: case 1L: + if ((Tcl_WideUInt)objPtr->internalRep.wideValue < 2) { return TCL_OK; } goto badBoolean; @@ -1938,12 +1996,6 @@ TclSetBooleanFromAny( goto badBoolean; } -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { - goto badBoolean; - } -#endif - if (objPtr->typePtr == &tclDoubleType) { goto badBoolean; } @@ -1956,7 +2008,7 @@ TclSetBooleanFromAny( badBoolean: if (interp != NULL) { int length; - const char *str = Tcl_GetStringFromObj(objPtr, &length); + const char *str = TclGetStringFromObj(objPtr, &length); Tcl_Obj *msg; TclNewLiteralStringObj(msg, "expected boolean value but got \""); @@ -1972,9 +2024,10 @@ static int ParseBoolean( register Tcl_Obj *objPtr) /* The object to parse/convert. */ { - int i, length, newBool; + int newBool; char lowerCase[6]; - const char *str = TclGetStringFromObj(objPtr, &length); + const char *str = TclGetString(objPtr); + size_t i, length = objPtr->length; if ((length == 0) || (length > 5)) { /* @@ -2026,25 +2079,25 @@ ParseBoolean( /* * Checking the 'y' is redundant, but makes the code clearer. */ - if (strncmp(lowerCase, "yes", (size_t) length) == 0) { + if (strncmp(lowerCase, "yes", length) == 0) { newBool = 1; goto goodBoolean; } return TCL_ERROR; case 'n': - if (strncmp(lowerCase, "no", (size_t) length) == 0) { + if (strncmp(lowerCase, "no", length) == 0) { newBool = 0; goto goodBoolean; } return TCL_ERROR; case 't': - if (strncmp(lowerCase, "true", (size_t) length) == 0) { + if (strncmp(lowerCase, "true", length) == 0) { newBool = 1; goto goodBoolean; } return TCL_ERROR; case 'f': - if (strncmp(lowerCase, "false", (size_t) length) == 0) { + if (strncmp(lowerCase, "false", length) == 0) { newBool = 0; goto goodBoolean; } @@ -2053,10 +2106,10 @@ ParseBoolean( if (length < 2) { return TCL_ERROR; } - if (strncmp(lowerCase, "on", (size_t) length) == 0) { + if (strncmp(lowerCase, "on", length) == 0) { newBool = 1; goto goodBoolean; - } else if (strncmp(lowerCase, "off", (size_t) length) == 0) { + } else if (strncmp(lowerCase, "off", length) == 0) { newBool = 0; goto goodBoolean; } @@ -2079,7 +2132,7 @@ ParseBoolean( numericBoolean: TclFreeIntRep(objPtr); - objPtr->internalRep.longValue = newBool; + objPtr->internalRep.wideValue = newBool; objPtr->typePtr = &tclIntType; return TCL_OK; } @@ -2260,7 +2313,7 @@ Tcl_GetDoubleFromObj( return TCL_OK; } if (objPtr->typePtr == &tclIntType) { - *dblPtr = objPtr->internalRep.longValue; + *dblPtr = (double) objPtr->internalRep.wideValue; return TCL_OK; } if (objPtr->typePtr == &tclBignumType) { @@ -2270,12 +2323,6 @@ Tcl_GetDoubleFromObj( *dblPtr = TclBignumToDouble(&big); return TCL_OK; } -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { - *dblPtr = (double) objPtr->internalRep.wideValue; - return TCL_OK; - } -#endif } while (SetDoubleFromAny(interp, objPtr) == TCL_OK); return TCL_ERROR; } @@ -2504,9 +2551,8 @@ SetIntFromAny( Tcl_Interp *interp, /* Tcl interpreter */ Tcl_Obj *objPtr) /* Pointer to the object to convert */ { - long l; - - return TclGetLongFromObj(interp, objPtr, &l); + Tcl_WideInt w; + return Tcl_GetWideIntFromObj(interp, objPtr, &w); } /* @@ -2535,12 +2581,28 @@ UpdateStringOfInt( char buffer[TCL_INTEGER_SPACE]; register int len; + len = TclFormatInt(buffer, objPtr->internalRep.wideValue); + + objPtr->bytes = ckalloc(len + 1); + memcpy(objPtr->bytes, buffer, (unsigned) len + 1); + objPtr->length = len; +} + +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG) +static void +UpdateStringOfOldInt( + register Tcl_Obj *objPtr) /* Int object whose string rep to update. */ +{ + char buffer[TCL_INTEGER_SPACE]; + register int len; + len = TclFormatInt(buffer, objPtr->internalRep.longValue); objPtr->bytes = ckalloc(len + 1); memcpy(objPtr->bytes, buffer, (unsigned) len + 1); objPtr->length = len; } +#endif /* *---------------------------------------------------------------------- @@ -2572,8 +2634,8 @@ UpdateStringOfInt( *---------------------------------------------------------------------- */ -#ifdef TCL_MEM_DEBUG #undef Tcl_NewLongObj +#ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_NewLongObj( @@ -2592,7 +2654,7 @@ Tcl_NewLongObj( { register Tcl_Obj *objPtr; - TclNewLongObj(objPtr, longValue); + TclNewIntObj(objPtr, longValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ @@ -2629,6 +2691,7 @@ Tcl_NewLongObj( *---------------------------------------------------------------------- */ +#undef Tcl_DbNewLongObj #ifdef TCL_MEM_DEBUG Tcl_Obj * @@ -2645,7 +2708,7 @@ Tcl_DbNewLongObj( TclDbNewObj(objPtr, file, line); objPtr->bytes = NULL; - objPtr->internalRep.longValue = longValue; + objPtr->internalRep.wideValue = longValue; objPtr->typePtr = &tclIntType; return objPtr; } @@ -2683,6 +2746,7 @@ Tcl_DbNewLongObj( *---------------------------------------------------------------------- */ +#undef Tcl_SetLongObj void Tcl_SetLongObj( register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ @@ -2693,7 +2757,7 @@ Tcl_SetLongObj( Tcl_Panic("%s called with shared object", "Tcl_SetLongObj"); } - TclSetLongObj(objPtr, longValue); + TclSetIntObj(objPtr, longValue); } /* @@ -2724,12 +2788,13 @@ Tcl_GetLongFromObj( register long *longPtr) /* Place to store resulting long. */ { do { +#ifdef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclIntType) { - *longPtr = objPtr->internalRep.longValue; + *longPtr = objPtr->internalRep.wideValue; return TCL_OK; } -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { +#else + if (objPtr->typePtr == &tclIntType) { /* * We return any integer in the range -ULONG_MAX to ULONG_MAX * converted to a long, ignoring overflow. The rule preserves @@ -2752,7 +2817,7 @@ Tcl_GetLongFromObj( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected integer but got \"%s\"", - Tcl_GetString(objPtr))); + TclGetString(objPtr))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL); } return TCL_ERROR; @@ -2802,49 +2867,6 @@ Tcl_GetLongFromObj( TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } -#ifndef TCL_WIDE_INT_IS_LONG - -/* - *---------------------------------------------------------------------- - * - * UpdateStringOfWideInt -- - * - * Update the string representation for a wide integer object. Note: this - * function does not free an existing old string rep so storage will be - * lost if this has not already been done. - * - * Results: - * None. - * - * Side effects: - * The object's string is set to a valid string that results from the - * wideInt-to-string conversion. - * - *---------------------------------------------------------------------- - */ - -static void -UpdateStringOfWideInt( - 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; - - /* - * Note that sprintf will generate a compiler warning under Mingw claiming - * %I64 is an unknown format specifier. Just ignore this warning. We can't - * use %L as the format specifier since that gets printed as a 32 bit - * value. - */ - - sprintf(buffer, "%" TCL_LL_MODIFIER "d", wideVal); - len = strlen(buffer); - objPtr->bytes = ckalloc(len + 1); - memcpy(objPtr->bytes, buffer, len + 1); - objPtr->length = len; -} -#endif /* !TCL_WIDE_INT_IS_LONG */ /* *---------------------------------------------------------------------- @@ -2894,7 +2916,7 @@ Tcl_NewWideIntObj( register Tcl_Obj *objPtr; TclNewObj(objPtr); - Tcl_SetWideIntObj(objPtr, wideValue); + TclSetIntObj(objPtr, wideValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ @@ -2946,7 +2968,7 @@ Tcl_DbNewWideIntObj( register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); - Tcl_SetWideIntObj(objPtr, wideValue); + TclSetIntObj(objPtr, wideValue); return objPtr; } @@ -2995,19 +3017,7 @@ Tcl_SetWideIntObj( Tcl_Panic("%s called with shared object", "Tcl_SetWideIntObj"); } - if ((wideValue >= (Tcl_WideInt) LONG_MIN) - && (wideValue <= (Tcl_WideInt) LONG_MAX)) { - TclSetLongObj(objPtr, (long) wideValue); - } else { -#ifndef TCL_WIDE_INT_IS_LONG - TclSetWideIntObj(objPtr, wideValue); -#else - mp_int big; - - TclBNInitBignumFromWideInt(&big, wideValue); - Tcl_SetBignumObj(objPtr, &big); -#endif - } + TclSetIntObj(objPtr, wideValue); } /* @@ -3039,21 +3049,15 @@ Tcl_GetWideIntFromObj( /* Place to store resulting long. */ { do { -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { - *wideIntPtr = objPtr->internalRep.wideValue; - return TCL_OK; - } -#endif if (objPtr->typePtr == &tclIntType) { - *wideIntPtr = (Tcl_WideInt) objPtr->internalRep.longValue; + *wideIntPtr = objPtr->internalRep.wideValue; return TCL_OK; } if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected integer but got \"%s\"", - Tcl_GetString(objPtr))); + TclGetString(objPtr))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL); } return TCL_ERROR; @@ -3099,33 +3103,6 @@ Tcl_GetWideIntFromObj( TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } -#ifndef TCL_WIDE_INT_IS_LONG - -/* - *---------------------------------------------------------------------- - * - * SetWideIntFromAny -- - * - * Attempts to force the internal representation for a Tcl object to - * tclWideIntType, specifically. - * - * 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. - * - *---------------------------------------------------------------------- - */ - -static int -SetWideIntFromAny( - Tcl_Interp *interp, /* Tcl interpreter */ - Tcl_Obj *objPtr) /* Pointer to the object to convert */ -{ - Tcl_WideInt w; - return Tcl_GetWideIntFromObj(interp, objPtr, &w); -} -#endif /* !TCL_WIDE_INT_IS_LONG */ /* *---------------------------------------------------------------------- @@ -3148,8 +3125,8 @@ FreeBignum( UNPACK_BIGNUM(objPtr, toFree); mp_clear(&toFree); - if ((long) objPtr->internalRep.ptrAndLongRep.value < 0) { - ckfree(objPtr->internalRep.ptrAndLongRep.ptr); + if (PTR2INT(objPtr->internalRep.twoPtrValue.ptr2) < 0) { + ckfree(objPtr->internalRep.twoPtrValue.ptr1); } objPtr->typePtr = NULL; } @@ -3220,13 +3197,11 @@ UpdateStringOfBignum( if (status != MP_OKAY) { Tcl_Panic("radix size failure in UpdateStringOfBignum"); } - if (size == 3) { + if (size < 2) { /* - * mp_radix_size() returns 3 when more than INT_MAX bytes would be + * mp_radix_size() returns < 2 when more than INT_MAX bytes would be * needed to hold the string rep (because mp_radix_size ignores - * integer overflow issues). When we know the string rep will be more - * than 3, we can conclude the string rep would overflow our string - * length limits. + * integer overflow issues). * * Note that so long as we enforce our bignums to the size that fits * in a packed bignum, this branch will never be taken. @@ -3360,31 +3335,25 @@ GetBignumFromObj( mp_init_copy(bignumValue, &temp); } else { UNPACK_BIGNUM(objPtr, *bignumValue); - objPtr->internalRep.ptrAndLongRep.ptr = NULL; - objPtr->internalRep.ptrAndLongRep.value = 0; + objPtr->internalRep.twoPtrValue.ptr1 = NULL; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = NULL; if (objPtr->bytes == NULL) { - TclInitStringRep(objPtr, tclEmptyStringRep, 0); + TclInitStringRep(objPtr, &tclEmptyString, 0); } } return TCL_OK; } if (objPtr->typePtr == &tclIntType) { - TclBNInitBignumFromLong(bignumValue, objPtr->internalRep.longValue); - return TCL_OK; - } -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { - TclBNInitBignumFromWideInt(bignumValue, + TclInitBignumFromWideInt(bignumValue, objPtr->internalRep.wideValue); return TCL_OK; } -#endif if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected integer but got \"%s\"", - Tcl_GetString(objPtr))); + TclGetString(objPtr))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL); } return TCL_ERROR; @@ -3489,36 +3458,11 @@ Tcl_SetBignumObj( Tcl_Panic("%s called with shared object", "Tcl_SetBignumObj"); } if ((size_t) bignumValue->used - <= (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1) / DIGIT_BIT) { - unsigned long value = 0, numBytes = sizeof(long); - long scratch; - unsigned char *bytes = (unsigned char *) &scratch; - - if (mp_to_unsigned_bin_n(bignumValue, bytes, &numBytes) != MP_OKAY) { - goto tooLargeForLong; - } - while (numBytes-- > 0) { - value = (value << CHAR_BIT) | *bytes++; - } - if (value > (((~(unsigned long)0) >> 1) + bignumValue->sign)) { - goto tooLargeForLong; - } - if (bignumValue->sign) { - TclSetLongObj(objPtr, -(long)value); - } else { - TclSetLongObj(objPtr, (long)value); - } - mp_clear(bignumValue); - return; - } - tooLargeForLong: -#ifndef TCL_WIDE_INT_IS_LONG - if ((size_t) bignumValue->used - <= (CHAR_BIT * sizeof(Tcl_WideInt) + DIGIT_BIT - 1) / DIGIT_BIT) { + <= (CHAR_BIT * sizeof(Tcl_WideUInt) + DIGIT_BIT - 1) / DIGIT_BIT) { Tcl_WideUInt value = 0; - unsigned long numBytes = sizeof(Tcl_WideInt); - Tcl_WideInt scratch; - unsigned char *bytes = (unsigned char *)&scratch; + unsigned long numBytes = sizeof(Tcl_WideUInt); + Tcl_WideUInt scratch; + unsigned char *bytes = (unsigned char *) &scratch; if (mp_to_unsigned_bin_n(bignumValue, bytes, &numBytes) != MP_OKAY) { goto tooLargeForWide; @@ -3530,15 +3474,14 @@ Tcl_SetBignumObj( goto tooLargeForWide; } if (bignumValue->sign) { - TclSetWideIntObj(objPtr, -(Tcl_WideInt)value); + TclSetIntObj(objPtr, -(Tcl_WideInt)value); } else { - TclSetWideIntObj(objPtr, (Tcl_WideInt)value); + TclSetIntObj(objPtr, (Tcl_WideInt)value); } mp_clear(bignumValue); return; } tooLargeForWide: -#endif TclInvalidateStringRep(objPtr); TclFreeIntRep(objPtr); TclSetBignumIntRep(objPtr, bignumValue); @@ -3620,17 +3563,10 @@ TclGetNumberFromObj( return TCL_OK; } if (objPtr->typePtr == &tclIntType) { - *typePtr = TCL_NUMBER_LONG; - *clientDataPtr = &objPtr->internalRep.longValue; - return TCL_OK; - } -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { *typePtr = TCL_NUMBER_WIDE; *clientDataPtr = &objPtr->internalRep.wideValue; return TCL_OK; } -#endif if (objPtr->typePtr == &tclBignumType) { static Tcl_ThreadDataKey bignumKey; mp_int *bigPtr = Tcl_GetThreadData(&bignumKey, @@ -3683,7 +3619,7 @@ Tcl_DbIncrRefCount( Tcl_Panic("incrementing refCount of previously disposed object"); } -# ifdef TCL_THREADS +#if TCL_THREADS /* * Check to make sure that the Tcl_Obj was allocated by the current * thread. Don't do this check when shutting down since thread local @@ -3746,7 +3682,7 @@ Tcl_DbDecrRefCount( Tcl_Panic("decrementing refCount of previously disposed object"); } -# ifdef TCL_THREADS +#if TCL_THREADS /* * Check to make sure that the Tcl_Obj was allocated by the current * thread. Don't do this check when shutting down since thread local @@ -3766,25 +3702,11 @@ Tcl_DbDecrRefCount( Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread", "decr ref count"); } - - /* - * If the Tcl_Obj is going to be deleted, remove the entry. - */ - - if ((objPtr->refCount - 1) <= 0) { - ObjData *objData = Tcl_GetHashValue(hPtr); - - if (objData != NULL) { - ckfree(objData); - } - - Tcl_DeleteHashEntry(hPtr); - } } # endif /* TCL_THREADS */ #endif /* TCL_MEM_DEBUG */ - if (--(objPtr)->refCount <= 0) { + if (objPtr->refCount-- <= 1) { TclFreeObj(objPtr); } } @@ -3825,7 +3747,7 @@ Tcl_DbIsShared( Tcl_Panic("checking whether previously disposed object is shared"); } -# ifdef TCL_THREADS +#if TCL_THREADS /* * Check to make sure that the Tcl_Obj was allocated by the current * thread. Don't do this check when shutting down since thread local @@ -3948,15 +3870,14 @@ TclCompareObjKeys( Tcl_Obj *objPtr1 = keyPtr; Tcl_Obj *objPtr2 = (Tcl_Obj *) hPtr->key.oneWordValue; register const char *p1, *p2; - register int l1, l2; + register size_t l1, l2; /* * If the object pointers are the same then they match. - */ + * OPT: this comparison was moved to the caller - if (objPtr1 == objPtr2) { - return 1; - } + if (objPtr1 == objPtr2) return 1; + */ /* * Don't use Tcl_GetStringFromObj as it would prevent l1 and l2 being @@ -4030,7 +3951,7 @@ TclFreeObjEntry( *---------------------------------------------------------------------- */ -unsigned int +TCL_HASH_TYPE TclHashObjKey( Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key from which to compute hash value. */ @@ -4080,7 +4001,7 @@ TclHashObjKey( result += (result << 3) + UCHAR(*++string); } } - return result; + return (TCL_HASH_TYPE) result; } /* @@ -4134,11 +4055,10 @@ Tcl_GetCommandFromObj( */ resPtr = objPtr->internalRep.twoPtrValue.ptr1; - if ((objPtr->typePtr == &tclCmdNameType) && (resPtr != NULL)) { + if (objPtr->typePtr == &tclCmdNameType) { register Command *cmdPtr = resPtr->cmdPtr; if ((cmdPtr->cmdEpoch == resPtr->cmdEpoch) - && !(cmdPtr->flags & CMD_IS_DELETED) && (interp == cmdPtr->nsPtr->interp) && !(cmdPtr->nsPtr->flags & NS_DYING)) { register Namespace *refNsPtr = (Namespace *) @@ -4158,7 +4078,8 @@ Tcl_GetCommandFromObj( * had is invalid one way or another. */ - if (SetCmdNameFromAny(interp, objPtr) != TCL_OK) { + /* See [07d13d99b0a9] why we cannot call SetCmdNameFromAny() directly here. */ + if (tclCmdNameType.setFromAnyProc(interp, objPtr) != TCL_OK) { return NULL; } resPtr = objPtr->internalRep.twoPtrValue.ptr1; @@ -4185,54 +4106,78 @@ Tcl_GetCommandFromObj( *---------------------------------------------------------------------- */ -void -TclSetCmdNameObj( - 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. */ +static void +SetCmdNameObj( + Tcl_Interp *interp, + Tcl_Obj *objPtr, + Command *cmdPtr, + ResolvedCmdName *resPtr) { Interp *iPtr = (Interp *) interp; - register ResolvedCmdName *resPtr; - register Namespace *currNsPtr; - const char *name; + ResolvedCmdName *fillPtr; + const char *name = TclGetString(objPtr); - if (objPtr->typePtr == &tclCmdNameType) { - return; + if (resPtr) { + fillPtr = resPtr; + } else { + fillPtr = ckalloc(sizeof(ResolvedCmdName)); + fillPtr->refCount = 1; } + fillPtr->cmdPtr = cmdPtr; cmdPtr->refCount++; - resPtr = ckalloc(sizeof(ResolvedCmdName)); - resPtr->cmdPtr = cmdPtr; - resPtr->cmdEpoch = cmdPtr->cmdEpoch; - resPtr->refCount = 1; + fillPtr->cmdEpoch = cmdPtr->cmdEpoch; - name = TclGetString(objPtr); - if ((*name++ == ':') && (*name == ':')) { + /* NOTE: relying on NULL termination here. */ + if ((name[0] == ':') && (name[1] == ':')) { /* - * The name is fully qualified: set the referring namespace to - * NULL. + * Fully qualified names always resolve to same thing. No need + * to record resolution context information. */ - resPtr->refNsPtr = NULL; + fillPtr->refNsPtr = NULL; + fillPtr->refNsId = 0; /* Will not be read */ + fillPtr->refNsCmdEpoch = 0; /* Will not be read */ } else { /* - * Get the current namespace. + * Record current state of current namespace as the resolution + * context of this command name lookup. */ + Namespace *currNsPtr = iPtr->varFramePtr->nsPtr; - currNsPtr = iPtr->varFramePtr->nsPtr; + fillPtr->refNsPtr = currNsPtr; + fillPtr->refNsId = currNsPtr->nsId; + fillPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; + } + + if (resPtr == NULL) { + TclFreeIntRep(objPtr); - resPtr->refNsPtr = currNsPtr; - resPtr->refNsId = currNsPtr->nsId; - resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; + objPtr->internalRep.twoPtrValue.ptr1 = fillPtr; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; + objPtr->typePtr = &tclCmdNameType; } +} - TclFreeIntRep(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = resPtr; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - objPtr->typePtr = &tclCmdNameType; +void +TclSetCmdNameObj( + Tcl_Interp *interp, /* Points to interpreter containing command + * that should be cached in objPtr. */ + 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. */ +{ + register ResolvedCmdName *resPtr; + + if (objPtr->typePtr == &tclCmdNameType) { + resPtr = objPtr->internalRep.twoPtrValue.ptr1; + if (resPtr != NULL && resPtr->cmdPtr == cmdPtr) { + return; + } + } + + SetCmdNameObj(interp, objPtr, cmdPtr, NULL); } /* @@ -4263,14 +4208,12 @@ FreeCmdNameInternalRep( { register ResolvedCmdName *resPtr = objPtr->internalRep.twoPtrValue.ptr1; - if (resPtr != NULL) { /* * Decrement the reference count of the ResolvedCmdName structure. If * there are no more uses, free the ResolvedCmdName structure. */ - resPtr->refCount--; - if (resPtr->refCount == 0) { + if (resPtr->refCount-- <= 1) { /* * Now free the cached command, unless it is still in its hash * table or if there are other references to it from other cmdName @@ -4282,7 +4225,6 @@ FreeCmdNameInternalRep( TclCleanupCommandMacro(cmdPtr); ckfree(resPtr); } - } objPtr->typePtr = NULL; } @@ -4315,9 +4257,7 @@ DupCmdNameInternalRep( copyPtr->internalRep.twoPtrValue.ptr1 = resPtr; copyPtr->internalRep.twoPtrValue.ptr2 = NULL; - if (resPtr != NULL) { resPtr->refCount++; - } copyPtr->typePtr = &tclCmdNameType; } @@ -4347,10 +4287,8 @@ SetCmdNameFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr) /* The object to convert. */ { - Interp *iPtr = (Interp *) interp; const char *name; register Command *cmdPtr; - Namespace *currNsPtr; register ResolvedCmdName *resPtr; if (interp == NULL) { @@ -4370,59 +4308,31 @@ SetCmdNameFromAny( Tcl_FindCommand(interp, name, /*ns*/ NULL, /*flags*/ 0); /* - * Free the old internalRep before setting the new one. Do this after - * getting the string rep to allow the conversion code (in particular, - * Tcl_GetStringFromObj) to use that old internalRep. + * Stop shimmering and caching nothing when we found nothing. Just + * report the failure to find the command as an error. */ - if (cmdPtr) { - cmdPtr->refCount++; - resPtr = objPtr->internalRep.twoPtrValue.ptr1; - if ((objPtr->typePtr == &tclCmdNameType) - && resPtr && (resPtr->refCount == 1)) { - /* - * Reuse the old ResolvedCmdName struct instead of freeing it - */ - - Command *oldCmdPtr = resPtr->cmdPtr; - - if (--oldCmdPtr->refCount == 0) { - TclCleanupCommandMacro(oldCmdPtr); - } - } else { - TclFreeIntRep(objPtr); - resPtr = ckalloc(sizeof(ResolvedCmdName)); - resPtr->refCount = 1; - objPtr->internalRep.twoPtrValue.ptr1 = resPtr; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - objPtr->typePtr = &tclCmdNameType; - } - resPtr->cmdPtr = cmdPtr; - resPtr->cmdEpoch = cmdPtr->cmdEpoch; - if ((*name++ == ':') && (*name == ':')) { - /* - * The name is fully qualified: set the referring namespace to - * NULL. - */ + if (cmdPtr == NULL) { + return TCL_ERROR; + } - resPtr->refNsPtr = NULL; - } else { - /* - * Get the current namespace. - */ + resPtr = objPtr->internalRep.twoPtrValue.ptr1; + if ((objPtr->typePtr == &tclCmdNameType) && (resPtr->refCount == 1)) { + /* + * Re-use existing ResolvedCmdName struct when possible. + * Cleanup the old fields that need it. + */ - currNsPtr = iPtr->varFramePtr->nsPtr; + Command *oldCmdPtr = resPtr->cmdPtr; - resPtr->refNsPtr = currNsPtr; - resPtr->refNsId = currNsPtr->nsId; - resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; + if (oldCmdPtr->refCount-- <= 1) { + TclCleanupCommandMacro(oldCmdPtr); } } else { - TclFreeIntRep(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = NULL; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - objPtr->typePtr = &tclCmdNameType; + resPtr = NULL; } + + SetCmdNameObj(interp, objPtr, cmdPtr, resPtr); return TCL_OK; } @@ -4449,7 +4359,6 @@ Tcl_RepresentationCmd( int objc, Tcl_Obj *const objv[]) { - char ptrBuffer[2*TCL_INTEGER_SPACE+6]; Tcl_Obj *descObj; if (objc != 2) { @@ -4463,18 +4372,20 @@ Tcl_RepresentationCmd( * "1872361827361287" */ - sprintf(ptrBuffer, "%p", (void *) objv[1]); descObj = Tcl_ObjPrintf("value is a %s with a refcount of %d," - " object pointer at %s", - objv[1]->typePtr ? objv[1]->typePtr->name : "pure string", - objv[1]->refCount, ptrBuffer); + " object pointer at %p", + objv[1]->typePtr ? objv[1]->typePtr->name : "pure string", + objv[1]->refCount, objv[1]); if (objv[1]->typePtr) { - sprintf(ptrBuffer, "%p:%p", - (void *) objv[1]->internalRep.twoPtrValue.ptr1, - (void *) objv[1]->internalRep.twoPtrValue.ptr2); - Tcl_AppendPrintfToObj(descObj, ", internal representation %s", - ptrBuffer); + if (objv[1]->typePtr == &tclDoubleType) { + Tcl_AppendPrintfToObj(descObj, ", internal representation %g", + objv[1]->internalRep.doubleValue); + } else { + Tcl_AppendPrintfToObj(descObj, ", internal representation %p:%p", + (void *) objv[1]->internalRep.twoPtrValue.ptr1, + (void *) objv[1]->internalRep.twoPtrValue.ptr2); + } } if (objv[1]->bytes) { diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c index b7f4173..8267a7d 100644 --- a/generic/tclOptimize.c +++ b/generic/tclOptimize.c @@ -191,7 +191,7 @@ TrimUnreachable( * ConvertZeroEffectToNOP -- * * Replace PUSH/POP sequences (when non-hazardous) with NOPs. Also - * replace PUSH empty/CONCAT and TRY_CVT_NUMERIC (when followed by an + * replace PUSH empty/STR_CONCAT and TRY_CVT_NUMERIC (when followed by an * operation that guarantees the check for arithmeticity) and eliminate * LNOT when we can invert the following JUMP condition. * @@ -227,13 +227,13 @@ ConvertZeroEffectToNOP( case INST_PUSH1: if (nextInst == INST_POP) { blank = size + InstLength(nextInst); - } else if (nextInst == INST_CONCAT1 + } else if (nextInst == INST_STR_CONCAT1 && TclGetUInt1AtPtr(currentInstPtr + size + 1) == 2) { Tcl_Obj *litPtr = TclFetchLiteral(envPtr, TclGetUInt1AtPtr(currentInstPtr + 1)); int numBytes; - (void) Tcl_GetStringFromObj(litPtr, &numBytes); + (void) TclGetStringFromObj(litPtr, &numBytes); if (numBytes == 0) { blank = size + InstLength(nextInst); } @@ -242,13 +242,13 @@ ConvertZeroEffectToNOP( case INST_PUSH4: if (nextInst == INST_POP) { blank = size + 1; - } else if (nextInst == INST_CONCAT1 + } else if (nextInst == INST_STR_CONCAT1 && TclGetUInt1AtPtr(currentInstPtr + size + 1) == 2) { Tcl_Obj *litPtr = TclFetchLiteral(envPtr, TclGetUInt4AtPtr(currentInstPtr + 1)); int numBytes; - (void) Tcl_GetStringFromObj(litPtr, &numBytes); + (void) TclGetStringFromObj(litPtr, &numBytes); if (numBytes == 0) { blank = size + InstLength(nextInst); } @@ -344,21 +344,28 @@ AdvanceJumps( CompileEnv *envPtr) { unsigned char *currentInstPtr; + Tcl_HashTable jumps; for (currentInstPtr = envPtr->codeStart ; currentInstPtr < envPtr->codeNext-1 ; currentInstPtr += AddrLength(currentInstPtr)) { - int offset, delta; + int offset, delta, isNew; switch (*currentInstPtr) { case INST_JUMP1: case INST_JUMP_TRUE1: case INST_JUMP_FALSE1: offset = TclGetInt1AtPtr(currentInstPtr + 1); + Tcl_InitHashTable(&jumps, TCL_ONE_WORD_KEYS); for (delta=0 ; offset+delta != 0 ;) { if (offset + delta < -128 || offset + delta > 127) { break; } + Tcl_CreateHashEntry(&jumps, INT2PTR(offset), &isNew); + if (!isNew) { + offset = TclGetInt1AtPtr(currentInstPtr + 1); + break; + } offset += delta; switch (*(currentInstPtr + offset)) { case INST_NOP: @@ -373,13 +380,21 @@ AdvanceJumps( } break; } + Tcl_DeleteHashTable(&jumps); TclStoreInt1AtPtr(offset, currentInstPtr + 1); continue; case INST_JUMP4: case INST_JUMP_TRUE4: case INST_JUMP_FALSE4: + Tcl_InitHashTable(&jumps, TCL_ONE_WORD_KEYS); + Tcl_CreateHashEntry(&jumps, INT2PTR(0), &isNew); for (offset = TclGetInt4AtPtr(currentInstPtr + 1); offset!=0 ;) { + Tcl_CreateHashEntry(&jumps, INT2PTR(offset), &isNew); + if (!isNew) { + offset = TclGetInt4AtPtr(currentInstPtr + 1); + break; + } switch (*(currentInstPtr + offset)) { case INST_NOP: offset += InstLength(INST_NOP); @@ -393,6 +408,7 @@ AdvanceJumps( } break; } + Tcl_DeleteHashTable(&jumps); TclStoreInt4AtPtr(offset, currentInstPtr + 1); continue; } @@ -411,7 +427,7 @@ AdvanceJumps( void TclOptimizeBytecode( - CompileEnv *envPtr) + void *envPtr) { ConvertZeroEffectToNOP(envPtr); AdvanceJumps(envPtr); diff --git a/generic/tclPanic.c b/generic/tclPanic.c index 2a453b9..85b7388 100644 --- a/generic/tclPanic.c +++ b/generic/tclPanic.c @@ -15,7 +15,7 @@ #include "tclInt.h" #if defined(_WIN32) || defined(__CYGWIN__) - MODULE_SCOPE void tclWinDebugPanic(const char *format, ...); + MODULE_SCOPE TCL_NORETURN void tclWinDebugPanic(const char *format, ...); #endif /* @@ -23,10 +23,10 @@ * procedure. */ -#if defined(__CYGWIN__) -static Tcl_PanicProc *panicProc = tclWinDebugPanic; +#if defined(__CYGWIN__) || (defined(_WIN32) && (defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8)) +static TCL_NORETURN1 Tcl_PanicProc *panicProc = tclWinDebugPanic; #else -static Tcl_PanicProc *panicProc = NULL; +static TCL_NORETURN1 Tcl_PanicProc *panicProc = NULL; #endif /* @@ -45,9 +45,10 @@ static Tcl_PanicProc *panicProc = NULL; *---------------------------------------------------------------------- */ +#undef Tcl_SetPanicProc void Tcl_SetPanicProc( - Tcl_PanicProc *proc) + TCL_NORETURN1 Tcl_PanicProc *proc) { #if defined(_WIN32) /* tclWinDebugPanic only installs if there is no panicProc yet. */ @@ -111,7 +112,7 @@ Tcl_PanicVA( __builtin_trap(); # elif defined(_WIN64) __debugbreak(); -# elif defined(_MSC_VER) +# elif defined(_MSC_VER) && defined (_M_IX86) _asm {int 3} # else DebugBreak(); @@ -141,7 +142,14 @@ Tcl_PanicVA( *---------------------------------------------------------------------- */ - /* ARGSUSED */ +/* ARGSUSED */ + +/* + * The following comment is here so that Coverity's static analizer knows that + * a Tcl_Panic() call can never return and avoids lots of false positives. + */ + +/* coverity[+kill] */ void Tcl_Panic( const char *format, diff --git a/generic/tclParse.c b/generic/tclParse.c index c5cb1d1..00b83a1 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -12,10 +12,10 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ - -#include <assert.h> + #include "tclInt.h" #include "tclParse.h" +#include <assert.h> /* * The following table provides parsing information about each possible 8-bit @@ -167,6 +167,8 @@ static int ParseTokens(const char *src, int numBytes, int mask, int flags, Tcl_Parse *parsePtr); static int ParseWhiteSpace(const char *src, int numBytes, int *incompletePtr, char *typePtr); +static int ParseAllWhiteSpace(const char *src, int numBytes, + int *incompletePtr); /* *---------------------------------------------------------------------- @@ -298,9 +300,43 @@ Tcl_ParseCommand( */ parsePtr->commandStart = src; + type = CHAR_TYPE(*src); + scanned = 1; /* Can't have missing whitepsace before first word. */ while (1) { int expandWord = 0; + /* Are we at command termination? */ + + if ((numBytes == 0) || (type & terminators) != 0) { + parsePtr->term = src; + parsePtr->commandSize = src + (numBytes != 0) + - parsePtr->commandStart; + return TCL_OK; + } + + /* Are we missing white space after previous word? */ + + if (scanned == 0) { + if (src[-1] == '"') { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "extra characters after close-quote", -1)); + } + parsePtr->errorType = TCL_PARSE_QUOTE_EXTRA; + } else { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "extra characters after close-brace", -1)); + } + parsePtr->errorType = TCL_PARSE_BRACE_EXTRA; + } + parsePtr->term = src; + error: + Tcl_FreeParse(parsePtr); + parsePtr->commandSize = parsePtr->end - parsePtr->commandStart; + return TCL_ERROR; + } + /* * Create the token for the word. */ @@ -310,23 +346,6 @@ Tcl_ParseCommand( tokenPtr = &parsePtr->tokenPtr[wordIndex]; tokenPtr->type = TCL_TOKEN_WORD; - /* - * Skip white space before the word. Also skip a backslash-newline - * sequence: it should be treated just like white space. - */ - - scanned = ParseWhiteSpace(src,numBytes, &parsePtr->incomplete, &type); - src += scanned; - numBytes -= scanned; - if (numBytes == 0) { - parsePtr->term = src; - break; - } - if ((type & terminators) != 0) { - parsePtr->term = src; - src++; - break; - } tokenPtr->start = src; parsePtr->numTokens++; parsePtr->numWords++; @@ -511,7 +530,7 @@ Tcl_ParseCommand( listStart = nextElem = tokenPtr[1].start; while (nextElem < listEnd) { int quoted; - + tokenPtr->type = TCL_TOKEN_SIMPLE_WORD; tokenPtr->numComponents = 1; @@ -546,52 +565,12 @@ Tcl_ParseCommand( tokenPtr->type = TCL_TOKEN_SIMPLE_WORD; } - /* - * Do two additional checks: (a) make sure we're really at the end of - * a word (there might have been garbage left after a quoted or braced - * word), and (b) check for the end of the command. - */ + /* Parse the whitespace between words. */ scanned = ParseWhiteSpace(src,numBytes, &parsePtr->incomplete, &type); - if (scanned) { - src += scanned; - numBytes -= scanned; - continue; - } - - if (numBytes == 0) { - parsePtr->term = src; - break; - } - if ((type & terminators) != 0) { - parsePtr->term = src; - src++; - break; - } - if (src[-1] == '"') { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "extra characters after close-quote", -1)); - } - parsePtr->errorType = TCL_PARSE_QUOTE_EXTRA; - } else { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "extra characters after close-brace", -1)); - } - parsePtr->errorType = TCL_PARSE_BRACE_EXTRA; - } - parsePtr->term = src; - goto error; + src += scanned; + numBytes -= scanned; } - - parsePtr->commandSize = src - parsePtr->commandStart; - return TCL_OK; - - error: - Tcl_FreeParse(parsePtr); - parsePtr->commandSize = parsePtr->end - parsePtr->commandStart; - return TCL_ERROR; } /* @@ -621,6 +600,47 @@ TclIsSpaceProc( /* *---------------------------------------------------------------------- * + * TclIsBareword-- + * + * Report whether byte is one that can be part of a "bareword". + * This concept is named in expression parsing, where it determines + * what can be a legal function name, but is the same definition used + * in determining what variable names can be parsed as variable + * substitutions without the benefit of enclosing braces. The set of + * ASCII chars that are accepted are the numeric chars ('0'-'9'), + * the alphabetic chars ('a'-'z', 'A'-'Z') and underscore ('_'). + * + * Results: + * Returns 1, if byte is in the accepted set of chars, 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclIsBareword( + char byte) +{ + if (byte < '0' || byte > 'z') { + return 0; + } + if (byte <= '9' || byte >= 'a') { + return 1; + } + if (byte == '_') { + return 1; + } + if (byte < 'A' || byte > 'Z') { + return 0; + } + return 1; +} + +/* + *---------------------------------------------------------------------- + * * ParseWhiteSpace -- * * Scans up to numBytes bytes starting at src, consuming white space @@ -692,23 +712,32 @@ ParseWhiteSpace( *---------------------------------------------------------------------- */ -int -TclParseAllWhiteSpace( +static int +ParseAllWhiteSpace( const char *src, /* First character to parse. */ - int numBytes) /* Max number of byes to scan */ + int numBytes, /* Max number of byes to scan */ + int *incompletePtr) /* Set true if parse is incomplete. */ { - int dummy; char type; const char *p = src; do { - int scanned = ParseWhiteSpace(p, numBytes, &dummy, &type); + int scanned = ParseWhiteSpace(p, numBytes, incompletePtr, &type); p += scanned; numBytes -= scanned; } while (numBytes && (*p == '\n') && (p++, --numBytes)); return (p-src); } + +int +TclParseAllWhiteSpace( + const char *src, /* First character to parse. */ + int numBytes) /* Max number of byes to scan */ +{ + int dummy; + return ParseAllWhiteSpace(src, numBytes, &dummy); +} /* *---------------------------------------------------------------------- @@ -800,7 +829,7 @@ TclParseBackslash( * written there. */ { register const char *p = src+1; - Tcl_UniChar unichar; + Tcl_UniChar unichar = 0; int result; int count; char buf[TCL_UTF_MAX]; @@ -934,13 +963,13 @@ TclParseBackslash( */ if (Tcl_UtfCharComplete(p, numBytes - 1)) { - count = Tcl_UtfToUniChar(p, &unichar) + 1; /* +1 for '\' */ + count = TclUtfToUniChar(p, &unichar) + 1; /* +1 for '\' */ } else { char utfBytes[TCL_UTF_MAX]; memcpy(utfBytes, p, (size_t) (numBytes - 1)); utfBytes[numBytes - 1] = '\0'; - count = Tcl_UtfToUniChar(utfBytes, &unichar) + 1; + count = TclUtfToUniChar(utfBytes, &unichar) + 1; } result = unichar; break; @@ -950,7 +979,12 @@ TclParseBackslash( if (readPtr != NULL) { *readPtr = count; } - return Tcl_UniCharToUtf(result, dst); + count = Tcl_UniCharToUtf(result, dst); + if (!count) { + /* Special case for handling upper surrogates. */ + count = Tcl_UniCharToUtf(-1, dst); + } + return count; } /* @@ -980,17 +1014,12 @@ ParseComment( * command. */ { register const char *p = src; + int incomplete = parsePtr->incomplete; while (numBytes) { - char type; - int scanned; - - do { - scanned = ParseWhiteSpace(p, numBytes, - &parsePtr->incomplete, &type); - p += scanned; - numBytes -= scanned; - } while (numBytes && (*p == '\n') && (p++,numBytes--)); + int scanned = ParseAllWhiteSpace(p, numBytes, &incomplete); + p += scanned; + numBytes -= scanned; if ((numBytes == 0) || (*p != '#')) { break; @@ -999,35 +1028,28 @@ ParseComment( parsePtr->commentStart = p; } + p++; + numBytes--; while (numBytes) { + if (*p == '\n') { + p++; + numBytes--; + break; + } if (*p == '\\') { - scanned = ParseWhiteSpace(p, numBytes, &parsePtr->incomplete, - &type); - if (scanned) { - p += scanned; - numBytes -= scanned; - } else { - /* - * General backslash substitution in comments isn't part - * of the formal spec, but test parse-15.47 and history - * indicate that it has been the de facto rule. Don't - * change it now. - */ - - TclParseBackslash(p, numBytes, &scanned, NULL); - p += scanned; - numBytes -= scanned; - } - } else { p++; numBytes--; - if (p[-1] == '\n') { + if (numBytes == 0) { break; } } + incomplete = (*p == '\n'); + p++; + numBytes--; } parsePtr->commentSize = p - parsePtr->commentStart; } + parsePtr->incomplete = incomplete; return (p - src); } @@ -1152,6 +1174,8 @@ ParseTokens( numBytes--; nestedPtr = TclStackAlloc(parsePtr->interp, sizeof(Tcl_Parse)); while (1) { + const char *curEnd; + if (Tcl_ParseCommand(parsePtr->interp, src, numBytes, 1, nestedPtr) != TCL_OK) { parsePtr->errorType = nestedPtr->errorType; @@ -1160,8 +1184,9 @@ ParseTokens( TclStackFree(parsePtr->interp, nestedPtr); return TCL_ERROR; } + curEnd = src + numBytes; src = nestedPtr->commandStart + nestedPtr->commandSize; - numBytes = parsePtr->end - src; + numBytes = curEnd - src; Tcl_FreeParse(nestedPtr); /* @@ -1346,9 +1371,7 @@ Tcl_ParseVarName( { Tcl_Token *tokenPtr; register const char *src; - unsigned char c; - int varIndex, offset; - Tcl_UniChar ch; + int varIndex; unsigned array; if ((numBytes == 0) || (start == NULL)) { @@ -1431,22 +1454,12 @@ Tcl_ParseVarName( tokenPtr->numComponents = 0; 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; - numBytes -= offset; + if (TclIsBareword(*src)) { + src += 1; + numBytes -= 1; continue; } - if ((c == ':') && (numBytes != 1) && (src[1] == ':')) { + if ((src[0] == ':') && (numBytes != 1) && (src[1] == ':')) { src += 2; numBytes -= 2; while (numBytes && (*src == ':')) { @@ -1886,7 +1899,7 @@ Tcl_ParseQuotedString( * flags argument to provide support for the -nobackslashes, -nocommands, * and -novariables options, as represented by the flag values * TCL_SUBST_BACKSLASHES, TCL_SUBST_COMMANDS, TCL_SUBST_VARIABLES. - * + * * Results: * None. * @@ -2215,7 +2228,7 @@ TclSubstTokens( if (result == 0) { clPos = 0; } else { - Tcl_GetStringFromObj(result, &clPos); + TclGetStringFromObj(result, &clPos); } if (numCL >= maxNumCL) { @@ -2491,62 +2504,12 @@ TclObjCommandComplete( * check. */ { int length; - const char *script = Tcl_GetStringFromObj(objPtr, &length); + const char *script = TclGetStringFromObj(objPtr, &length); return CommandComplete(script, length); } /* - *---------------------------------------------------------------------- - * - * TclIsLocalScalar -- - * - * Check to see if a given string is a legal scalar variable name with no - * namespace qualifiers or substitutions. - * - * Results: - * Returns 1 if the variable is a local scalar. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclIsLocalScalar( - const char *src, - int len) -{ - const char *p; - const char *lastChar = src + (len - 1); - - for (p=src ; p<=lastChar ; p++) { - if ((CHAR_TYPE(*p) != TYPE_NORMAL) - && (CHAR_TYPE(*p) != TYPE_COMMAND_END)) { - /* - * TCL_COMMAND_END is returned for the last character of the - * string. By this point we know it isn't an array or namespace - * reference. - */ - - return 0; - } - if (*p == '(') { - if (*lastChar == ')') { /* We have an array element */ - return 0; - } - } else if (*p == ':') { - if ((p != lastChar) && *(p+1) == ':') { /* qualified name */ - return 0; - } - } - } - - return 1; -} - -/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index b7f3dcf..2453c46 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -13,6 +13,7 @@ #include "tclInt.h" #include "tclFileSystem.h" +#include <assert.h> /* * Prototypes for functions defined later in this file. @@ -231,7 +232,7 @@ TclFSNormalizeAbsolutePath( retVal = Tcl_NewStringObj(path, dirSep - path); Tcl_IncrRefCount(retVal); } - Tcl_GetStringFromObj(retVal, &curLen); + TclGetStringFromObj(retVal, &curLen); if (curLen == 0) { Tcl_AppendToObj(retVal, dirSep, 1); } @@ -257,7 +258,7 @@ TclFSNormalizeAbsolutePath( retVal = Tcl_NewStringObj(path, dirSep - path); Tcl_IncrRefCount(retVal); } - Tcl_GetStringFromObj(retVal, &curLen); + TclGetStringFromObj(retVal, &curLen); if (curLen == 0) { Tcl_AppendToObj(retVal, dirSep, 1); } @@ -288,7 +289,7 @@ TclFSNormalizeAbsolutePath( */ const char *path = - Tcl_GetStringFromObj(retVal, &curLen); + TclGetStringFromObj(retVal, &curLen); while (--curLen >= 0) { if (IsSeparatorOrNull(path[curLen])) { @@ -303,7 +304,7 @@ TclFSNormalizeAbsolutePath( Tcl_SetObjLength(retVal, curLen+1); Tcl_AppendObjToObj(retVal, linkObj); TclDecrRefCount(linkObj); - linkStr = Tcl_GetStringFromObj(retVal, &curLen); + linkStr = TclGetStringFromObj(retVal, &curLen); } else { /* * Absolute link. @@ -316,7 +317,7 @@ TclFSNormalizeAbsolutePath( } else { retVal = linkObj; } - linkStr = Tcl_GetStringFromObj(retVal, &curLen); + linkStr = TclGetStringFromObj(retVal, &curLen); /* * Convert to forward-slashes on windows. @@ -333,7 +334,7 @@ TclFSNormalizeAbsolutePath( } } } else { - linkStr = Tcl_GetStringFromObj(retVal, &curLen); + linkStr = TclGetStringFromObj(retVal, &curLen); } /* @@ -404,7 +405,7 @@ TclFSNormalizeAbsolutePath( if (tclPlatform == TCL_PLATFORM_WINDOWS) { int len; - const char *path = Tcl_GetStringFromObj(retVal, &len); + const char *path = TclGetStringFromObj(retVal, &len); if (len == 2 && path[0] != 0 && path[1] == ':') { if (Tcl_IsShared(retVal)) { @@ -512,7 +513,7 @@ TclFSGetPathType( if (PATHFLAGS(pathPtr) == 0) { /* The path is not absolute... */ -#ifdef __WIN32__ +#ifdef _WIN32 /* ... on Windows we must make another call to determine whether * it's relative or volumerelative [Bug 2571597]. */ return TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr, @@ -579,7 +580,7 @@ TclPathPart( int numBytes; const char *rest = - Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &numBytes); + TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes); if (strchr(rest, '/') != NULL) { goto standardPath; @@ -617,7 +618,7 @@ TclPathPart( int numBytes; const char *rest = - Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &numBytes); + TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes); if (strchr(rest, '/') != NULL) { goto standardPath; @@ -646,7 +647,7 @@ TclPathPart( const char *fileName, *extension; int length; - fileName = Tcl_GetStringFromObj(fsPathPtr->normPathPtr, + fileName = TclGetStringFromObj(fsPathPtr->normPathPtr, &length); extension = TclGetExtension(fileName); if (extension == NULL) { @@ -698,7 +699,7 @@ TclPathPart( int length; const char *fileName, *extension; - fileName = Tcl_GetStringFromObj(pathPtr, &length); + fileName = TclGetStringFromObj(pathPtr, &length); extension = TclGetExtension(fileName); if (extension == NULL) { Tcl_IncrRefCount(pathPtr); @@ -849,18 +850,20 @@ TclJoinPath( int elements, Tcl_Obj * const objv[]) { - Tcl_Obj *res; + Tcl_Obj *res = NULL; int i; const Tcl_Filesystem *fsPtr = NULL; - res = NULL; + assert ( elements >= 0 ); - for (i = 0; i < elements; i++) { - int driveNameLength, strEltLen, length; - Tcl_PathType type; - char *strElt, *ptr; - Tcl_Obj *driveName = NULL; - Tcl_Obj *elt = objv[i]; + if (elements == 0) { + return Tcl_NewObj(); + } + + assert ( elements > 0 ); + + if (elements == 2) { + Tcl_Obj *elt = objv[0]; /* * This is a special case where we can be much more efficient, where @@ -869,19 +872,22 @@ TclJoinPath( * object which can be normalized more efficiently. Currently we only * use the special case when we have exactly two elements, but we * could expand that in the future. + * + * Bugfix [a47641a0]. TclNewFSPathObj requires first argument + * to be an absolute path. Added a check for that elt is absolute. */ - if ((i == (elements-2)) && (i == 0) - && (elt->typePtr == &tclFsPathType) - && !((elt->bytes != NULL) && (elt->bytes[0] == '\0'))) { - Tcl_Obj *tailObj = objv[i+1]; + if ((elt->typePtr == &tclFsPathType) + && !((elt->bytes != NULL) && (elt->bytes[0] == '\0')) + && TclGetPathType(elt, NULL, NULL, NULL) == TCL_PATH_ABSOLUTE) { + Tcl_Obj *tailObj = objv[1]; + Tcl_PathType type = TclGetPathType(tailObj, NULL, NULL, NULL); - type = TclGetPathType(tailObj, NULL, NULL, NULL); if (type == TCL_PATH_RELATIVE) { const char *str; int len; - str = Tcl_GetStringFromObj(tailObj, &len); + str = TclGetStringFromObj(tailObj, &len); if (len == 0) { /* * This happens if we try to handle the root volume '/'. @@ -889,9 +895,6 @@ TclJoinPath( * the base itself is just fine! */ - if (res != NULL) { - TclDecrRefCount(res); - } return elt; } @@ -914,10 +917,17 @@ TclJoinPath( if ((tclPlatform != TCL_PLATFORM_WINDOWS) || (strchr(Tcl_GetString(elt), '\\') == NULL)) { - if (res != NULL) { - TclDecrRefCount(res); + + if (PATHFLAGS(elt)) { + return TclNewFSPathObj(elt, str, len); + } + if (TCL_PATH_ABSOLUTE != Tcl_FSGetPathType(elt)) { + return TclNewFSPathObj(elt, str, len); + } + (void) Tcl_FSGetNormalizedPath(NULL, elt); + if (elt == PATHOBJ(elt)->normPathPtr) { + return TclNewFSPathObj(elt, str, len); } - return TclNewFSPathObj(elt, str, len); } } @@ -926,24 +936,30 @@ TclJoinPath( * more general code below handle things. */ } else if (tclPlatform == TCL_PLATFORM_UNIX) { - if (res != NULL) { - TclDecrRefCount(res); - } return tailObj; } else { const char *str = TclGetString(tailObj); if (tclPlatform == TCL_PLATFORM_WINDOWS) { if (strchr(str, '\\') == NULL) { - if (res != NULL) { - TclDecrRefCount(res); - } return tailObj; } } } } - strElt = Tcl_GetStringFromObj(elt, &strEltLen); + } + + assert ( res == NULL ); + + for (i = 0; i < elements; i++) { + int driveNameLength, strEltLen, length; + Tcl_PathType type; + char *strElt, *ptr; + Tcl_Obj *driveName = NULL; + Tcl_Obj *elt = objv[i]; + + strElt = TclGetStringFromObj(elt, &strEltLen); + driveNameLength = 0; type = TclGetPathType(elt, &fsPtr, &driveNameLength, &driveName); if (type != TCL_PATH_RELATIVE) { /* @@ -999,6 +1015,12 @@ TclJoinPath( } } ptr = strElt; + /* [Bug f34cf83dd0] */ + if (driveNameLength > 0) { + if (ptr[0] == '/' && ptr[-1] == '/') { + goto noQuickReturn; + } + } while (*ptr != '\0') { if (*ptr == '/' && (ptr[1] == '/' || ptr[1] == '\0')) { /* @@ -1030,10 +1052,8 @@ TclJoinPath( noQuickReturn: if (res == NULL) { res = Tcl_NewObj(); - ptr = Tcl_GetStringFromObj(res, &length); - } else { - ptr = Tcl_GetStringFromObj(res, &length); } + ptr = TclGetStringFromObj(res, &length); /* * Strip off any './' before a tilde, unless this is the beginning of @@ -1066,6 +1086,7 @@ TclJoinPath( if (sep != NULL) { separator = TclGetString(sep)[0]; + TclDecrRefCount(sep); } /* Safety check in case the VFS driver caused sharing */ if (Tcl_IsShared(res)) { @@ -1077,7 +1098,7 @@ TclJoinPath( if (length > 0 && ptr[length -1] != '/') { Tcl_AppendToObj(res, &separator, 1); - Tcl_GetStringFromObj(res, &length); + TclGetStringFromObj(res, &length); } Tcl_SetObjLength(res, length + (int) strlen(strElt)); @@ -1101,9 +1122,7 @@ TclJoinPath( Tcl_SetObjLength(res, length); } } - if (res == NULL) { - res = Tcl_NewObj(); - } + assert ( res != NULL ); return res; } @@ -1372,7 +1391,7 @@ AppendPath( * intrep produce the same results; that is, bugward compatibility. If * we need to fix that bug here, it needs fixing in TclJoinPath() too. */ - bytes = Tcl_GetStringFromObj(tail, &numBytes); + bytes = TclGetStringFromObj(tail, &numBytes); if (numBytes == 0) { Tcl_AppendToObj(copy, "/", 1); } else { @@ -1431,7 +1450,7 @@ TclFSMakePathRelative( * too little below, leading to wrong answers returned by glob. */ - tempStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen); + tempStr = TclGetStringFromObj(cwdPtr, &cwdLen); /* * Should we perhaps use 'Tcl_FSPathSeparator'? But then what about the @@ -1451,7 +1470,7 @@ TclFSMakePathRelative( } break; } - tempStr = Tcl_GetStringFromObj(pathPtr, &len); + tempStr = TclGetStringFromObj(pathPtr, &len); return Tcl_NewStringObj(tempStr + cwdLen, len - cwdLen); } @@ -1715,7 +1734,7 @@ Tcl_FSGetTranslatedStringPath( if (transPtr != NULL) { int len; - const char *orig = Tcl_GetStringFromObj(transPtr, &len); + const char *orig = TclGetStringFromObj(transPtr, &len); char *result = ckalloc(len+1); memcpy(result, orig, (size_t) len+1); @@ -1776,7 +1795,7 @@ Tcl_FSGetNormalizedPath( UpdateStringOfFsPath(pathPtr); } - Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &tailLen); + TclGetStringFromObj(fsPathPtr->normPathPtr, &tailLen); if (tailLen) { copy = AppendPath(dir, fsPathPtr->normPathPtr); } else { @@ -1789,8 +1808,7 @@ Tcl_FSGetNormalizedPath( * We now own a reference on both 'dir' and 'copy' */ - (void) Tcl_GetStringFromObj(dir, &cwdLen); - cwdLen += (Tcl_GetString(copy)[cwdLen] == '/'); + (void) TclGetStringFromObj(dir, &cwdLen); /* Normalize the combined string. */ @@ -1812,12 +1830,12 @@ Tcl_FSGetNormalizedPath( * normalized head, we can more efficiently normalize the combined * path by passing over only the unnormalized tail portion. When * this is sufficient, prior developers claim this should be much - * faster. We use 'cwdLen-1' so that we are already pointing at + * faster. We use 'cwdLen' so that we are already pointing at * the dir-separator that we know about. The normalization code * will actually start off directly after that separator. */ - TclFSNormalizeToUniquePath(interp, copy, cwdLen-1); + TclFSNormalizeToUniquePath(interp, copy, cwdLen); } /* Now we need to construct the new path object. */ @@ -1883,7 +1901,7 @@ Tcl_FSGetNormalizedPath( copy = AppendPath(fsPathPtr->cwdPtr, pathPtr); - (void) Tcl_GetStringFromObj(fsPathPtr->cwdPtr, &cwdLen); + (void) TclGetStringFromObj(fsPathPtr->cwdPtr, &cwdLen); cwdLen += (Tcl_GetString(copy)[cwdLen] == '/'); /* @@ -1956,7 +1974,7 @@ Tcl_FSGetNormalizedPath( /* * We have a refCount on the cwd. */ -#ifdef __WIN32__ +#ifdef _WIN32 } else if (type == TCL_PATH_VOLUME_RELATIVE) { /* * Only Windows has volume-relative paths. @@ -1969,7 +1987,7 @@ Tcl_FSGetNormalizedPath( return NULL; } pureNormalized = 0; -#endif /* __WIN32__ */ +#endif /* _WIN32 */ } } @@ -2333,7 +2351,7 @@ SetFsPathFromAny( * cmdAH.test exercise most of the code). */ - name = Tcl_GetStringFromObj(pathPtr, &len); + name = TclGetStringFromObj(pathPtr, &len); /* * Handle tilde substitutions, if needed. @@ -2437,19 +2455,13 @@ SetFsPathFromAny( } TclDecrRefCount(parts); } else { - /* - * Simple case. "rest" is relative path. Just join it. The - * "rest" object will be freed when Tcl_FSJoinToPath returns - * (unless something else claims a refCount on it). - */ - - Tcl_Obj *joined; - Tcl_Obj *rest = Tcl_NewStringObj(name+split+1, -1); + Tcl_Obj *pair[2]; - Tcl_IncrRefCount(transPtr); - joined = Tcl_FSJoinToPath(transPtr, 1, &rest); - TclDecrRefCount(transPtr); - transPtr = joined; + pair[0] = transPtr; + pair[1] = Tcl_NewStringObj(name+split+1, -1); + transPtr = TclJoinPath(2, pair); + Tcl_DecrRefCount(pair[0]); + Tcl_DecrRefCount(pair[1]); } } } else { @@ -2608,9 +2620,9 @@ UpdateStringOfFsPath( copy = AppendPath(fsPathPtr->cwdPtr, fsPathPtr->normPathPtr); - pathPtr->bytes = Tcl_GetStringFromObj(copy, &cwdLen); + pathPtr->bytes = TclGetStringFromObj(copy, &cwdLen); pathPtr->length = cwdLen; - copy->bytes = tclEmptyStringRep; + copy->bytes = &tclEmptyString; copy->length = 0; TclDecrRefCount(copy); } @@ -2669,7 +2681,7 @@ TclNativePathInFilesystem( int len; - (void) Tcl_GetStringFromObj(pathPtr, &len); + (void) TclGetStringFromObj(pathPtr, &len); if (len == 0) { /* * We reject the empty path "". diff --git a/generic/tclPipe.c b/generic/tclPipe.c index 83fb818..f94fe5c 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -60,7 +60,7 @@ static TclFile FileForRedirect(Tcl_Interp *interp, const char *spec, static TclFile FileForRedirect( - Tcl_Interp *interp, /* Intepreter to use for error reporting. */ + Tcl_Interp *interp, /* Interpreter to use for error reporting. */ const char *spec, /* Points to character just after redirection * character. */ int atOK, /* Non-zero means that '@' notation can be @@ -221,13 +221,13 @@ Tcl_ReapDetachedProcs(void) { register Detached *detPtr; Detached *nextPtr, *prevPtr; - int status; - Tcl_Pid pid; + int status, code; Tcl_MutexLock(&pipeMutex); for (detPtr = detList, prevPtr = NULL; detPtr != NULL; ) { - pid = Tcl_WaitPid(detPtr->pid, &status, WNOHANG); - if ((pid == 0) || ((pid == (Tcl_Pid) -1) && (errno != ECHILD))) { + status = TclProcessWait(detPtr->pid, WNOHANG, &code, NULL, NULL); + if (status == TCL_PROCESS_UNCHANGED || (status == TCL_PROCESS_ERROR + && code != ECHILD)) { prevPtr = detPtr; detPtr = detPtr->nextPtr; continue; @@ -277,38 +277,21 @@ TclCleanupChildren( { int result = TCL_OK; int i, abnormalExit, anyErrorInfo; - Tcl_Pid pid; - int waitStatus; - const char *msg; - unsigned long resolvedPid; + TclProcessWaitStatus waitStatus; + int code; + Tcl_Obj *msg, *error; abnormalExit = 0; for (i = 0; i < numPids; i++) { - /* - * We need to get the resolved pid before we wait on it as the windows - * implementation of Tcl_WaitPid deletes the information such that any - * following calls to TclpGetPid fail. - */ - - resolvedPid = TclpGetPid(pidPtr[i]); - pid = Tcl_WaitPid(pidPtr[i], &waitStatus, 0); - if (pid == (Tcl_Pid) -1) { + waitStatus = TclProcessWait(pidPtr[i], 0, &code, &msg, &error); + if (waitStatus == TCL_PROCESS_ERROR) { result = TCL_ERROR; if (interp != NULL) { - msg = Tcl_PosixError(interp); - if (errno == ECHILD) { - /* - * This changeup in message suggested by Mark Diekhans to - * remind people that ECHILD errors can occur on some - * systems if SIGCHLD isn't in its default state. - */ - - msg = - "child process lost (is SIGCHLD ignored or trapped?)"; - } - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "error waiting for process to exit: %s", msg)); + Tcl_SetObjErrorCode(interp, error); + Tcl_SetObjResult(interp, msg); } + Tcl_DecrRefCount(error); + Tcl_DecrRefCount(msg); continue; } @@ -319,39 +302,19 @@ TclCleanupChildren( * removed). */ - if (!WIFEXITED(waitStatus) || (WEXITSTATUS(waitStatus) != 0)) { - char msg1[TCL_INTEGER_SPACE], msg2[TCL_INTEGER_SPACE]; - + if (waitStatus != TCL_PROCESS_EXITED || code != 0) { result = TCL_ERROR; - sprintf(msg1, "%lu", resolvedPid); - if (WIFEXITED(waitStatus)) { + if (waitStatus == TCL_PROCESS_EXITED) { if (interp != NULL) { - sprintf(msg2, "%u", WEXITSTATUS(waitStatus)); - Tcl_SetErrorCode(interp, "CHILDSTATUS", msg1, msg2, NULL); + Tcl_SetObjErrorCode(interp, error); } abnormalExit = 1; } else if (interp != NULL) { - const char *p; - - if (WIFSIGNALED(waitStatus)) { - p = Tcl_SignalMsg(WTERMSIG(waitStatus)); - Tcl_SetErrorCode(interp, "CHILDKILLED", msg1, - Tcl_SignalId(WTERMSIG(waitStatus)), p, NULL); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "child killed: %s\n", p)); - } else if (WIFSTOPPED(waitStatus)) { - p = Tcl_SignalMsg(WSTOPSIG(waitStatus)); - Tcl_SetErrorCode(interp, "CHILDSUSP", msg1, - Tcl_SignalId(WSTOPSIG(waitStatus)), p, NULL); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "child suspended: %s\n", p)); - } else { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "child wait status didn't make sense\n", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", - "ODDWAITRESULT", msg1, NULL); - } + Tcl_SetObjErrorCode(interp, error); + Tcl_SetObjResult(interp, msg); } + Tcl_DecrRefCount(error); + Tcl_DecrRefCount(msg); } } @@ -668,7 +631,13 @@ TclCreatePipeline( if (*p == '>') { p++; atOK = 0; - flags = O_WRONLY | O_CREAT; + + /* + * Note that the O_APPEND flag only has an effect on POSIX + * platforms. On Windows, we just have to carry on regardless. + */ + + flags = O_WRONLY | O_CREAT | O_APPEND; } if (errorClose != 0) { errorClose = 0; @@ -930,6 +899,7 @@ TclCreatePipeline( pidPtr[numPids] = pid; numPids++; + TclProcessCreated(pid); /* * Close off our copies of file descriptors that were set up for this diff --git a/generic/tclPkg.c b/generic/tclPkg.c index df90cea..2c16458 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -17,6 +17,10 @@ #include "tclInt.h" +MODULE_SCOPE char *tclEmptyStringRep; + +char *tclEmptyStringRep = &tclEmptyString; + /* * Each invocation of the "package ifneeded" command creates a structure of * the following type, which is used to load the package into the interpreter @@ -28,10 +32,22 @@ typedef struct PkgAvail { char *script; /* Script to invoke to provide this version of * the package. Malloc'ed and protected by * Tcl_Preserve and Tcl_Release. */ + char *pkgIndex; /* Full file name of pkgIndex file */ struct PkgAvail *nextPtr; /* Next in list of available versions of the * same package. */ } PkgAvail; +typedef struct PkgName { + struct PkgName *nextPtr; /* Next in list of package names being initialized. */ + char name[1]; +} PkgName; + +typedef struct PkgFiles { + PkgName *names; /* Package names being initialized. Must be first field*/ + Tcl_HashTable table; /* Table which contains files for each package */ +} PkgFiles; + + /* * For each package that is known in any way to an interpreter, there is one * record of the following type. These records are stored in the @@ -49,6 +65,18 @@ typedef struct Package { const void *clientData; /* Client data. */ } Package; +typedef struct Require { + void * clientDataPtr; + const char *name; + Package *pkgPtr; + char *versionToProvide; +} Require; + +typedef struct RequireProcArgs { + const char *name; + void *clientDataPtr; +} RequireProcArgs; + /* * Prototypes for functions defined in this file: */ @@ -69,9 +97,15 @@ static void AddRequirementsToResult(Tcl_Interp *interp, int reqc, static void AddRequirementsToDString(Tcl_DString *dstring, int reqc, Tcl_Obj *const reqv[]); static Package * FindPackage(Tcl_Interp *interp, const char *name); -static const char * PkgRequireCore(Tcl_Interp *interp, const char *name, - int reqc, Tcl_Obj *const reqv[], - void *clientDataPtr); +static int PkgRequireCore(ClientData data[], Tcl_Interp *interp, int result); +static int PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result); +static int PkgRequireCoreCleanup(ClientData data[], Tcl_Interp *interp, int result); +static int PkgRequireCoreStep1(ClientData data[], Tcl_Interp *interp, int result); +static int PkgRequireCoreStep2(ClientData data[], Tcl_Interp *interp, int result); +static int TclNRPkgRequireProc(ClientData clientData, Tcl_Interp *interp, int reqc, Tcl_Obj *const reqv[]); +static int SelectPackage(ClientData data[], Tcl_Interp *interp, int result); +static int SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result); +static int TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int result); /* * Helper macros. @@ -81,7 +115,7 @@ static const char * PkgRequireCore(Tcl_Interp *interp, const char *name, ((v) = ckalloc(len), memcpy((v),(s),(len))) #define DupString(v,s) \ do { \ - unsigned local__len = (unsigned) (strlen(s) + 1); \ + size_t local__len = strlen(s) + 1; \ DupBlock((v),(s),local__len); \ } while (0) @@ -189,6 +223,63 @@ Tcl_PkgProvideEx( *---------------------------------------------------------------------- */ +static void PkgFilesCleanupProc(ClientData clientData, + Tcl_Interp *interp) +{ + PkgFiles *pkgFiles = (PkgFiles *) clientData; + Tcl_HashSearch search; + Tcl_HashEntry *entry; + + while (pkgFiles->names) { + PkgName *name = pkgFiles->names; + pkgFiles->names = name->nextPtr; + ckfree(name); + } + entry = Tcl_FirstHashEntry(&pkgFiles->table, &search); + while (entry) { + Tcl_Obj *obj = (Tcl_Obj *)Tcl_GetHashValue(entry); + Tcl_DecrRefCount(obj); + entry = Tcl_NextHashEntry(&search); + } + Tcl_DeleteHashTable(&pkgFiles->table); + ckfree(pkgFiles); + return; +} + +void *TclInitPkgFiles(Tcl_Interp *interp) +{ + /* If assocdata "tclPkgFiles" doesn't exist yet, create it */ + PkgFiles *pkgFiles = Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + if (!pkgFiles) { + pkgFiles = ckalloc(sizeof(PkgFiles)); + pkgFiles->names = NULL; + Tcl_InitHashTable(&pkgFiles->table, TCL_STRING_KEYS); + Tcl_SetAssocData(interp, "tclPkgFiles", PkgFilesCleanupProc, pkgFiles); + } + return pkgFiles; +} + +void TclPkgFileSeen(Tcl_Interp *interp, const char *fileName) +{ + PkgFiles *pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + if (pkgFiles && pkgFiles->names) { + const char *name = pkgFiles->names->name; + Tcl_HashTable *table = &pkgFiles->table; + int new; + Tcl_HashEntry *entry = Tcl_CreateHashEntry(table, name, &new); + Tcl_Obj *list; + + if (new) { + list = Tcl_NewObj(); + Tcl_SetHashValue(entry, list); + Tcl_IncrRefCount(list); + } else { + list = Tcl_GetHashValue(entry); + } + Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj(fileName, -1)); + } +} + #undef Tcl_PkgRequire const char * Tcl_PkgRequire( @@ -258,8 +349,8 @@ Tcl_PkgRequireEx( * * Second, how does this work? If we reach this point, then the global * variable tclEmptyStringRep has the value NULL. Compare that with - * the definition of tclEmptyStringRep near the top of the file - * generic/tclObj.c. It clearly should not have the value NULL; it + * the definition of tclEmptyStringRep near the top of this file. + * It clearly should not have the value NULL; it * should point to the char tclEmptyString. If we see it having the * value NULL, then somehow we are seeing a Tcl library that isn't * completely initialized, and that's an indicator for the error @@ -275,18 +366,11 @@ Tcl_PkgRequireEx( * After all, two Tcl libraries can't be a good thing!) * * Trouble is that's going to be tricky. We're now using a Tcl library - * that's not fully initialized. In particular, it doesn't have a - * proper value for tclEmptyStringRep. The Tcl_Obj system heavily - * depends on the value of tclEmptyStringRep and all of Tcl depends - * (increasingly) on the Tcl_Obj system, we need to correct that flaw - * before making the calls to set the interpreter result to the error - * message. That's the only flaw corrected; other problems with - * initialization of the Tcl library are not remedied, so be very - * careful about adding any other calls here without checking how they - * behave when initialization is incomplete. + * that's not fully initialized. Functions in it may not work + * reliably, so be very careful about adding any other calls here + * without checking how they behave when initialization is incomplete. */ - tclEmptyStringRep = &tclEmptyString; Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Cannot load package \"%s\" in standalone executable:" " This package is not compiled with stub support", name)); @@ -299,7 +383,10 @@ Tcl_PkgRequireEx( */ if (version == NULL) { - result = PkgRequireCore(interp, name, 0, NULL, clientDataPtr); + if (Tcl_PkgRequireProc(interp, name, 0, NULL, clientDataPtr) == TCL_OK) { + result = Tcl_GetStringResult(interp); + Tcl_ResetResult(interp); + } } else { if (exact && TCL_OK != CheckVersionAndConvert(interp, version, NULL, NULL)) { @@ -310,10 +397,12 @@ Tcl_PkgRequireEx( Tcl_AppendStringsToObj(ov, "-", version, NULL); } Tcl_IncrRefCount(ov); - result = PkgRequireCore(interp, name, 1, &ov, clientDataPtr); + if (Tcl_PkgRequireProc(interp, name, 1, &ov, clientDataPtr) == TCL_OK) { + result = Tcl_GetStringResult(interp); + Tcl_ResetResult(interp); + } TclDecrRefCount(ov); } - return result; } @@ -328,327 +417,432 @@ Tcl_PkgRequireProc( * available. */ void *clientDataPtr) { - const char *result = - PkgRequireCore(interp, name, reqc, reqv, clientDataPtr); + RequireProcArgs args; + args.name = name; + args.clientDataPtr = clientDataPtr; + return Tcl_NRCallObjProc(interp, TclNRPkgRequireProc, (void *)&args, reqc, reqv); +} - if (result == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewStringObj(result, -1)); +static int +TclNRPkgRequireProc( + ClientData clientData, + Tcl_Interp *interp, + int reqc, + Tcl_Obj *const reqv[]) { + RequireProcArgs *args = clientData; + Tcl_NRAddCallback(interp, PkgRequireCore, (void *)args->name, INT2PTR(reqc), (void *)reqv, args->clientDataPtr); return TCL_OK; } -static const char * -PkgRequireCore( - Tcl_Interp *interp, /* Interpreter in which package is now - * available. */ - const char *name, /* Name of desired package. */ - int reqc, /* Requirements constraining the desired - * version. */ - Tcl_Obj *const reqv[], /* 0 means to use the latest version - * available. */ - void *clientDataPtr) +static int +PkgRequireCore(ClientData data[], Tcl_Interp *interp, int result) { - Interp *iPtr = (Interp *) interp; - Package *pkgPtr; - PkgAvail *availPtr, *bestPtr, *bestStablePtr; - char *availVersion, *bestVersion; - /* Internal rep. of versions */ - int availStable, code, satisfies, pass; - char *script, *pkgVersionI; + const char *name = data[0]; + int reqc = PTR2INT(data[1]); + Tcl_Obj *const *reqv = data[2]; + int code = CheckAllRequirements(interp, reqc, reqv); + Require *reqPtr; + if (code != TCL_OK) { + return code; + } + reqPtr = ckalloc(sizeof(Require)); + Tcl_NRAddCallback(interp, PkgRequireCoreCleanup, reqPtr, NULL, NULL, NULL); + reqPtr->clientDataPtr = data[3]; + reqPtr->name = name; + reqPtr->pkgPtr = FindPackage(interp, name); + if (reqPtr->pkgPtr->version == NULL) { + Tcl_NRAddCallback(interp, SelectPackage, reqPtr, INT2PTR(reqc), (void *)reqv, PkgRequireCoreStep1); + } else { + Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + } + return TCL_OK; +} + +static int +PkgRequireCoreStep1(ClientData data[], Tcl_Interp *interp, int result) { Tcl_DString command; + char *script; + Require *reqPtr = data[0]; + int reqc = PTR2INT(data[1]); + Tcl_Obj **const reqv = data[2]; + const char *name = reqPtr->name /* Name of desired package. */; + if (reqPtr->pkgPtr->version == NULL) { + /* + * The package is not in the database. If there is a "package unknown" + * command, invoke it. + */ - if (TCL_OK != CheckAllRequirements(interp, reqc, reqv)) { - return NULL; + script = ((Interp *) interp)->packageUnknown; + if (script == NULL) { + Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + } else { + Tcl_DStringInit(&command); + Tcl_DStringAppend(&command, script, -1); + Tcl_DStringAppendElement(&command, name); + AddRequirementsToDString(&command, reqc, reqv); + + Tcl_NRAddCallback(interp, PkgRequireCoreStep2, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + Tcl_NREvalObj(interp, + Tcl_NewStringObj(Tcl_DStringValue(&command), Tcl_DStringLength(&command)), + TCL_EVAL_GLOBAL + ); + Tcl_DStringFree(&command); + } + return TCL_OK; + } else { + Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + } + return TCL_OK; +} + +static int +PkgRequireCoreStep2(ClientData data[], Tcl_Interp *interp, int result) { + Require *reqPtr = data[0]; + int reqc = PTR2INT(data[1]); + Tcl_Obj **const reqv = data[2]; + const char *name = reqPtr->name /* Name of desired package. */; + if ((result != TCL_OK) && (result != TCL_ERROR)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad return code: %d", result)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); + result = TCL_ERROR; + } + if (result == TCL_ERROR) { + Tcl_AddErrorInfo(interp, + "\n (\"package unknown\" script)"); + return result; + } + Tcl_ResetResult(interp); + /* pkgPtr may now be invalid, so refresh it. */ + reqPtr->pkgPtr = FindPackage(interp, name); + Tcl_NRAddCallback(interp, SelectPackage, reqPtr, INT2PTR(reqc), (void *)reqv, PkgRequireCoreFinal); + return TCL_OK; +} + +static int +PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result) { + Require *reqPtr = data[0]; + int reqc = PTR2INT(data[1]), satisfies; + Tcl_Obj **const reqv = data[2]; + char *pkgVersionI; + void *clientDataPtr = reqPtr->clientDataPtr; + const char *name = reqPtr->name /* Name of desired package. */; + if (reqPtr->pkgPtr->version == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't find package %s", name)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL); + AddRequirementsToResult(interp, reqc, reqv); + return TCL_ERROR; } /* - * It can take up to three passes to find the package: one pass to run the - * "package unknown" script, one to run the "package ifneeded" script for - * a specific version, and a final pass to lookup the package loaded by - * the "package ifneeded" script. + * Ensure that the provided version meets the current requirements. */ - for (pass=1 ;; pass++) { - pkgPtr = FindPackage(interp, name); - if (pkgPtr->version != NULL) { - break; - } + if (reqc != 0) { + CheckVersionAndConvert(interp, reqPtr->pkgPtr->version, &pkgVersionI, NULL); + satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv); - /* - * Check whether we're already attempting to load some version of this - * package (circular dependency detection). - */ + ckfree(pkgVersionI); - if (pkgPtr->clientData != NULL) { + if (!satisfies) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "circular package dependency:" - " attempt to provide %s %s requires %s", - name, (char *) pkgPtr->clientData, name)); + "version conflict for package \"%s\": have %s, need", + name, reqPtr->pkgPtr->version)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", + NULL); AddRequirementsToResult(interp, reqc, reqv); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL); - return NULL; + return TCL_ERROR; } + } - /* - * The package isn't yet present. Search the list of available - * versions and invoke the script for the best available version. We - * are actually locating the best, and the best stable version. One of - * them is then chosen based on the selection mode. - */ + if (clientDataPtr) { + const void **ptr = (const void **) clientDataPtr; - bestPtr = NULL; - bestStablePtr = NULL; - bestVersion = NULL; + *ptr = reqPtr->pkgPtr->clientData; + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(reqPtr->pkgPtr->version, -1)); + return TCL_OK; +} - for (availPtr = pkgPtr->availPtr; availPtr != NULL; - availPtr = availPtr->nextPtr) { - if (CheckVersionAndConvert(interp, availPtr->version, - &availVersion, &availStable) != TCL_OK) { - /* - * The provided version number has invalid syntax. This - * should not happen. This should have been caught by the - * 'package ifneeded' registering the package. - */ +static int +PkgRequireCoreCleanup(ClientData data[], Tcl_Interp *interp, int result) { + ckfree(data[0]); + return result; +} - continue; - } + +static int +SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { + PkgAvail *availPtr, *bestPtr, *bestStablePtr; + char *availVersion, *bestVersion, *bestStableVersion; + /* Internal rep. of versions */ + int availStable, satisfies; + Require *reqPtr = data[0]; + int reqc = PTR2INT(data[1]); + Tcl_Obj **const reqv = data[2]; + const char *name = reqPtr->name; + Package *pkgPtr = reqPtr->pkgPtr; + Interp *iPtr = (Interp *) interp; - if (bestPtr != NULL) { - int res = CompareVersions(availVersion, bestVersion, NULL); + /* + * Check whether we're already attempting to load some version of this + * package (circular dependency detection). + */ - /* - * Note: Use internal reps! - */ + if (pkgPtr->clientData != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "circular package dependency:" + " attempt to provide %s %s requires %s", + name, (char *) pkgPtr->clientData, name)); + AddRequirementsToResult(interp, reqc, reqv); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL); + return TCL_ERROR; + } - if (res <= 0) { - /* - * The version of the package sought is not as good as the - * currently selected version. Ignore it. - */ + /* + * The package isn't yet present. Search the list of available + * versions and invoke the script for the best available version. We + * are actually locating the best, and the best stable version. One of + * them is then chosen based on the selection mode. + */ - ckfree(availVersion); - availVersion = NULL; - continue; - } - } + bestPtr = NULL; + bestStablePtr = NULL; + bestVersion = NULL; + bestStableVersion = NULL; + for (availPtr = pkgPtr->availPtr; availPtr != NULL; + availPtr = availPtr->nextPtr) { + if (CheckVersionAndConvert(interp, availPtr->version, + &availVersion, &availStable) != TCL_OK) { /* - * We have found a version which is better than our max. + * The provided version number has invalid syntax. This + * should not happen. This should have been caught by the + * 'package ifneeded' registering the package. */ - if (reqc > 0) { - /* Check satisfaction of requirements. */ + continue; + } - satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv); - if (!satisfies) { - ckfree(availVersion); - availVersion = NULL; - continue; - } + /* Check satisfaction of requirements before considering the current version further. */ + if (reqc > 0) { + satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv); + if (!satisfies) { + ckfree(availVersion); + availVersion = NULL; + continue; } + } - bestPtr = availPtr; - - if (bestVersion != NULL) { - ckfree(bestVersion); - } - bestVersion = availVersion; + if (bestPtr != NULL) { + int res = CompareVersions(availVersion, bestVersion, NULL); /* - * If this new best version is stable then it also has to be - * better than the max stable version found so far. + * Note: Used internal reps in the comparison! */ - if (availStable) { - bestStablePtr = availPtr; + if (res > 0) { + /* + * The version of the package sought is better than the + * currently selected version. + */ + ckfree(bestVersion); + bestVersion = NULL; + goto newbest; } - } + } else { + newbest: + /* We have found a version which is better than our max. */ - if (bestVersion != NULL) { - ckfree(bestVersion); + bestPtr = availPtr; + CheckVersionAndConvert(interp, bestPtr->version, &bestVersion, NULL); } - /* - * Now choose a version among the two best. For 'latest' we simply - * take (actually keep) the best. For 'stable' we take the best - * stable, if there is any, or the best if there is nothing stable. - */ - - if ((iPtr->packagePrefer == PKG_PREFER_STABLE) - && (bestStablePtr != NULL)) { - bestPtr = bestStablePtr; + if (!availStable) { + ckfree(availVersion); + availVersion = NULL; + continue; } - if (bestPtr != NULL) { + if (bestStablePtr != NULL) { + int res = CompareVersions(availVersion, bestStableVersion, NULL); + /* - * We found an ifneeded script for the package. Be careful while - * executing it: this could cause reentrancy, so (a) protect the - * script itself from deletion and (b) don't assume that bestPtr - * will still exist when the script completes. + * Note: Used internal reps in the comparison! */ - char *versionToProvide = bestPtr->version; - script = bestPtr->script; + if (res > 0) { + /* + * This stable version of the package sought is better + * than the currently selected stable version. + */ + ckfree(bestStableVersion); + bestStableVersion = NULL; + goto newstable; + } + } else { + newstable: + /* We have found a stable version which is better than our max stable. */ + bestStablePtr = availPtr; + CheckVersionAndConvert(interp, bestStablePtr->version, &bestStableVersion, NULL); + } - pkgPtr->clientData = versionToProvide; - Tcl_Preserve(script); - Tcl_Preserve(versionToProvide); - code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL); - Tcl_Release(script); + ckfree(availVersion); + availVersion = NULL; + } /* end for */ - pkgPtr = FindPackage(interp, name); - if (code == TCL_OK) { - Tcl_ResetResult(interp); - if (pkgPtr->version == NULL) { - code = TCL_ERROR; - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "attempt to provide package %s %s failed:" - " no version of package %s provided", - name, versionToProvide, name)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED", - NULL); - } else { - char *pvi, *vi; - - if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi, - NULL) != TCL_OK) { - code = TCL_ERROR; - } else if (CheckVersionAndConvert(interp, - versionToProvide, &vi, NULL) != TCL_OK) { - ckfree(pvi); - code = TCL_ERROR; - } else { - int res = CompareVersions(pvi, vi, NULL); - - ckfree(pvi); - ckfree(vi); - if (res != 0) { - code = TCL_ERROR; - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "attempt to provide package %s %s failed:" - " package %s %s provided instead", - name, versionToProvide, - name, pkgPtr->version)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", - "WRONGPROVIDE", NULL); - } - } - } - } else if (code != TCL_ERROR) { - Tcl_Obj *codePtr = Tcl_NewIntObj(code); - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "attempt to provide package %s %s failed:" - " bad return code: %s", - name, versionToProvide, TclGetString(codePtr))); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); - TclDecrRefCount(codePtr); - code = TCL_ERROR; - } + /* + * Clean up memorized internal reps, if any. + */ - if (code == TCL_ERROR) { - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"package ifneeded %s %s\" script)", - name, versionToProvide)); - } - Tcl_Release(versionToProvide); + if (bestVersion != NULL) { + ckfree(bestVersion); + bestVersion = NULL; + } - if (code != TCL_OK) { - /* - * Take a non-TCL_OK code from the script as an indication the - * package wasn't loaded properly, so the package system - * should not remember an improper load. - * - * This is consistent with our returning NULL. If we're not - * willing to tell our caller we got a particular version, we - * shouldn't store that version for telling future callers - * either. - */ + if (bestStableVersion != NULL) { + ckfree(bestStableVersion); + bestStableVersion = NULL; + } - if (pkgPtr->version != NULL) { - ckfree(pkgPtr->version); - pkgPtr->version = NULL; - } - pkgPtr->clientData = NULL; - return NULL; - } + /* + * Now choose a version among the two best. For 'latest' we simply + * take (actually keep) the best. For 'stable' we take the best + * stable, if there is any, or the best if there is nothing stable. + */ - break; - } + if ((iPtr->packagePrefer == PKG_PREFER_STABLE) + && (bestStablePtr != NULL)) { + bestPtr = bestStablePtr; + } + if (bestPtr == NULL) { + Tcl_NRAddCallback(interp, data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + } else { /* - * The package is not in the database. If there is a "package unknown" - * command, invoke it (but only on the first pass; after that, we - * should not get here in the first place). + * We found an ifneeded script for the package. Be careful while + * executing it: this could cause reentrancy, so (a) protect the + * script itself from deletion and (b) don't assume that bestPtr + * will still exist when the script completes. */ - if (pass > 1) { - break; + char *versionToProvide = bestPtr->version; + PkgFiles *pkgFiles; + PkgName *pkgName; + + Tcl_Preserve(versionToProvide); + pkgPtr->clientData = versionToProvide; + + pkgFiles = TclInitPkgFiles(interp); + /* Push "ifneeded" package name in "tclPkgFiles" assocdata. */ + pkgName = ckalloc(sizeof(PkgName) + strlen(name)); + pkgName->nextPtr = pkgFiles->names; + strcpy(pkgName->name, name); + pkgFiles->names = pkgName; + if (bestPtr->pkgIndex) { + TclPkgFileSeen(interp, bestPtr->pkgIndex); } + reqPtr->versionToProvide = versionToProvide; + Tcl_NRAddCallback(interp, SelectPackageFinal, reqPtr, INT2PTR(reqc), (void *)reqv, data[3]); + Tcl_NREvalObj(interp, Tcl_NewStringObj(bestPtr->script, -1), TCL_EVAL_GLOBAL); + } + return TCL_OK; +} + +static int +SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) { + Require *reqPtr = data[0]; + int reqc = PTR2INT(data[1]); + Tcl_Obj **const reqv = data[2]; + const char *name = reqPtr->name; + char *versionToProvide = reqPtr->versionToProvide; + + /* Pop the "ifneeded" package name from "tclPkgFiles" assocdata*/ + PkgFiles *pkgFiles = Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + PkgName *pkgName = pkgFiles->names; + pkgFiles->names = pkgName->nextPtr; + ckfree(pkgName); + + reqPtr->pkgPtr = FindPackage(interp, name); + if (result == TCL_OK) { + Tcl_ResetResult(interp); + if (reqPtr->pkgPtr->version == NULL) { + result = TCL_ERROR; + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "attempt to provide package %s %s failed:" + " no version of package %s provided", + name, versionToProvide, name)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED", + NULL); + } else { + char *pvi, *vi; - script = ((Interp *) interp)->packageUnknown; - if (script != NULL) { - Tcl_DStringInit(&command); - Tcl_DStringAppend(&command, script, -1); - Tcl_DStringAppendElement(&command, name); - AddRequirementsToDString(&command, reqc, reqv); - - code = Tcl_EvalEx(interp, Tcl_DStringValue(&command), - Tcl_DStringLength(&command), TCL_EVAL_GLOBAL); - Tcl_DStringFree(&command); + if (CheckVersionAndConvert(interp, reqPtr->pkgPtr->version, &pvi, + NULL) != TCL_OK) { + result = TCL_ERROR; + } else if (CheckVersionAndConvert(interp, + versionToProvide, &vi, NULL) != TCL_OK) { + ckfree(pvi); + result = TCL_ERROR; + } else { + int res = CompareVersions(pvi, vi, NULL); - if ((code != TCL_OK) && (code != TCL_ERROR)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad return code: %d", code)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); - code = TCL_ERROR; - } - if (code == TCL_ERROR) { - Tcl_AddErrorInfo(interp, - "\n (\"package unknown\" script)"); - return NULL; + ckfree(pvi); + ckfree(vi); + if (res != 0) { + result = TCL_ERROR; + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "attempt to provide package %s %s failed:" + " package %s %s provided instead", + name, versionToProvide, + name, reqPtr->pkgPtr->version)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", + "WRONGPROVIDE", NULL); + } } - Tcl_ResetResult(interp); } - } + } else if (result != TCL_ERROR) { + Tcl_Obj *codePtr = Tcl_NewIntObj(result); - if (pkgPtr->version == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't find package %s", name)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL); - AddRequirementsToResult(interp, reqc, reqv); - return NULL; + "attempt to provide package %s %s failed:" + " bad return code: %s", + name, versionToProvide, TclGetString(codePtr))); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); + TclDecrRefCount(codePtr); + result = TCL_ERROR; } - /* - * At this point we know that the package is present. Make sure that the - * provided version meets the current requirements. - */ - - if (reqc != 0) { - CheckVersionAndConvert(interp, pkgPtr->version, &pkgVersionI, NULL); - satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv); + if (result == TCL_ERROR) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"package ifneeded %s %s\" script)", + name, versionToProvide)); + } + Tcl_Release(versionToProvide); - ckfree(pkgVersionI); + if (result != TCL_OK) { + /* + * Take a non-TCL_OK code from the script as an indication the + * package wasn't loaded properly, so the package system + * should not remember an improper load. + * + * This is consistent with our returning NULL. If we're not + * willing to tell our caller we got a particular version, we + * shouldn't store that version for telling future callers + * either. + */ - if (!satisfies) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "version conflict for package \"%s\": have %s, need", - name, pkgPtr->version)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", - NULL); - AddRequirementsToResult(interp, reqc, reqv); - return NULL; + if (reqPtr->pkgPtr->version != NULL) { + ckfree(reqPtr->pkgPtr->version); + reqPtr->pkgPtr->version = NULL; } + reqPtr->pkgPtr->clientData = NULL; + return result; } - if (clientDataPtr) { - const void **ptr = (const void **) clientDataPtr; - - *ptr = pkgPtr->clientData; - } - return pkgPtr->version; + Tcl_NRAddCallback(interp, data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + return TCL_OK; } /* @@ -754,27 +948,36 @@ Tcl_PkgPresentEx( * *---------------------------------------------------------------------- */ +int +Tcl_PackageObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + return Tcl_NRCallObjProc(interp, TclNRPackageObjCmd, NULL, objc, objv); +} /* ARGSUSED */ int -Tcl_PackageObjCmd( +TclNRPackageObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { static const char *const pkgOptions[] = { - "forget", "ifneeded", "names", "prefer", "present", - "provide", "require", "unknown", "vcompare", "versions", - "vsatisfies", NULL + "files", "forget", "ifneeded", "names", "prefer", + "present", "provide", "require", "unknown", "vcompare", + "versions", "vsatisfies", NULL }; enum pkgOptions { - PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PREFER, PKG_PRESENT, - PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE, PKG_VERSIONS, - PKG_VSATISFIES + PKG_FILES, PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PREFER, + PKG_PRESENT, PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE, + PKG_VERSIONS, PKG_VSATISFIES }; Interp *iPtr = (Interp *) interp; - int optionIndex, exact, i, satisfies; + int optionIndex, exact, i, newobjc, satisfies; PkgAvail *availPtr, *prevPtr; Package *pkgPtr; Tcl_HashEntry *hPtr; @@ -783,6 +986,7 @@ Tcl_PackageObjCmd( const char *version; const char *argv2, *argv3, *argv4; char *iva = NULL, *ivb = NULL; + Tcl_Obj *objvListPtr, **newObjvPtr; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); @@ -794,11 +998,37 @@ Tcl_PackageObjCmd( return TCL_ERROR; } switch ((enum pkgOptions) optionIndex) { + case PKG_FILES: { + PkgFiles *pkgFiles; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "package"); + return TCL_ERROR; + } + pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + if (pkgFiles) { + Tcl_HashEntry *entry = Tcl_FindHashEntry(&pkgFiles->table, Tcl_GetString(objv[2])); + if (entry) { + Tcl_SetObjResult(interp, (Tcl_Obj *)Tcl_GetHashValue(entry)); + } + } + break; + } case PKG_FORGET: { const char *keyString; + PkgFiles *pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL); for (i = 2; i < objc; i++) { keyString = TclGetString(objv[i]); + if (pkgFiles) { + hPtr = Tcl_FindHashEntry(&pkgFiles->table, keyString); + if (hPtr) { + Tcl_Obj *obj = Tcl_GetHashValue(hPtr); + Tcl_DeleteHashEntry(hPtr); + Tcl_DecrRefCount(obj); + } + } + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString); if (hPtr == NULL) { continue; @@ -813,6 +1043,10 @@ Tcl_PackageObjCmd( pkgPtr->availPtr = availPtr->nextPtr; Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC); Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); + if (availPtr->pkgIndex) { + Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC); + availPtr->pkgIndex = NULL; + } ckfree(availPtr); } ckfree(pkgPtr); @@ -842,7 +1076,7 @@ Tcl_PackageObjCmd( } else { pkgPtr = FindPackage(interp, argv2); } - argv3 = Tcl_GetStringFromObj(objv[3], &length); + argv3 = TclGetStringFromObj(objv[3], &length); for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL; prevPtr = availPtr, availPtr = availPtr->nextPtr) { @@ -863,6 +1097,10 @@ Tcl_PackageObjCmd( return TCL_OK; } Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); + if (availPtr->pkgIndex) { + Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC); + availPtr->pkgIndex = NULL; + } break; } } @@ -873,6 +1111,7 @@ Tcl_PackageObjCmd( } if (availPtr == NULL) { availPtr = ckalloc(sizeof(PkgAvail)); + availPtr->pkgIndex = NULL; DupBlock(availPtr->version, argv3, (unsigned) length + 1); if (prevPtr == NULL) { @@ -883,7 +1122,11 @@ Tcl_PackageObjCmd( prevPtr->nextPtr = availPtr; } } - argv4 = Tcl_GetStringFromObj(objv[4], &length); + if (iPtr->scriptFile) { + argv4 = TclGetStringFromObj(iPtr->scriptFile, &length); + DupBlock(availPtr->pkgIndex, argv4, (unsigned) length + 1); + } + argv4 = TclGetStringFromObj(objv[4], &length); DupBlock(availPtr->script, argv4, (unsigned) length + 1); break; } @@ -989,7 +1232,6 @@ Tcl_PackageObjCmd( argv2 = TclGetString(objv[2]); if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { Tcl_Obj *ov; - int res; if (objc != 5) { goto requireSyntax; @@ -1009,17 +1251,38 @@ Tcl_PackageObjCmd( Tcl_AppendStringsToObj(ov, "-", version, NULL); version = NULL; argv3 = TclGetString(objv[3]); + Tcl_IncrRefCount(objv[3]); + + objvListPtr = Tcl_NewListObj(0, NULL); + Tcl_IncrRefCount(objvListPtr); + Tcl_ListObjAppendElement(interp, objvListPtr, ov); + Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); - Tcl_IncrRefCount(ov); - res = Tcl_PkgRequireProc(interp, argv3, 1, &ov, NULL); - TclDecrRefCount(ov); - return res; + Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[3], objvListPtr, NULL, NULL); + Tcl_NRAddCallback(interp, PkgRequireCore, (void *)argv3, INT2PTR(newobjc), newObjvPtr, NULL); + return TCL_OK; } else { + int i, newobjc = objc-3; + Tcl_Obj *const *newobjv = objv + 3; if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) { return TCL_ERROR; } + objvListPtr = Tcl_NewListObj(0, NULL); + Tcl_IncrRefCount(objvListPtr); + Tcl_IncrRefCount(objv[2]); + for (i = 0; i < newobjc; i++) { + + /* + * Tcl_Obj structures may have come from another interpreter, + * so duplicate them. + */ - return Tcl_PkgRequireProc(interp, argv2, objc-3, objv+3, NULL); + Tcl_ListObjAppendElement(interp, objvListPtr, Tcl_DuplicateObj(newobjv[i])); + } + Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); + Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[2], objvListPtr, NULL, NULL); + Tcl_NRAddCallback(interp, PkgRequireCore, (void *)argv2, INT2PTR(newobjc), newObjvPtr, NULL); + return TCL_OK; } break; case PKG_UNKNOWN: { @@ -1034,7 +1297,7 @@ Tcl_PackageObjCmd( if (iPtr->packageUnknown != NULL) { ckfree(iPtr->packageUnknown); } - argv2 = Tcl_GetStringFromObj(objv[2], &length); + argv2 = TclGetStringFromObj(objv[2], &length); if (argv2[0] == 0) { iPtr->packageUnknown = NULL; } else { @@ -1159,6 +1422,13 @@ Tcl_PackageObjCmd( } return TCL_OK; } + +static int +TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int result) { + TclDecrRefCount((Tcl_Obj *)data[0]); + TclDecrRefCount((Tcl_Obj *)data[1]); + return result; +} /* *---------------------------------------------------------------------- @@ -1220,7 +1490,7 @@ FindPackage( void TclFreePackageInfo( - Interp *iPtr) /* Interpereter that is being deleted. */ + Interp *iPtr) /* Interpreter that is being deleted. */ { Package *pkgPtr; Tcl_HashSearch search; @@ -1238,6 +1508,10 @@ TclFreePackageInfo( pkgPtr->availPtr = availPtr->nextPtr; Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC); Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); + if (availPtr->pkgIndex) { + Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC); + availPtr->pkgIndex = NULL; + } ckfree(availPtr); } ckfree(pkgPtr); @@ -1682,7 +1956,7 @@ AddRequirementsToResult( int i, length; for (i = 0; i < reqc; i++) { - const char *v = Tcl_GetStringFromObj(reqv[i], &length); + const char *v = TclGetStringFromObj(reqv[i], &length); if ((length & 0x1) && (v[length/2] == '-') && (strncmp(v, v+((length+1)/2), length/2) == 0)) { @@ -1895,7 +2169,7 @@ Tcl_PkgInitStubsCheck( { const char *actualVersion = Tcl_PkgPresent(interp, "Tcl", version, 0); - if (exact && actualVersion) { + if ((exact&1) && actualVersion) { const char *p = version; int count = 0; diff --git a/generic/tclPkgConfig.c b/generic/tclPkgConfig.c index 466d535..9e194c8 100644 --- a/generic/tclPkgConfig.c +++ b/generic/tclPkgConfig.c @@ -40,7 +40,7 @@ * configuration information. */ -#ifdef TCL_THREADS +#if TCL_THREADS # define CFG_THREADED "1" #else # define CFG_THREADED "0" diff --git a/generic/tclPlatDecls.h b/generic/tclPlatDecls.h index e9b92fe..abc8ee8 100644 --- a/generic/tclPlatDecls.h +++ b/generic/tclPlatDecls.h @@ -42,11 +42,15 @@ /* !BEGIN!: Do not edit below this line. */ +#ifdef __cplusplus +extern "C" { +#endif + /* * Exported function declarations: */ -#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ /* 0 */ EXTERN TCHAR * Tcl_WinUtfToTChar(const char *str, int len, Tcl_DString *dsPtr); @@ -71,7 +75,7 @@ typedef struct TclPlatStubs { int magic; void *hooks; -#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ TCHAR * (*tcl_WinUtfToTChar) (const char *str, int len, Tcl_DString *dsPtr); /* 0 */ char * (*tcl_WinTCharToUtf) (const TCHAR *str, int len, Tcl_DString *dsPtr); /* 1 */ #endif /* WIN */ @@ -81,10 +85,8 @@ typedef struct TclPlatStubs { #endif /* MACOSX */ } TclPlatStubs; -#ifdef __cplusplus -extern "C" { -#endif extern const TclPlatStubs *tclPlatStubsPtr; + #ifdef __cplusplus } #endif @@ -95,7 +97,7 @@ extern const TclPlatStubs *tclPlatStubsPtr; * Inline function declarations: */ -#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ #define Tcl_WinUtfToTChar \ (tclPlatStubsPtr->tcl_WinUtfToTChar) /* 0 */ #define Tcl_WinTCharToUtf \ diff --git a/generic/tclPreserve.c b/generic/tclPreserve.c index 0bd8f93..5c6097f 100644 --- a/generic/tclPreserve.c +++ b/generic/tclPreserve.c @@ -22,7 +22,7 @@ typedef struct { ClientData clientData; /* Address of preserved block. */ - int refCount; /* Number of Tcl_Preserve calls in effect for + size_t refCount; /* Number of Tcl_Preserve calls in effect for * block. */ int mustFree; /* Non-zero means Tcl_EventuallyFree was * called while a Tcl_Preserve call was in @@ -63,7 +63,7 @@ typedef struct HandleStruct { * ensure that the contents of the handle are * not changed by anyone else. */ #endif - int refCount; /* Number of TclHandlePreserve() calls in + size_t refCount; /* Number of TclHandlePreserve() calls in * effect on this handle. */ } HandleStruct; @@ -155,7 +155,7 @@ Tcl_Preserve( refPtr->clientData = clientData; refPtr->refCount = 1; refPtr->mustFree = 0; - refPtr->freeProc = TCL_STATIC; + refPtr->freeProc = 0; inUse += 1; Tcl_MutexUnlock(&preserveMutex); } @@ -195,7 +195,7 @@ Tcl_Release( continue; } - if (--refPtr->refCount != 0) { + if (refPtr->refCount-- > 1) { Tcl_MutexUnlock(&preserveMutex); return; } @@ -459,8 +459,7 @@ TclHandleRelease( handlePtr, handlePtr->ptr2, handlePtr->ptr); } #endif - handlePtr->refCount--; - if ((handlePtr->refCount == 0) && (handlePtr->ptr == NULL)) { + if ((handlePtr->refCount-- <= 1) && (handlePtr->ptr == NULL)) { ckfree(handlePtr); } } diff --git a/generic/tclProc.c b/generic/tclProc.c index 1314719..212b680 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -15,7 +15,6 @@ #include "tclInt.h" #include "tclCompile.h" -#include "tclOOInt.h" /* * Variables that are part of the [apply] command implementation and which @@ -23,7 +22,6 @@ */ typedef struct { - int isRootEnsemble; Command cmd; ExtraFrameInfo efi; } ApplyExtraData; @@ -41,9 +39,6 @@ static void InitResolvedLocals(Tcl_Interp *interp, ByteCode *codePtr, Var *defPtr, Namespace *nsPtr); static void InitLocalCache(Proc *procPtr); -static int PushProcCallFrame(ClientData clientData, - register Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[], int isLambda); static void ProcBodyDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr); static void ProcBodyFree(Tcl_Obj *objPtr); static int ProcWrongNumArgs(Tcl_Interp *interp, int skip); @@ -73,9 +68,8 @@ const Tcl_ObjType tclProcBodyType = { }; /* - * The [upvar]/[uplevel] level reference type. Uses the ptrAndLongRep field, - * encoding the type of level reference in ptr and the actual parsed out - * offset in value. + * The [upvar]/[uplevel] level reference type. Uses the longValue field + * to remember the integer value of a parsed #<integer> format. * * Uses the default behaviour throughout, and never disposes of the string * rep; it's just a cache type. @@ -92,10 +86,10 @@ static const Tcl_ObjType levelReferenceType = { * * Internally, ptr1 is a pointer to a Proc instance that is not bound to a * command name, and ptr2 is a pointer to the namespace that the Proc instance - * will execute within. + * will execute within. IF YOU CHANGE THIS, CHECK IN tclDisassemble.c TOO. */ -static const Tcl_ObjType lambdaType = { +const Tcl_ObjType tclLambdaType = { "lambdaExpr", /* name */ FreeLambdaInternalRep, /* freeIntRepProc */ DupLambdaInternalRep, /* dupIntRepProc */ @@ -130,11 +124,10 @@ Tcl_ProcObjCmd( { register Interp *iPtr = (Interp *) interp; Proc *procPtr; - const char *fullName; - const char *procName, *procArgs, *procBody; + const char *procName; + const char *simpleName, *procArgs, *procBody; Namespace *nsPtr, *altNsPtr, *cxtNsPtr; Tcl_Command cmd; - Tcl_DString ds; if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "name args body"); @@ -147,29 +140,21 @@ Tcl_ProcObjCmd( * namespace. */ - fullName = TclGetString(objv[1]); - TclGetNamespaceForQualName(interp, fullName, NULL, 0, - &nsPtr, &altNsPtr, &cxtNsPtr, &procName); + procName = TclGetString(objv[1]); + TclGetNamespaceForQualName(interp, procName, NULL, 0, + &nsPtr, &altNsPtr, &cxtNsPtr, &simpleName); if (nsPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create procedure \"%s\": unknown namespace", - fullName)); + procName)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } - if (procName == NULL) { + if (simpleName == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create procedure \"%s\": bad procedure name", - fullName)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); - return TCL_ERROR; - } - if ((nsPtr != iPtr->globalNsPtr) - && (procName != NULL) && (procName[0] == ':')) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't create procedure \"%s\" in non-global namespace with" - " name starting with \":\"", procName)); + procName)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } @@ -178,31 +163,16 @@ Tcl_ProcObjCmd( * Create the data structure to represent the procedure. */ - if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3], + if (TclCreateProc(interp, nsPtr, simpleName, objv[2], objv[3], &procPtr) != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (creating proc \""); - Tcl_AddErrorInfo(interp, procName); + Tcl_AddErrorInfo(interp, simpleName); Tcl_AddErrorInfo(interp, "\")"); return TCL_ERROR; } - /* - * Now create a command for the procedure. This will initially be in the - * current namespace unless the procedure's name included namespace - * qualifiers. To create the new command in the right namespace, we - * generate a fully qualified name for it. - */ - - Tcl_DStringInit(&ds); - if (nsPtr != iPtr->globalNsPtr) { - Tcl_DStringAppend(&ds, nsPtr->fullName, -1); - TclDStringAppendLiteral(&ds, "::"); - } - Tcl_DStringAppend(&ds, procName, -1); - - cmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), TclObjInterpProc, - TclNRInterpProc, procPtr, TclProcDeleteProc); - Tcl_DStringFree(&ds); + cmd = TclNRCreateCommandInNs(interp, simpleName, (Tcl_Namespace *) nsPtr, + TclObjInterpProc, TclNRInterpProc, procPtr, TclProcDeleteProc); /* * Now initialize the new procedure's cmdPtr field. This will be used @@ -221,7 +191,7 @@ Tcl_ProcObjCmd( * * This code is nearly identical to the #280 code in SetLambdaFromAny, see * this file. The differences are the different index of the body in the - * line array of the context, and the lamdba code requires some special + * line array of the context, and the lambda code requires some special * processing. Find a way to factor the common elements into a single * function. */ @@ -349,7 +319,7 @@ Tcl_ProcObjCmd( * The argument list is just "args"; check the body */ - procBody = Tcl_GetStringFromObj(objv[3], &numBytes); + procBody = TclGetStringFromObj(objv[3], &numBytes); if (TclParseAllWhiteSpace(procBody, numBytes) < numBytes) { goto done; } @@ -399,13 +369,13 @@ TclCreateProc( Proc **procPtrPtr) /* Returns: pointer to proc data. */ { Interp *iPtr = (Interp *) interp; - const char **argArray = NULL; register Proc *procPtr; - int i, length, result, numArgs; - const char *args, *bytes, *p; + int i, result, numArgs, plen; + const char *bytes, *argname, *argnamei; + char argnamelast; register CompiledLocal *localPtr = NULL; - Tcl_Obj *defPtr; + Tcl_Obj *defPtr, *errorObj, **argArray; int precompiled = 0; if (bodyPtr->typePtr == &tclProcBodyType) { @@ -442,6 +412,7 @@ TclCreateProc( */ if (Tcl_IsShared(bodyPtr)) { + int length; Tcl_Obj *sharedBodyPtr = bodyPtr; bytes = TclGetStringFromObj(bodyPtr, &length); @@ -479,12 +450,9 @@ TclCreateProc( * argument specifier. If the body is precompiled, processing is limited * to checking that the parsed argument is consistent with the one stored * in the Proc. - * - * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULS. */ - args = TclGetStringFromObj(argsPtr, &length); - result = Tcl_SplitList(interp, args, &numArgs, &argArray); + result = Tcl_ListObjGetElements(interp , argsPtr ,&numArgs ,&argArray); if (result != TCL_OK) { goto procError; } @@ -506,29 +474,30 @@ TclCreateProc( } for (i = 0; i < numArgs; i++) { - int fieldCount, nameLength, valueLength; - const char **fieldValues; + int fieldCount, nameLength; + size_t valueLength; + Tcl_Obj **fieldValues; /* * Now divide the specifier up into name and default. */ - result = Tcl_SplitList(interp, argArray[i], &fieldCount, + result = Tcl_ListObjGetElements(interp, argArray[i], &fieldCount, &fieldValues); if (result != TCL_OK) { goto procError; } if (fieldCount > 2) { - ckfree(fieldValues); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "too many fields in argument specifier \"%s\"", - argArray[i])); + errorObj = Tcl_NewStringObj( + "too many fields in argument specifier \"", -1); + Tcl_AppendObjToObj(errorObj, argArray[i]); + Tcl_AppendToObj(errorObj, "\"", -1); + Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } - if ((fieldCount == 0) || (*fieldValues[0] == 0)) { - ckfree(fieldValues); + if ((fieldCount == 0) || (fieldValues[0]->length == 0)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "argument with no name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", @@ -536,9 +505,10 @@ TclCreateProc( goto procError; } - nameLength = strlen(fieldValues[0]); + nameLength = Tcl_NumUtfChars(Tcl_GetString(fieldValues[0]), fieldValues[0]->length); if (fieldCount == 2) { - valueLength = strlen(fieldValues[1]); + valueLength = Tcl_NumUtfChars(Tcl_GetString(fieldValues[1]), + fieldValues[1]->length); } else { valueLength = 0; } @@ -547,33 +517,29 @@ TclCreateProc( * Check that the formal parameter name is a scalar. */ - p = fieldValues[0]; - while (*p != '\0') { - if (*p == '(') { - const char *q = p; - do { - q++; - } while (*q != '\0'); - q--; - if (*q == ')') { /* We have an array element. */ + argname = Tcl_GetStringFromObj(fieldValues[0], &plen); + argnamei = argname; + argnamelast = argname[plen-1]; + while (plen--) { + if (argnamei[0] == '(') { + if (argnamelast == ')') { /* We have an array element. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "formal parameter \"%s\" is an array element", - fieldValues[0])); - ckfree(fieldValues); + Tcl_GetString(fieldValues[0]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } - } else if ((*p == ':') && (*(p+1) == ':')) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "formal parameter \"%s\" is not a simple name", - fieldValues[0])); - ckfree(fieldValues); + } else if ((argnamei[0] == ':') && (argnamei[1] == ':')) { + errorObj = Tcl_NewStringObj("formal parameter \"", -1); + Tcl_AppendObjToObj(errorObj, fieldValues[0]); + Tcl_AppendToObj(errorObj, "\" is not a simple name", -1); + Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } - p++; + argnamei = Tcl_UtfNext(argnamei); } if (precompiled) { @@ -589,7 +555,7 @@ TclCreateProc( */ if ((localPtr->nameLength != nameLength) - || (strcmp(localPtr->name, fieldValues[0])) + || (Tcl_UtfNcmp(localPtr->name, argname, nameLength)) || (localPtr->frameIndex != i) || !(localPtr->flags & VAR_ARGUMENT) || (localPtr->defValuePtr == NULL && fieldCount == 2) @@ -597,7 +563,6 @@ TclCreateProc( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "procedure \"%s\": formal parameter %d is " "inconsistent with precompiled body", procName, i)); - ckfree(fieldValues); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "BYTECODELIES", NULL); goto procError; @@ -608,17 +573,17 @@ TclCreateProc( */ if (localPtr->defValuePtr != NULL) { - int tmpLength; - const char *tmpPtr = TclGetStringFromObj(localPtr->defValuePtr, - &tmpLength); + const char *tmpPtr = TclGetString(localPtr->defValuePtr); + size_t tmpLength = localPtr->defValuePtr->length; if ((valueLength != tmpLength) || - strncmp(fieldValues[1], tmpPtr, (size_t) tmpLength)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "procedure \"%s\": formal parameter \"%s\" has " - "default value inconsistent with precompiled body", - procName, fieldValues[0])); - ckfree(fieldValues); + Tcl_UtfNcmp(Tcl_GetString(fieldValues[1]), tmpPtr, tmpLength)) { + errorObj = Tcl_ObjPrintf( + "procedure \"%s\": formal parameter \"" ,procName); + Tcl_AppendObjToObj(errorObj, fieldValues[0]); + Tcl_AppendToObj(errorObj, "\" has " + "default value inconsistent with precompiled body", -1); + Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "BYTECODELIES", NULL); goto procError; @@ -638,7 +603,7 @@ TclCreateProc( * local variables for the argument. */ - localPtr = ckalloc(TclOffset(CompiledLocal, name) + nameLength+1); + localPtr = ckalloc(TclOffset(CompiledLocal, name) + fieldValues[0]->length +1); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; } else { @@ -646,19 +611,18 @@ TclCreateProc( procPtr->lastLocalPtr = localPtr; } localPtr->nextPtr = NULL; - localPtr->nameLength = nameLength; + localPtr->nameLength = Tcl_NumUtfChars(argname, fieldValues[0]->length); localPtr->frameIndex = i; localPtr->flags = VAR_ARGUMENT; localPtr->resolveInfo = NULL; if (fieldCount == 2) { - localPtr->defValuePtr = - Tcl_NewStringObj(fieldValues[1], valueLength); + localPtr->defValuePtr = fieldValues[1]; Tcl_IncrRefCount(localPtr->defValuePtr); } else { localPtr->defValuePtr = NULL; } - memcpy(localPtr->name, fieldValues[0], nameLength + 1); + memcpy(localPtr->name, argname, fieldValues[0]->length + 1); if ((i == numArgs - 1) && (localPtr->nameLength == 4) && (localPtr->name[0] == 'a') @@ -666,12 +630,9 @@ TclCreateProc( localPtr->flags |= VAR_IS_ARGS; } } - - ckfree(fieldValues); } *procPtrPtr = procPtr; - ckfree(argArray); return TCL_OK; procError: @@ -692,9 +653,6 @@ TclCreateProc( } ckfree(procPtr); } - if (argArray != NULL) { - ckfree(argArray); - } return TCL_ERROR; } @@ -789,7 +747,7 @@ TclGetFrame( * Results: * The return value is -1 if an error occurred in finding the frame (in * this case an error message is left in the interp's result). 1 is - * returned if objPtr was either a number or a number preceded by "#" and + * returned if objPtr was either an int or an int preceded by "#" and * it specified a valid frame. 0 is returned if objPtr isn't one of the * two things above (in this case, the lookup acts as if objPtr were * "1"). The variable pointed to by framePtrPtr is filled in with the @@ -811,101 +769,71 @@ TclObjGetFrame( { register Interp *iPtr = (Interp *) interp; int curLevel, level, result; - CallFrame *framePtr; - const char *name; + const char *name = NULL; /* * Parse object to figure out which level number to go to. */ - result = 1; + result = 0; curLevel = iPtr->varFramePtr->level; - if (objPtr == NULL) { - name = "1"; - goto haveLevel1; - } - name = TclGetString(objPtr); - if (objPtr->typePtr == &levelReferenceType) { - if (objPtr->internalRep.ptrAndLongRep.ptr != NULL) { - level = curLevel - objPtr->internalRep.ptrAndLongRep.value; - } else { - level = objPtr->internalRep.ptrAndLongRep.value; - } - if (level < 0) { - goto levelError; - } - /* TODO: Consider skipping the typePtr checks */ - } else if (objPtr->typePtr == &tclIntType -#ifndef TCL_WIDE_INT_IS_LONG - || objPtr->typePtr == &tclWideIntType -#endif - ) { - if (TclGetIntFromObj(NULL, objPtr, &level) != TCL_OK || level < 0) { - goto levelError; - } - level = curLevel - level; - } else if (*name == '#') { - if (Tcl_GetInt(interp, name+1, &level) != TCL_OK || level < 0) { - goto levelError; - } - - /* - * Cache for future reference. - * - * TODO: Use the new ptrAndLongRep intrep - */ - - TclFreeIntRep(objPtr); - objPtr->typePtr = &levelReferenceType; - objPtr->internalRep.ptrAndLongRep.ptr = NULL; - objPtr->internalRep.ptrAndLongRep.value = level; - } else if (isdigit(UCHAR(*name))) { /* INTL: digit */ - if (Tcl_GetInt(interp, name, &level) != TCL_OK) { - return -1; - } - - /* - * Cache for future reference. - * - * TODO: Use the new ptrAndLongRep intrep - */ + /* + * Check for integer first, since that has potential to spare us + * a generation of a stringrep. + */ - TclFreeIntRep(objPtr); - objPtr->typePtr = &levelReferenceType; - objPtr->internalRep.ptrAndLongRep.ptr = (void *) 1; /* non-NULL */ - objPtr->internalRep.ptrAndLongRep.value = level; + if (objPtr == NULL) { + /* Do nothing */ + } else if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &level) + && (level >= 0)) { level = curLevel - level; + result = 1; + } else if (objPtr->typePtr == &levelReferenceType) { + level = (int) objPtr->internalRep.wideValue; + result = 1; } else { - /* - * Don't cache as the object *isn't* a level reference (might even be - * NULL...) - */ + name = TclGetString(objPtr); + if (name[0] == '#') { + if (TCL_OK == Tcl_GetInt(NULL, name+1, &level) && level >= 0) { + TclFreeIntRep(objPtr); + objPtr->typePtr = &levelReferenceType; + objPtr->internalRep.wideValue = level; + result = 1; + } else { + result = -1; + } + } else if (isdigit(UCHAR(name[0]))) { /* INTL: digit */ + /* + * If this were an integer, we'd have succeeded already. + * Docs say we have to treat this as a 'bad level' error. + */ + result = -1; + } + } - haveLevel1: + if (result == 0) { level = curLevel - 1; - result = 0; + name = "1"; } - - /* - * Figure out which frame to use, and return it to the caller. - */ - - for (framePtr = iPtr->varFramePtr; framePtr != NULL; - framePtr = framePtr->callerVarPtr) { - if (framePtr->level == level) { - break; + if (result != -1) { + if (level >= 0) { + CallFrame *framePtr; + for (framePtr = iPtr->varFramePtr; framePtr != NULL; + framePtr = framePtr->callerVarPtr) { + if (framePtr->level == level) { + *framePtrPtr = framePtr; + return result; + } + } + } + if (name == NULL) { + name = TclGetString(objPtr); } } - if (framePtr == NULL) { - goto levelError; - } - *framePtrPtr = framePtr; - return result; - levelError: Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", name, NULL); return -1; } @@ -1123,12 +1051,10 @@ ProcWrongNumArgs( if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) { desiredObjs[0] = Tcl_NewStringObj("lambdaExpr", -1); } else { - ((Interp *) interp)->ensembleRewrite.numInsertedObjs -= skip - 1; - #ifdef AVOID_HACKS_FOR_ITCL desiredObjs[0] = framePtr->objv[skip-1]; #else - desiredObjs[0] = Tcl_NewListObj(skip, framePtr->objv); + desiredObjs[0] = Tcl_NewListObj(1, framePtr->objv + skip - 1); #endif /* AVOID_HACKS_FOR_ITCL */ } Tcl_IncrRefCount(desiredObjs[0]); @@ -1563,6 +1489,10 @@ InitArgsAndLocals( */ incorrectArgs: + if ((skip != 1) && + TclInitRewriteEnsemble(interp, skip-1, 0, framePtr->objv)) { + TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); + } memset(varPtr, 0, ((framePtr->compiledLocals + localCt)-varPtr) * sizeof(Var)); return ProcWrongNumArgs(interp, skip); @@ -1571,7 +1501,7 @@ InitArgsAndLocals( /* *---------------------------------------------------------------------- * - * PushProcCallFrame -- + * TclPushProcCallFrame -- * * Compiles a proc body if necessary, then pushes a CallFrame suitable * for executing it. @@ -1586,8 +1516,8 @@ InitArgsAndLocals( *---------------------------------------------------------------------- */ -static int -PushProcCallFrame( +int +TclPushProcCallFrame( ClientData clientData, /* Record describing procedure to be * interpreted. */ register Tcl_Interp *interp,/* Interpreter in which procedure was @@ -1650,12 +1580,9 @@ PushProcCallFrame( */ framePtrPtr = &framePtr; - result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, + (void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, (Tcl_Namespace *) nsPtr, (isLambda? (FRAME_IS_PROC|FRAME_IS_LAMBDA) : FRAME_IS_PROC)); - if (result != TCL_OK) { - return result; - } framePtr->objc = objc; framePtr->objv = objv; @@ -1708,7 +1635,7 @@ TclNRInterpProc( * procedure. */ Tcl_Obj *const objv[]) /* Argument value objects. */ { - int result = PushProcCallFrame(clientData, interp, objc, objv, + int result = TclPushProcCallFrame(clientData, interp, objc, objv, /*isLambda*/ 0); if (result != TCL_OK) { @@ -1850,14 +1777,44 @@ InterpProcNR2( TCL_DTRACE_PROC_RETURN(l < iPtr->varFramePtr->objc ? TclGetString(iPtr->varFramePtr->objv[l]) : NULL, result); } - if (--procPtr->refCount <= 0) { + if (procPtr->refCount-- <= 1) { TclProcCleanupProc(procPtr); } /* - * Process the result code. + * Free the stack-allocated compiled locals and CallFrame. It is important + * to pop the call frame without freeing it first: the compiledLocals + * cannot be freed before the frame is popped, as the local variables must + * be deleted. But the compiledLocals must be freed first, as they were + * allocated later on the stack. */ + if (result != TCL_OK) { + goto process; + } + + done: + if (TCL_DTRACE_PROC_RESULT_ENABLED()) { + int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; + Tcl_Obj *r = Tcl_GetObjResult(interp); + + TCL_DTRACE_PROC_RESULT(l < iPtr->varFramePtr->objc ? + TclGetString(iPtr->varFramePtr->objv[l]) : NULL, result, + TclGetString(r), r); + } + + freePtr = iPtr->framePtr; + Tcl_PopCallFrame(interp); /* Pop but do not free. */ + TclStackFree(interp, freePtr->compiledLocals); + /* Free compiledLocals. */ + TclStackFree(interp, freePtr); /* Free CallFrame. */ + return result; + + /* + * Process any non-TCL_OK result code. + */ + + process: switch (result) { case TCL_RETURN: /* @@ -1892,46 +1849,8 @@ InterpProcNR2( */ errorProc(interp, procNameObj); - - default: - /* - * Process other results (OK and non-standard) by doing nothing - * special, skipping directly to the code afterwards that cleans up - * associated memory. - * - * Non-standard results are processed by passing them through quickly. - * This means they all work as exceptions, unwinding the stack quickly - * and neatly. Who knows how well they are handled by third-party code - * though... - */ - - (void) 0; /* do nothing */ } - - if (TCL_DTRACE_PROC_RESULT_ENABLED()) { - int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; - Tcl_Obj *r = Tcl_GetObjResult(interp); - - TCL_DTRACE_PROC_RESULT(l < iPtr->varFramePtr->objc ? - TclGetString(iPtr->varFramePtr->objv[l]) : NULL, result, - TclGetString(r), r); - } - - /* - * Free the stack-allocated compiled locals and CallFrame. It is important - * to pop the call frame without freeing it first: the compiledLocals - * cannot be freed before the frame is popped, as the local variables must - * be deleted. But the compiledLocals must be freed first, as they were - * allocated later on the stack. - */ - - freePtr = iPtr->framePtr; - Tcl_PopCallFrame(interp); /* Pop but do not free. */ - TclStackFree(interp, freePtr->compiledLocals); - /* Free compiledLocals. */ - TclStackFree(interp, freePtr); /* Free CallFrame. */ - - return result; + goto done; } /* @@ -2071,7 +1990,7 @@ TclProcCompileProc( procPtr->numCompiledLocals = procPtr->numArgs; } - TclPushStackFrame(interp, &framePtr, (Tcl_Namespace *) nsPtr, + (void) TclPushStackFrame(interp, &framePtr, (Tcl_Namespace *) nsPtr, /* isProcCallFrame */ 0); /* @@ -2128,7 +2047,7 @@ MakeProcError( * messages and trace information. */ { int overflow, limit = 60, nameLen; - const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen); + const char *procName = TclGetStringFromObj(procNameObj, &nameLen); overflow = (nameLen > limit); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( @@ -2163,8 +2082,7 @@ TclProcDeleteProc( { Proc *procPtr = clientData; - procPtr->refCount--; - if (procPtr->refCount <= 0) { + if (procPtr->refCount-- <= 1) { TclProcCleanupProc(procPtr); } } @@ -2419,7 +2337,7 @@ ProcBodyFree( { Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1; - if (procPtr->refCount-- < 2) { + if (procPtr->refCount-- <= 1) { TclProcCleanupProc(procPtr); } } @@ -2451,7 +2369,7 @@ DupLambdaInternalRep( procPtr->refCount++; Tcl_IncrRefCount(nsObjPtr); - copyPtr->typePtr = &lambdaType; + copyPtr->typePtr = &tclLambdaType; } static void @@ -2462,8 +2380,7 @@ FreeLambdaInternalRep( Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1; Tcl_Obj *nsObjPtr = objPtr->internalRep.twoPtrValue.ptr2; - procPtr->refCount--; - if (procPtr->refCount == 0) { + if (procPtr->refCount-- <= 1) { TclProcCleanupProc(procPtr); } TclDecrRefCount(nsObjPtr); @@ -2488,7 +2405,7 @@ SetLambdaFromAny( /* * Convert objPtr to list type first; if it cannot be converted, or if its - * length is not 2, then it cannot be converted to lambdaType. + * length is not 2, then it cannot be converted to tclLambdaType. */ result = TclListObjGetElements(NULL, objPtr, &objc, &objv); @@ -2634,14 +2551,14 @@ SetLambdaFromAny( /* * Free the list internalrep of objPtr - this will free argsPtr, but * bodyPtr retains a reference from the Proc structure. Then finish the - * conversion to lambdaType. + * conversion to tclLambdaType. */ TclFreeIntRep(objPtr); objPtr->internalRep.twoPtrValue.ptr1 = procPtr; objPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr; - objPtr->typePtr = &lambdaType; + objPtr->typePtr = &tclLambdaType; return TCL_OK; } @@ -2682,7 +2599,7 @@ TclNRApplyObjCmd( Interp *iPtr = (Interp *) interp; Proc *procPtr = NULL; Tcl_Obj *lambdaPtr, *nsObjPtr; - int result, isRootEnsemble; + int result; Tcl_Namespace *nsPtr; ApplyExtraData *extraPtr; @@ -2692,39 +2609,15 @@ TclNRApplyObjCmd( } /* - * Set lambdaPtr, convert it to lambdaType in the current interp if + * Set lambdaPtr, convert it to tclLambdaType in the current interp if * necessary. */ lambdaPtr = objv[1]; - if (lambdaPtr->typePtr == &lambdaType) { + if (lambdaPtr->typePtr == &tclLambdaType) { procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1; } -#define JOE_EXTENSION 0 -/* - * Note: this code is NOT FUNCTIONAL due to the NR implementation; DO NOT - * ENABLE! Leaving here as reminder to (a) TIP the suggestion, and (b) adapt - * the code. (MS) - */ - -#if JOE_EXTENSION - else { - /* - * Joe English's suggestion to allow cmdNames to function as lambdas. - */ - - Tcl_Obj *elemPtr; - int numElem; - - if ((lambdaPtr->typePtr == &tclCmdNameType) || - (TclListObjGetElements(interp, lambdaPtr, &numElem, - &elemPtr) == TCL_OK && numElem == 1)) { - return Tcl_EvalObjv(interp, objc-1, objv+1, 0); - } - } -#endif - if ((procPtr == NULL) || (procPtr->iPtr != iPtr)) { result = SetLambdaFromAny(interp, lambdaPtr); if (result != TCL_OK) { @@ -2765,17 +2658,7 @@ TclNRApplyObjCmd( extraPtr->efi.fields[0].clientData = lambdaPtr; extraPtr->cmd.clientData = &extraPtr->efi; - isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL); - if (isRootEnsemble) { - iPtr->ensembleRewrite.sourceObjs = objv; - iPtr->ensembleRewrite.numRemovedObjs = 1; - iPtr->ensembleRewrite.numInsertedObjs = 0; - } else { - iPtr->ensembleRewrite.numInsertedObjs -= 1; - } - extraPtr->isRootEnsemble = isRootEnsemble; - - result = PushProcCallFrame(procPtr, interp, objc, objv, 1); + result = TclPushProcCallFrame(procPtr, interp, objc, objv, 1); if (result == TCL_OK) { TclNRAddCallback(interp, ApplyNR2, extraPtr, NULL, NULL, NULL); result = TclNRInterpProcCore(interp, objv[1], 2, &MakeLambdaError); @@ -2791,10 +2674,6 @@ ApplyNR2( { ApplyExtraData *extraPtr = data[0]; - if (extraPtr->isRootEnsemble) { - ((Interp *) interp)->ensembleRewrite.sourceObjs = NULL; - } - TclStackFree(interp, extraPtr); return result; } @@ -2825,7 +2704,7 @@ MakeLambdaError( * messages and trace information. */ { int overflow, limit = 60, nameLen; - const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen); + const char *procName = TclGetStringFromObj(procNameObj, &nameLen); overflow = (nameLen > limit); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( @@ -2837,229 +2716,36 @@ MakeLambdaError( /* *---------------------------------------------------------------------- * - * Tcl_DisassembleObjCmd -- + * TclGetCmdFrameForProcedure -- * - * Implementation of the "::tcl::unsupported::disassemble" command. This - * command is not documented, but will disassemble procedures, lambda - * terms and general scripts. Note that will compile terms if necessary - * in order to disassemble them. + * How to get the CmdFrame information for a procedure. + * + * Results: + * A pointer to the CmdFrame (only guaranteed to be valid until the next + * Tcl command is processed or the interpreter's state is otherwise + * modified) or a NULL if the information is not available. + * + * Side effects: + * none. * *---------------------------------------------------------------------- */ -int -Tcl_DisassembleObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +CmdFrame * +TclGetCmdFrameForProcedure( + Proc *procPtr) /* The procedure whose cmd-frame is to be + * looked up. */ { - static const char *const types[] = { - "lambda", "method", "objmethod", "proc", "script", NULL - }; - enum Types { - DISAS_LAMBDA, DISAS_CLASS_METHOD, DISAS_OBJECT_METHOD, DISAS_PROC, - DISAS_SCRIPT - }; - int idx, result; - Tcl_Obj *codeObjPtr = NULL; - Proc *procPtr = NULL; - Tcl_HashEntry *hPtr; - Object *oPtr; + Tcl_HashEntry *hePtr; - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "type ..."); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[1], types, "type", 0, &idx)!=TCL_OK){ - return TCL_ERROR; - } - - switch ((enum Types) idx) { - case DISAS_LAMBDA: { - Command cmd; - Tcl_Obj *nsObjPtr; - Tcl_Namespace *nsPtr; - - /* - * Compile (if uncompiled) and disassemble a lambda term. - */ - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "lambdaTerm"); - return TCL_ERROR; - } - if (objv[2]->typePtr == &lambdaType) { - procPtr = objv[2]->internalRep.twoPtrValue.ptr1; - } - if (procPtr == NULL || procPtr->iPtr != (Interp *) interp) { - result = SetLambdaFromAny(interp, objv[2]); - if (result != TCL_OK) { - return result; - } - procPtr = objv[2]->internalRep.twoPtrValue.ptr1; - } - - memset(&cmd, 0, sizeof(Command)); - nsObjPtr = objv[2]->internalRep.twoPtrValue.ptr2; - result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); - if (result != TCL_OK) { - return result; - } - cmd.nsPtr = (Namespace *) nsPtr; - procPtr->cmdPtr = &cmd; - result = PushProcCallFrame(procPtr, interp, objc, objv, 1); - if (result != TCL_OK) { - return result; - } - TclPopStackFrame(interp); - codeObjPtr = procPtr->bodyPtr; - break; - } - case DISAS_PROC: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "procName"); - return TCL_ERROR; - } - - procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2])); - if (procPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" isn't a procedure", TclGetString(objv[2]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROC", - TclGetString(objv[2]), NULL); - return TCL_ERROR; - } - - /* - * Compile (if uncompiled) and disassemble a procedure. - */ - - result = PushProcCallFrame(procPtr, interp, 2, objv+1, 1); - if (result != TCL_OK) { - return result; - } - TclPopStackFrame(interp); - codeObjPtr = procPtr->bodyPtr; - break; - case DISAS_SCRIPT: - /* - * Compile and disassemble a script. - */ - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "script"); - return TCL_ERROR; - } - if ((objv[2]->typePtr != &tclByteCodeType) - && (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK)) { - return TCL_ERROR; - } - codeObjPtr = objv[2]; - break; - - case DISAS_CLASS_METHOD: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "className methodName"); - return TCL_ERROR; - } - - /* - * Look up the body of a class method. - */ - - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); - if (oPtr == NULL) { - return TCL_ERROR; - } - if (oPtr->classPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" is not a class", TclGetString(objv[2]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", - TclGetString(objv[2]), NULL); - return TCL_ERROR; - } - hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, - (char *) objv[3]); - goto methodBody; - case DISAS_OBJECT_METHOD: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "objectName methodName"); - return TCL_ERROR; - } - - /* - * Look up the body of an instance method. - */ - - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); - if (oPtr == NULL) { - return TCL_ERROR; - } - if (oPtr->methodsPtr == NULL) { - goto unknownMethod; - } - hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[3]); - - /* - * Compile (if necessary) and disassemble a method body. - */ - - methodBody: - if (hPtr == NULL) { - unknownMethod: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unknown method \"%s\"", TclGetString(objv[3]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(objv[3]), NULL); - return TCL_ERROR; - } - procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr)); - if (procPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "body not available for this kind of method", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", - "METHODTYPE", NULL); - return TCL_ERROR; - } - if (procPtr->bodyPtr->typePtr != &tclByteCodeType) { - Command cmd; - - /* - * Yes, this is ugly, but we need to pass the namespace in to the - * compiler in two places. - */ - - cmd.nsPtr = (Namespace *) oPtr->namespacePtr; - procPtr->cmdPtr = &cmd; - result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, - (Namespace *) oPtr->namespacePtr, "body of method", - TclGetString(objv[3])); - procPtr->cmdPtr = NULL; - if (result != TCL_OK) { - return result; - } - } - codeObjPtr = procPtr->bodyPtr; - break; - default: - CLANG_ASSERT(0); + if (procPtr == NULL || procPtr->iPtr == NULL) { + return NULL; } - - /* - * Do the actual disassembly. - */ - - if (((ByteCode *) codeObjPtr->internalRep.twoPtrValue.ptr1)->flags - & TCL_BYTECODE_PRECOMPILED) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "may not disassemble prebuilt bytecode", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", - "BYTECODE", NULL); - return TCL_ERROR; + hePtr = Tcl_FindHashEntry(procPtr->iPtr->linePBodyPtr, procPtr); + if (hePtr == NULL) { + return NULL; } - Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(codeObjPtr)); - return TCL_OK; + return (CmdFrame *) Tcl_GetHashValue(hePtr); } /* diff --git a/generic/tclProcess.c b/generic/tclProcess.c new file mode 100644 index 0000000..a781386 --- /dev/null +++ b/generic/tclProcess.c @@ -0,0 +1,957 @@ +/* + * tclProcess.c -- + * + * This file implements the "tcl::process" ensemble for subprocess + * management as defined by TIP #462. + * + * Copyright (c) 2017 Frederic Bonnet. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tclInt.h" + +/* + * Autopurge flag. Process-global because of the way Tcl manages child + * processes (see tclPipe.c). + */ + +static int autopurge = 1; /* Autopurge flag. */ + +/* + * Hash tables that keeps track of all child process statuses. Keys are the + * child process ids and resolved pids, values are (ProcessInfo *). + */ + +typedef struct ProcessInfo { + Tcl_Pid pid; /* Process id. */ + int resolvedPid; /* Resolved process id. */ + int purge; /* Purge eventualy. */ + TclProcessWaitStatus status;/* Process status. */ + int code; /* Error code, exit status or signal + number. */ + Tcl_Obj *msg; /* Error message. */ + Tcl_Obj *error; /* Error code. */ +} ProcessInfo; +static Tcl_HashTable infoTablePerPid; +static Tcl_HashTable infoTablePerResolvedPid; +static int infoTablesInitialized = 0; /* 0 means not yet initialized. */ +TCL_DECLARE_MUTEX(infoTablesMutex) + + /* + * Prototypes for functions defined later in this file: + */ + +static void InitProcessInfo(ProcessInfo *info, Tcl_Pid pid, + int resolvedPid); +static void FreeProcessInfo(ProcessInfo *info); +static int RefreshProcessInfo(ProcessInfo *info, int options); +static TclProcessWaitStatus WaitProcessStatus(Tcl_Pid pid, int resolvedPid, + int options, int *codePtr, Tcl_Obj **msgPtr, + Tcl_Obj **errorObjPtr); +static Tcl_Obj * BuildProcessStatusObj(ProcessInfo *info); +static int ProcessListObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int ProcessStatusObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int ProcessPurgeObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int ProcessAutopurgeObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); + +/* + *---------------------------------------------------------------------- + * + * InitProcessInfo -- + * + * Initializes the ProcessInfo structure. + * + * Results: + * None. + * + * Side effects: + * Memory written. + * + *---------------------------------------------------------------------- + */ + +void +InitProcessInfo( + ProcessInfo *info, /* Structure to initialize. */ + Tcl_Pid pid, /* Process id. */ + int resolvedPid) /* Resolved process id. */ +{ + info->pid = pid; + info->resolvedPid = resolvedPid; + info->purge = 0; + info->status = TCL_PROCESS_UNCHANGED; + info->code = 0; + info->msg = NULL; + info->error = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * FreeProcessInfo -- + * + * Free the ProcessInfo structure. + * + * Results: + * None. + * + * Side effects: + * Memory deallocated, Tcl_Obj refcount decreased. + * + *---------------------------------------------------------------------- + */ + +void +FreeProcessInfo( + ProcessInfo *info) /* Structure to free. */ +{ + /* + * Free stored Tcl_Objs. + */ + + if (info->msg) { + Tcl_DecrRefCount(info->msg); + } + if (info->error) { + Tcl_DecrRefCount(info->error); + } + + /* + * Free allocated structure. + */ + + ckfree(info); +} + +/* + *---------------------------------------------------------------------- + * + * RefreshProcessInfo -- + * + * Refresh process info. + * + * Results: + * Nonzero if state changed, else zero. + * + * Side effects: + * May call WaitProcessStatus, which can block if WNOHANG option is set. + * + *---------------------------------------------------------------------- + */ + +int +RefreshProcessInfo( + ProcessInfo *info, /* Structure to refresh. */ + int options /* Options passed to WaitProcessStatus. */ +) +{ + if (info->status == TCL_PROCESS_UNCHANGED) { + /* + * Refresh & store status. + */ + + info->status = WaitProcessStatus(info->pid, info->resolvedPid, + options, &info->code, &info->msg, &info->error); + if (info->msg) Tcl_IncrRefCount(info->msg); + if (info->error) Tcl_IncrRefCount(info->error); + return (info->status != TCL_PROCESS_UNCHANGED); + } else { + /* + * No change. + */ + + return 0; + } +} + +/* + *---------------------------------------------------------------------- + * + * WaitProcessStatus -- + * + * Wait for process status to change. + * + * Results: + * TclProcessWaitStatus enum value. + * + * Side effects: + * May call WaitProcessStatus, which can block if WNOHANG option is set. + * + *---------------------------------------------------------------------- + */ + +TclProcessWaitStatus +WaitProcessStatus( + Tcl_Pid pid, /* Process id. */ + int resolvedPid, /* Resolved process id. */ + int options, /* Options passed to Tcl_WaitPid. */ + int *codePtr, /* If non-NULL, will receive either: + * - 0 for normal exit. + * - errno in case of error. + * - non-zero exit code for abormal exit. + * - signal number if killed or suspended. + * - Tcl_WaitPid status in all other cases. + */ + Tcl_Obj **msgObjPtr, /* If non-NULL, will receive error message. */ + Tcl_Obj **errorObjPtr) /* If non-NULL, will receive error code. */ +{ + int waitStatus; + Tcl_Obj *errorStrings[5]; + const char *msg; + + pid = Tcl_WaitPid(pid, &waitStatus, options); + if (pid == 0) { + /* + * No change. + */ + + return TCL_PROCESS_UNCHANGED; + } + + /* + * Get process status. + */ + + if (pid == (Tcl_Pid) -1) { + /* + * POSIX errName msg + */ + + msg = Tcl_ErrnoMsg(errno); + if (errno == ECHILD) { + /* + * This changeup in message suggested by Mark Diekhans to + * remind people that ECHILD errors can occur on some + * systems if SIGCHLD isn't in its default state. + */ + + msg = "child process lost (is SIGCHLD ignored or trapped?)"; + } + if (codePtr) *codePtr = errno; + if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf( + "error waiting for process to exit: %s", msg); + if (errorObjPtr) { + errorStrings[0] = Tcl_NewStringObj("POSIX", -1); + errorStrings[1] = Tcl_NewStringObj(Tcl_ErrnoId(), -1); + errorStrings[2] = Tcl_NewStringObj(msg, -1); + *errorObjPtr = Tcl_NewListObj(3, errorStrings); + } + return TCL_PROCESS_ERROR; + } else if (WIFEXITED(waitStatus)) { + if (codePtr) *codePtr = WEXITSTATUS(waitStatus); + if (!WEXITSTATUS(waitStatus)) { + /* + * Normal exit. + */ + + if (msgObjPtr) *msgObjPtr = NULL; + if (errorObjPtr) *errorObjPtr = NULL; + } else { + /* + * CHILDSTATUS pid code + * + * Child exited with a non-zero exit status. + */ + + if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj( + "child process exited abnormally", -1); + if (errorObjPtr) { + errorStrings[0] = Tcl_NewStringObj("CHILDSTATUS", -1); + errorStrings[1] = Tcl_NewIntObj(resolvedPid); + errorStrings[2] = Tcl_NewIntObj(WEXITSTATUS(waitStatus)); + *errorObjPtr = Tcl_NewListObj(3, errorStrings); + } + } + return TCL_PROCESS_EXITED; + } else if (WIFSIGNALED(waitStatus)) { + /* + * CHILDKILLED pid sigName msg + * + * Child killed because of a signal. + */ + + msg = Tcl_SignalMsg(WTERMSIG(waitStatus)); + if (codePtr) *codePtr = WTERMSIG(waitStatus); + if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf( + "child killed: %s", msg); + if (errorObjPtr) { + errorStrings[0] = Tcl_NewStringObj("CHILDKILLED", -1); + errorStrings[1] = Tcl_NewIntObj(resolvedPid); + errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WTERMSIG(waitStatus)), -1); + errorStrings[3] = Tcl_NewStringObj(msg, -1); + *errorObjPtr = Tcl_NewListObj(4, errorStrings); + } + return TCL_PROCESS_SIGNALED; + } else if (WIFSTOPPED(waitStatus)) { + /* + * CHILDSUSP pid sigName msg + * + * Child suspended because of a signal. + */ + + msg = Tcl_SignalMsg(WSTOPSIG(waitStatus)); + if (codePtr) *codePtr = WSTOPSIG(waitStatus); + if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf( + "child suspended: %s", msg); + if (errorObjPtr) { + errorStrings[0] = Tcl_NewStringObj("CHILDSUSP", -1); + errorStrings[1] = Tcl_NewIntObj(resolvedPid); + errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WSTOPSIG(waitStatus)), -1); + errorStrings[3] = Tcl_NewStringObj(msg, -1); + *errorObjPtr = Tcl_NewListObj(4, errorStrings); + } + return TCL_PROCESS_STOPPED; + } else { + /* + * TCL OPERATION EXEC ODDWAITRESULT + * + * Child wait status didn't make sense. + */ + + if (codePtr) *codePtr = waitStatus; + if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj( + "child wait status didn't make sense\n", -1); + if (errorObjPtr) { + errorStrings[0] = Tcl_NewStringObj("TCL", -1); + errorStrings[1] = Tcl_NewStringObj("OPERATION", -1); + errorStrings[2] = Tcl_NewStringObj("EXEC", -1); + errorStrings[3] = Tcl_NewStringObj("ODDWAITRESULT", -1); + errorStrings[4] = Tcl_NewIntObj(resolvedPid); + *errorObjPtr = Tcl_NewListObj(5, errorStrings); + } + return TCL_PROCESS_UNKNOWN_STATUS; + } +} + + +/* + *---------------------------------------------------------------------- + * + * BuildProcessStatusObj -- + * + * Build a list object with process status. The first element is always + * a standard Tcl return value, which can be either TCL_OK or TCL_ERROR. + * In the latter case, the second element is the error message and the + * third element is a Tcl error code (see tclvars). + * + * Results: + * A list object. + * + * Side effects: + * Tcl_Objs are created. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +BuildProcessStatusObj( + ProcessInfo *info) +{ + Tcl_Obj *resultObjs[3]; + + if (info->status == TCL_PROCESS_UNCHANGED) { + /* + * Process still running, return empty obj. + */ + + return Tcl_NewObj(); + } + if (info->status == TCL_PROCESS_EXITED && info->code == 0) { + /* + * Normal exit, return TCL_OK. + */ + + return Tcl_NewIntObj(TCL_OK); + } + + /* + * Abnormal exit, return {TCL_ERROR msg error} + */ + + resultObjs[0] = Tcl_NewIntObj(TCL_ERROR); + resultObjs[1] = info->msg; + resultObjs[2] = info->error; + return Tcl_NewListObj(3, resultObjs); +} + +/*---------------------------------------------------------------------- + * + * ProcessListObjCmd -- + * + * This function implements the 'tcl::process list' Tcl command. + * Refer to the user documentation for details on what it does. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Access to the internal structures is protected by infoTablesMutex. + * + *---------------------------------------------------------------------- + */ + +static int +ProcessListObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Obj *list; + Tcl_HashEntry *entry; + Tcl_HashSearch search; + ProcessInfo *info; + + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return TCL_ERROR; + } + + /* + * Return the list of all chid process ids. + */ + + list = Tcl_NewListObj(0, NULL); + Tcl_MutexLock(&infoTablesMutex); + for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); + entry != NULL; entry = Tcl_NextHashEntry(&search)) { + info = (ProcessInfo *) Tcl_GetHashValue(entry); + Tcl_ListObjAppendElement(interp, list, + Tcl_NewIntObj(info->resolvedPid)); + } + Tcl_MutexUnlock(&infoTablesMutex); + Tcl_SetObjResult(interp, list); + return TCL_OK; +} + +/*---------------------------------------------------------------------- + * + * ProcessStatusObjCmd -- + * + * This function implements the 'tcl::process status' Tcl command. + * Refer to the user documentation for details on what it does. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Access to the internal structures is protected by infoTablesMutex. + * Calls RefreshProcessInfo, which can block if -wait switch is given. + * + *---------------------------------------------------------------------- + */ + +static int +ProcessStatusObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Obj *dict; + int index, options = WNOHANG; + Tcl_HashEntry *entry; + Tcl_HashSearch search; + ProcessInfo *info; + int numPids; + Tcl_Obj **pidObjs; + int result; + int i; + int pid; + Tcl_Obj *const *savedobjv = objv; + static const char *const switches[] = { + "-wait", "--", NULL + }; + enum switches { + STATUS_WAIT, STATUS_LAST + }; + + while (objc > 1) { + if (TclGetString(objv[1])[0] != '-') { + break; + } + if (Tcl_GetIndexFromObj(interp, objv[1], switches, "switches", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + ++objv; --objc; + if (STATUS_WAIT == (enum switches) index) { + options = 0; + } else { + break; + } + } + + if (objc != 1 && objc != 2) { + Tcl_WrongNumArgs(interp, 1, savedobjv, "?switches? ?pids?"); + return TCL_ERROR; + } + + if (objc == 1) { + /* + * Return a dict with all child process statuses. + */ + + dict = Tcl_NewDictObj(); + Tcl_MutexLock(&infoTablesMutex); + for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); + entry != NULL; entry = Tcl_NextHashEntry(&search)) { + info = (ProcessInfo *) Tcl_GetHashValue(entry); + RefreshProcessInfo(info, options); + + if (info->purge && autopurge) { + /* + * Purge entry. + */ + + Tcl_DeleteHashEntry(entry); + entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); + Tcl_DeleteHashEntry(entry); + FreeProcessInfo(info); + } else { + /* + * Add to result. + */ + + Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), + BuildProcessStatusObj(info)); + } + } + Tcl_MutexUnlock(&infoTablesMutex); + } else { + /* + * Only return statuses of provided processes. + */ + + result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs); + if (result != TCL_OK) { + return result; + } + dict = Tcl_NewDictObj(); + Tcl_MutexLock(&infoTablesMutex); + for (i = 0; i < numPids; i++) { + result = Tcl_GetIntFromObj(interp, pidObjs[i], (int *) &pid); + if (result != TCL_OK) { + Tcl_MutexUnlock(&infoTablesMutex); + Tcl_DecrRefCount(dict); + return result; + } + + entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(pid)); + if (!entry) { + /* + * Skip unknown process. + */ + + continue; + } + + info = (ProcessInfo *) Tcl_GetHashValue(entry); + RefreshProcessInfo(info, options); + + if (info->purge && autopurge) { + /* + * Purge entry. + */ + + Tcl_DeleteHashEntry(entry); + entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); + Tcl_DeleteHashEntry(entry); + FreeProcessInfo(info); + } else { + /* + * Add to result. + */ + + Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), + BuildProcessStatusObj(info)); + } + } + Tcl_MutexUnlock(&infoTablesMutex); + } + Tcl_SetObjResult(interp, dict); + return TCL_OK; +} + +/*---------------------------------------------------------------------- + * + * ProcessPurgeObjCmd -- + * + * This function implements the 'tcl::process purge' Tcl command. + * Refer to the user documentation for details on what it does. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Frees all ProcessInfo structures with their purge flag set. + * + *---------------------------------------------------------------------- + */ + +static int +ProcessPurgeObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_HashEntry *entry; + Tcl_HashSearch search; + ProcessInfo *info; + int numPids; + Tcl_Obj **pidObjs; + int result; + int i; + int pid; + + if (objc != 1 && objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?pids?"); + return TCL_ERROR; + } + + /* + * First reap detached procs so that their purge flag is up-to-date. + */ + + Tcl_ReapDetachedProcs(); + + if (objc == 1) { + /* + * Purge all terminated processes. + */ + + Tcl_MutexLock(&infoTablesMutex); + for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); + entry != NULL; entry = Tcl_NextHashEntry(&search)) { + info = (ProcessInfo *) Tcl_GetHashValue(entry); + if (info->purge) { + Tcl_DeleteHashEntry(entry); + entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); + Tcl_DeleteHashEntry(entry); + FreeProcessInfo(info); + } + } + Tcl_MutexUnlock(&infoTablesMutex); + } else { + /* + * Purge only provided processes. + */ + + result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs); + if (result != TCL_OK) { + return result; + } + Tcl_MutexLock(&infoTablesMutex); + for (i = 0; i < numPids; i++) { + result = Tcl_GetIntFromObj(interp, pidObjs[i], (int *) &pid); + if (result != TCL_OK) { + Tcl_MutexUnlock(&infoTablesMutex); + return result; + } + + entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(pid)); + if (!entry) { + /* + * Skip unknown process. + */ + + continue; + } + + info = (ProcessInfo *) Tcl_GetHashValue(entry); + if (info->purge) { + Tcl_DeleteHashEntry(entry); + entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); + Tcl_DeleteHashEntry(entry); + FreeProcessInfo(info); + } + } + Tcl_MutexUnlock(&infoTablesMutex); + } + + return TCL_OK; +} + +/*---------------------------------------------------------------------- + * + * ProcessAutopurgeObjCmd -- + * + * This function implements the 'tcl::process autopurge' Tcl command. + * Refer to the user documentation for details on what it does. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Alters detached process handling by Tcl_ReapDetachedProcs(). + * + *---------------------------------------------------------------------- + */ + +static int +ProcessAutopurgeObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + if (objc != 1 && objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?flag?"); + return TCL_ERROR; + } + + if (objc == 2) { + /* + * Set given value. + */ + + int flag; + int result = Tcl_GetBooleanFromObj(interp, objv[1], &flag); + if (result != TCL_OK) { + return result; + } + + autopurge = !!flag; + } + + /* + * Return current value. + */ + + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(autopurge)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclInitProcessCmd -- + * + * This procedure creates the "tcl::process" Tcl command. See the user + * documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +TclInitProcessCmd( + Tcl_Interp *interp) /* Current interpreter. */ +{ + static const EnsembleImplMap processImplMap[] = { + {"list", ProcessListObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1}, + {"status", ProcessStatusObjCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1}, + {"purge", ProcessPurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, + {"autopurge", ProcessAutopurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, + {NULL, NULL, NULL, NULL, NULL, 0} + }; + Tcl_Command processCmd; + + if (infoTablesInitialized == 0) { + Tcl_MutexLock(&infoTablesMutex); + if (infoTablesInitialized == 0) { + Tcl_InitHashTable(&infoTablePerPid, TCL_ONE_WORD_KEYS); + Tcl_InitHashTable(&infoTablePerResolvedPid, TCL_ONE_WORD_KEYS); + infoTablesInitialized = 1; + } + Tcl_MutexUnlock(&infoTablesMutex); + } + + processCmd = TclMakeEnsemble(interp, "::tcl::process", processImplMap); + Tcl_Export(interp, Tcl_FindNamespace(interp, "::tcl", NULL, 0), + "process", 0); + return processCmd; +} + +/* + *---------------------------------------------------------------------- + * + * TclProcessCreated -- + * + * Called when a child process has been created by Tcl. + * + * Results: + * None. + * + * Side effects: + * Internal structures are updated with a new ProcessInfo. + * + *---------------------------------------------------------------------- + */ + +void +TclProcessCreated( + Tcl_Pid pid) /* Process id. */ +{ + int resolvedPid; + Tcl_HashEntry *entry, *entry2; + int isNew; + ProcessInfo *info; + + /* + * Get resolved pid first. + */ + + resolvedPid = TclpGetPid(pid); + + Tcl_MutexLock(&infoTablesMutex); + + /* + * Create entry in pid table. + */ + + entry = Tcl_CreateHashEntry(&infoTablePerPid, pid, &isNew); + if (!isNew) { + /* + * Pid was reused, free old info and reuse structure. + */ + + info = (ProcessInfo *) Tcl_GetHashValue(entry); + entry2 = Tcl_FindHashEntry(&infoTablePerResolvedPid, + INT2PTR(resolvedPid)); + if (entry2) Tcl_DeleteHashEntry(entry2); + FreeProcessInfo(info); + } + + /* + * Allocate and initialize info structure. + */ + + info = (ProcessInfo *) ckalloc(sizeof(ProcessInfo)); + InitProcessInfo(info, pid, resolvedPid); + + /* + * Add entry to tables. + */ + + Tcl_SetHashValue(entry, info); + entry = Tcl_CreateHashEntry(&infoTablePerResolvedPid, INT2PTR(resolvedPid), + &isNew); + Tcl_SetHashValue(entry, info); + + Tcl_MutexUnlock(&infoTablesMutex); +} + +/* + *---------------------------------------------------------------------- + * + * TclProcessWait -- + * + * Wait for process status to change. + * + * Results: + * TclProcessWaitStatus enum value. + * + * Side effects: + * Completed process info structures are purged immediately (autopurge on) + * or eventually (autopurge off). + * + *---------------------------------------------------------------------- + */ + +TclProcessWaitStatus +TclProcessWait( + Tcl_Pid pid, /* Process id. */ + int options, /* Options passed to WaitProcessStatus. */ + int *codePtr, /* If non-NULL, will receive either: + * - 0 for normal exit. + * - errno in case of error. + * - non-zero exit code for abormal exit. + * - signal number if killed or suspended. + * - Tcl_WaitPid status in all other cases. + */ + Tcl_Obj **msgObjPtr, /* If non-NULL, will receive error message. */ + Tcl_Obj **errorObjPtr) /* If non-NULL, will receive error code. */ +{ + Tcl_HashEntry *entry; + ProcessInfo *info; + TclProcessWaitStatus result; + + /* + * First search for pid in table. + */ + + Tcl_MutexLock(&infoTablesMutex); + entry = Tcl_FindHashEntry(&infoTablePerPid, pid); + if (!entry) { + /* + * Unknown process, just call WaitProcessStatus and return. + */ + + result = WaitProcessStatus(pid, TclpGetPid(pid), options, codePtr, + msgObjPtr, errorObjPtr); + if (msgObjPtr && *msgObjPtr) Tcl_IncrRefCount(*msgObjPtr); + if (errorObjPtr && *errorObjPtr) Tcl_IncrRefCount(*errorObjPtr); + Tcl_MutexUnlock(&infoTablesMutex); + return result; + } + + info = (ProcessInfo *) Tcl_GetHashValue(entry); + if (info->purge) { + /* + * Process has completed but TclProcessWait has already been called, + * so report no change. + */ + Tcl_MutexUnlock(&infoTablesMutex); + + return TCL_PROCESS_UNCHANGED; + } + + RefreshProcessInfo(info, options); + if (info->status == TCL_PROCESS_UNCHANGED) { + /* + * No change, stop there. + */ + Tcl_MutexUnlock(&infoTablesMutex); + + return TCL_PROCESS_UNCHANGED; + } + + /* + * Set return values. + */ + + result = info->status; + if (codePtr) *codePtr = info->code; + if (msgObjPtr) *msgObjPtr = info->msg; + if (errorObjPtr) *errorObjPtr = info->error; + if (msgObjPtr && *msgObjPtr) Tcl_IncrRefCount(*msgObjPtr); + if (errorObjPtr && *errorObjPtr) Tcl_IncrRefCount(*errorObjPtr); + + if (autopurge) { + /* + * Purge now. + */ + + Tcl_DeleteHashEntry(entry); + entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, + INT2PTR(info->resolvedPid)); + Tcl_DeleteHashEntry(entry); + FreeProcessInfo(info); + } else { + /* + * Eventually purge. Subsequent calls will return + * TCL_PROCESS_UNCHANGED. + */ + + info->purge = 1; + } + Tcl_MutexUnlock(&infoTablesMutex); + return result; +} diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c index 6348e4a..5f8dc20 100644 --- a/generic/tclRegexp.c +++ b/generic/tclRegexp.c @@ -64,7 +64,7 @@ #define NUM_REGEXPS 30 -typedef struct ThreadSpecificData { +typedef struct { int initialized; /* Set to 1 when the module is initialized. */ char *patterns[NUM_REGEXPS];/* Strings corresponding to compiled regular * expression patterns. NULL means that this @@ -502,9 +502,16 @@ Tcl_RegExpMatchObj( { Tcl_RegExp re; - re = Tcl_GetRegExpFromObj(interp, patternObj, - TCL_REG_ADVANCED | TCL_REG_NOSUB); - if (re == NULL) { + /* + * For performance reasons, first try compiling the RE without support for + * subexpressions. On failure, try again without TCL_REG_NOSUB in case the + * RE has backreferences in it. Closely related to [Bug 1366683]. If this + * still fails, an error message will be left in the interpreter. + */ + + if (!(re = Tcl_GetRegExpFromObj(interp, patternObj, + TCL_REG_ADVANCED | TCL_REG_NOSUB)) + && !(re = Tcl_GetRegExpFromObj(interp, patternObj, TCL_REG_ADVANCED))) { return -1; } return Tcl_RegExpExecObj(interp, re, textObj, 0 /* offset */, @@ -672,7 +679,7 @@ TclRegAbout( resultObj = Tcl_NewObj(); Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewIntObj((int) regexpPtr->re.re_nsub)); + Tcl_NewWideIntObj((Tcl_WideInt) regexpPtr->re.re_nsub)); /* * Now append a list of all the bit-flags set for the RE. @@ -755,7 +762,7 @@ FreeRegexpInternalRep( * If this is the last reference to the regexp, free it. */ - if (--(regexpRepPtr->refCount) <= 0) { + if (regexpRepPtr->refCount-- <= 1) { FreeRegexp(regexpRepPtr); } objPtr->typePtr = NULL; @@ -946,7 +953,8 @@ CompileRegexp( * Tcl_RegExpExecObj to optionally do a fast match (avoids RE engine). */ - if (TclReToGlob(NULL, string, length, &stringBuf, &exact) == TCL_OK) { + if (TclReToGlob(NULL, string, length, &stringBuf, &exact, + NULL) == TCL_OK) { regexpPtr->globObjPtr = TclDStringToObj(&stringBuf); Tcl_IncrRefCount(regexpPtr->globObjPtr); } else { @@ -975,7 +983,7 @@ CompileRegexp( if (tsdPtr->patterns[NUM_REGEXPS-1] != NULL) { TclRegexp *oldRegexpPtr = tsdPtr->regexps[NUM_REGEXPS-1]; - if (--(oldRegexpPtr->refCount) <= 0) { + if (oldRegexpPtr->refCount-- <= 1) { FreeRegexp(oldRegexpPtr); } ckfree(tsdPtr->patterns[NUM_REGEXPS-1]); @@ -1049,7 +1057,7 @@ FinalizeRegexp( for (i = 0; (i < NUM_REGEXPS) && (tsdPtr->patterns[i] != NULL); i++) { regexpPtr = tsdPtr->regexps[i]; - if (--(regexpPtr->refCount) <= 0) { + if (regexpPtr->refCount-- <= 1) { FreeRegexp(regexpPtr); } ckfree(tsdPtr->patterns[i]); diff --git a/generic/tclRegexp.h b/generic/tclRegexp.h index 3b2433e..a263dfd 100644 --- a/generic/tclRegexp.h +++ b/generic/tclRegexp.h @@ -37,7 +37,7 @@ typedef struct TclRegexp { * of subexpressions. */ rm_detail_t details; /* Detailed information on match (currently * used only for REG_EXPECT). */ - int refCount; /* Count of number of references to this + size_t refCount; /* Count of number of references to this * compiled regexp. */ } TclRegexp; diff --git a/generic/tclResult.c b/generic/tclResult.c index 2f2563a..a5ec4be 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -27,7 +27,9 @@ enum returnKeys { static Tcl_Obj ** GetKeys(void); static void ReleaseKeys(ClientData clientData); static void ResetObjResult(Interp *iPtr); +#ifndef TCL_NO_DEPRECATED static void SetupAppendBuffer(Interp *iPtr, int newSpace); +#endif /* !TCL_NO_DEPRECATED */ /* * This structure is used to take a snapshot of the interpreter state in @@ -35,7 +37,7 @@ static void SetupAppendBuffer(Interp *iPtr, int newSpace); * then back up to the result or the error that was previously in progress. */ -typedef struct InterpState { +typedef struct { int status; /* return code status */ int flags; /* Each remaining field saves the */ int returnLevel; /* corresponding field of the Interp */ @@ -230,6 +232,7 @@ Tcl_DiscardInterpState( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_SaveResult void Tcl_SaveResult( @@ -461,6 +464,7 @@ Tcl_SetResult( ResetObjResult(iPtr); } +#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -483,18 +487,21 @@ const char * Tcl_GetStringResult( register Tcl_Interp *interp)/* Interpreter whose result to return. */ { + Interp *iPtr = (Interp *) interp; +#ifdef TCL_NO_DEPRECATED + return Tcl_GetString(iPtr->objResultPtr); +#else /* * If the string result is empty, move the object result to the string * result, then reset the object result. */ - Interp *iPtr = (Interp *) interp; - if (*(iPtr->result) == 0) { Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), TCL_VOLATILE); } return iPtr->result; +#endif } /* @@ -536,6 +543,7 @@ Tcl_SetObjResult( TclDecrRefCount(oldObjResult); +#ifndef TCL_NO_DEPRECATED /* * Reset the string result since we just set the result object. */ @@ -550,6 +558,7 @@ Tcl_SetObjResult( } iPtr->result = iPtr->resultSpace; iPtr->resultSpace[0] = 0; +#endif } /* @@ -578,6 +587,7 @@ Tcl_GetObjResult( Tcl_Interp *interp) /* Interpreter whose result to return. */ { register Interp *iPtr = (Interp *) interp; +#ifndef TCL_NO_DEPRECATED Tcl_Obj *objResultPtr; int length; @@ -604,6 +614,7 @@ Tcl_GetObjResult( iPtr->result = iPtr->resultSpace; iPtr->result[0] = 0; } +#endif /* !TCL_NO_DEPRECATED */ return iPtr->objResultPtr; } @@ -640,23 +651,6 @@ Tcl_AppendResultVA( } Tcl_AppendStringsToObjVA(objPtr, argList); Tcl_SetObjResult(interp, objPtr); - - /* - * Strictly we should call Tcl_GetStringResult(interp) here to make sure - * that interp->result is correct according to the old contract, but that - * makes the performance of much code (e.g. in Tk) absolutely awful. So we - * leave it out; code that really wants interp->result can just insert the - * calls to Tcl_GetStringResult() itself. [Patch 1041072 discussion] - */ - -#ifdef USE_INTERP_RESULT - /* - * Ensure that the interp->result is legal so old Tcl 7.* code still - * works. There's still embarrasingly much of it about... - */ - - (void) Tcl_GetStringResult(interp); -#endif /* USE_INTERP_RESULT */ } /* @@ -722,6 +716,21 @@ Tcl_AppendElement( * to result. */ { Interp *iPtr = (Interp *) interp; +#ifdef TCL_NO_DEPRECATED + Tcl_Obj *elementPtr = Tcl_NewStringObj(element, -1); + Tcl_Obj *listPtr = Tcl_NewListObj(1, &elementPtr); + const char *bytes; + + if (Tcl_IsShared(iPtr->objResultPtr)) { + Tcl_SetObjResult(interp, Tcl_DuplicateObj(iPtr->objResultPtr)); + } + bytes = TclGetString(iPtr->objResultPtr); + if (TclNeedSpace(bytes, bytes+iPtr->objResultPtr->length)) { + Tcl_AppendToObj(iPtr->objResultPtr, " ", 1); + } + Tcl_AppendObjToObj(iPtr->objResultPtr, listPtr); + Tcl_DecrRefCount(listPtr); +#else char *dst; int size; int flags; @@ -765,6 +774,7 @@ Tcl_AppendElement( flags |= TCL_DONT_QUOTE_HASH; } iPtr->appendUsed += Tcl_ConvertElement(element, dst, flags); +#endif /* !TCL_NO_DEPRECATED */ } /* @@ -786,6 +796,7 @@ Tcl_AppendElement( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED static void SetupAppendBuffer( Interp *iPtr, /* Interpreter whose result is being set up. */ @@ -846,6 +857,7 @@ SetupAppendBuffer( Tcl_FreeResult((Tcl_Interp *) iPtr); iPtr->result = iPtr->appendResult; } +#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -875,6 +887,7 @@ Tcl_FreeResult( { register Interp *iPtr = (Interp *) interp; +#ifndef TCL_NO_DEPRECATED if (iPtr->freeProc != NULL) { if (iPtr->freeProc == TCL_DYNAMIC) { ckfree(iPtr->result); @@ -884,6 +897,7 @@ Tcl_FreeResult( iPtr->freeProc = 0; } +#endif /* !TCL_NO_DEPRECATED */ ResetObjResult(iPtr); } @@ -913,6 +927,7 @@ Tcl_ResetResult( register Interp *iPtr = (Interp *) interp; ResetObjResult(iPtr); +#ifndef TCL_NO_DEPRECATED if (iPtr->freeProc != NULL) { if (iPtr->freeProc == TCL_DYNAMIC) { ckfree(iPtr->result); @@ -923,6 +938,7 @@ Tcl_ResetResult( } iPtr->result = iPtr->resultSpace; iPtr->resultSpace[0] = 0; +#endif /* !TCL_NO_DEPRECATED */ if (iPtr->errorCode) { /* Legacy support */ if (iPtr->flags & ERR_LEGACY_COPY) { @@ -982,11 +998,11 @@ ResetObjResult( Tcl_IncrRefCount(objResultPtr); iPtr->objResultPtr = objResultPtr; } else { - if (objResultPtr->bytes != tclEmptyStringRep) { + if (objResultPtr->bytes != &tclEmptyString) { if (objResultPtr->bytes) { ckfree(objResultPtr->bytes); } - objResultPtr->bytes = tclEmptyStringRep; + objResultPtr->bytes = &tclEmptyString; objResultPtr->length = 0; } TclFreeIntRep(objResultPtr); @@ -1276,10 +1292,8 @@ TclProcessReturn( Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO], &valuePtr); if (valuePtr != NULL) { - int infoLen; - - (void) TclGetStringFromObj(valuePtr, &infoLen); - if (infoLen) { + (void) TclGetString(valuePtr); + if (valuePtr->length) { iPtr->errorInfo = valuePtr; Tcl_IncrRefCount(iPtr->errorInfo); iPtr->flags |= ERR_ALREADY_LOGGED; @@ -1293,7 +1307,7 @@ TclProcessReturn( if (Tcl_IsShared(iPtr->errorStack)) { Tcl_Obj *newObj; - + newObj = Tcl_DuplicateObj(iPtr->errorStack); Tcl_DecrRefCount(iPtr->errorStack); Tcl_IncrRefCount(newObj); @@ -1382,13 +1396,11 @@ TclMergeReturnOptions( Tcl_Obj **keys = GetKeys(); for (; objc > 1; objv += 2, objc -= 2) { - int optLen; - const char *opt = TclGetStringFromObj(objv[0], &optLen); - int compareLen; - const char *compare = - TclGetStringFromObj(keys[KEY_OPTIONS], &compareLen); + const char *opt = TclGetString(objv[0]); + const char *compare = TclGetString(keys[KEY_OPTIONS]); - if ((optLen == compareLen) && (memcmp(opt, compare, optLen) == 0)) { + if ((objv[0]->length == keys[KEY_OPTIONS]->length) + && (memcmp(opt, compare, objv[0]->length) == 0)) { Tcl_DictSearch search; int done = 0; Tcl_Obj *keyPtr; @@ -1626,7 +1638,7 @@ TclNoErrorStack( Tcl_Obj *options) { Tcl_Obj **keys = GetKeys(); - + Tcl_DictObjRemove(interp, options, keys[KEY_ERRORSTACK]); return options; } diff --git a/generic/tclScan.c b/generic/tclScan.c index ef7eedf..0e3da17 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -10,6 +10,7 @@ */ #include "tclInt.h" +#include "tommath.h" /* * Flag values used by Tcl_ScanObjCmd. @@ -72,17 +73,17 @@ BuildCharSet( CharSet *cset, const char *format) /* Points to first char of set. */ { - Tcl_UniChar ch, start; + Tcl_UniChar ch = 0, start; int offset, nranges; const char *end; memset(cset, 0, sizeof(CharSet)); - offset = Tcl_UtfToUniChar(format, &ch); + offset = TclUtfToUniChar(format, &ch); if (ch == '^') { cset->exclude = 1; format += offset; - offset = Tcl_UtfToUniChar(format, &ch); + offset = TclUtfToUniChar(format, &ch); } end = format + offset; @@ -91,14 +92,14 @@ BuildCharSet( */ if (ch == ']') { - end += Tcl_UtfToUniChar(end, &ch); + end += TclUtfToUniChar(end, &ch); } nranges = 0; while (ch != ']') { if (ch == '-') { nranges++; } - end += Tcl_UtfToUniChar(end, &ch); + end += TclUtfToUniChar(end, &ch); } cset->chars = ckalloc(sizeof(Tcl_UniChar) * (end - format - 1)); @@ -113,11 +114,11 @@ BuildCharSet( */ cset->nchars = cset->nranges = 0; - format += Tcl_UtfToUniChar(format, &ch); + format += TclUtfToUniChar(format, &ch); start = ch; if (ch == ']' || ch == '-') { cset->chars[cset->nchars++] = ch; - format += Tcl_UtfToUniChar(format, &ch); + format += TclUtfToUniChar(format, &ch); } while (ch != ']') { if (*format == '-') { @@ -138,7 +139,7 @@ BuildCharSet( cset->chars[cset->nchars++] = start; cset->chars[cset->nchars++] = ch; } else { - format += Tcl_UtfToUniChar(format, &ch); + format += TclUtfToUniChar(format, &ch); /* * Check to see if the range is in reverse order. @@ -156,7 +157,7 @@ BuildCharSet( } else { cset->chars[cset->nchars++] = ch; } - format += Tcl_UtfToUniChar(format, &ch); + format += TclUtfToUniChar(format, &ch); } return format; } @@ -257,7 +258,7 @@ ValidateFormat( { int gotXpg, gotSequential, value, i, flags; char *end; - Tcl_UniChar ch; + Tcl_UniChar ch = 0; int objIndex, xpgSize, nspace = numVars; int *nassign = TclStackAlloc(interp, nspace * sizeof(int)); char buf[TCL_UTF_MAX+1]; @@ -279,20 +280,20 @@ ValidateFormat( xpgSize = objIndex = gotXpg = gotSequential = 0; while (*format != '\0') { - format += Tcl_UtfToUniChar(format, &ch); + format += TclUtfToUniChar(format, &ch); flags = 0; if (ch != '%') { continue; } - format += Tcl_UtfToUniChar(format, &ch); + format += TclUtfToUniChar(format, &ch); if (ch == '%') { continue; } if (ch == '*') { flags |= SCAN_SUPPRESS; - format += Tcl_UtfToUniChar(format, &ch); + format += TclUtfToUniChar(format, &ch); goto xpgCheckDone; } @@ -308,7 +309,7 @@ ValidateFormat( goto notXpg; } format = end+1; - format += Tcl_UtfToUniChar(format, &ch); + format += TclUtfToUniChar(format, &ch); gotXpg = 1; if (gotSequential) { goto mixedXPG; @@ -347,7 +348,7 @@ ValidateFormat( if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ value = strtoul(format-1, (char **) &format, 10); /* INTL: "C" locale. */ flags |= SCAN_WIDTH; - format += Tcl_UtfToUniChar(format, &ch); + format += TclUtfToUniChar(format, &ch); } /* @@ -359,13 +360,13 @@ ValidateFormat( if (*format == 'l') { flags |= SCAN_BIG; format += 1; - format += Tcl_UtfToUniChar(format, &ch); + format += TclUtfToUniChar(format, &ch); break; } case 'L': flags |= SCAN_LONGER; case 'h': - format += Tcl_UtfToUniChar(format, &ch); + format += TclUtfToUniChar(format, &ch); } if (!(flags & SCAN_SUPPRESS) && numVars && (objIndex >= numVars)) { @@ -406,20 +407,16 @@ ValidateFormat( */ case 'd': case 'e': + case 'E': case 'f': case 'g': + case 'G': case 'i': case 'o': case 'x': + case 'X': case 'b': - break; case 'u': - if (flags & SCAN_BIG) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "unsigned bignum scans are invalid", -1)); - Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADUNSIGNED",NULL); - goto error; - } break; /* * Bracket terms need special checking @@ -431,24 +428,24 @@ ValidateFormat( if (*format == '\0') { goto badSet; } - format += Tcl_UtfToUniChar(format, &ch); + format += TclUtfToUniChar(format, &ch); if (ch == '^') { if (*format == '\0') { goto badSet; } - format += Tcl_UtfToUniChar(format, &ch); + format += TclUtfToUniChar(format, &ch); } if (ch == ']') { if (*format == '\0') { goto badSet; } - format += Tcl_UtfToUniChar(format, &ch); + format += TclUtfToUniChar(format, &ch); } while (ch != ']') { if (*format == '\0') { goto badSet; } - format += Tcl_UtfToUniChar(format, &ch); + format += TclUtfToUniChar(format, &ch); } break; badSet: @@ -579,7 +576,7 @@ Tcl_ScanObjCmd( char op = 0; int width, underflow = 0; Tcl_WideInt wideValue; - Tcl_UniChar ch, sch; + Tcl_UniChar ch = 0, sch = 0; Tcl_Obj **objs = NULL, *objPtr = NULL; int flags; char buf[513]; /* Temporary buffer to hold scanned number @@ -592,7 +589,7 @@ Tcl_ScanObjCmd( return TCL_ERROR; } - format = Tcl_GetStringFromObj(objv[2], NULL); + format = Tcl_GetString(objv[2]); numVars = objc-3; /* @@ -614,7 +611,7 @@ Tcl_ScanObjCmd( } } - string = Tcl_GetStringFromObj(objv[1], NULL); + string = Tcl_GetString(objv[1]); baseString = string; /* @@ -627,7 +624,7 @@ Tcl_ScanObjCmd( nconversions = 0; while (*format != '\0') { int parseFlag = TCL_PARSE_NO_WHITESPACE; - format += Tcl_UtfToUniChar(format, &ch); + format += TclUtfToUniChar(format, &ch); flags = 0; @@ -636,13 +633,13 @@ Tcl_ScanObjCmd( */ if (Tcl_UniCharIsSpace(ch)) { - offset = Tcl_UtfToUniChar(string, &sch); + offset = TclUtfToUniChar(string, &sch); while (Tcl_UniCharIsSpace(sch)) { if (*string == '\0') { goto done; } string += offset; - offset = Tcl_UtfToUniChar(string, &sch); + offset = TclUtfToUniChar(string, &sch); } continue; } @@ -653,14 +650,14 @@ Tcl_ScanObjCmd( underflow = 1; goto done; } - string += Tcl_UtfToUniChar(string, &sch); + string += TclUtfToUniChar(string, &sch); if (ch != sch) { goto done; } continue; } - format += Tcl_UtfToUniChar(format, &ch); + format += TclUtfToUniChar(format, &ch); if (ch == '%') { goto literal; } @@ -672,13 +669,13 @@ Tcl_ScanObjCmd( if (ch == '*') { flags |= SCAN_SUPPRESS; - format += Tcl_UtfToUniChar(format, &ch); + format += TclUtfToUniChar(format, &ch); } else if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ char *formatEnd; value = strtoul(format-1, &formatEnd, 10);/* INTL: "C" locale. */ if (*formatEnd == '$') { format = formatEnd+1; - format += Tcl_UtfToUniChar(format, &ch); + format += TclUtfToUniChar(format, &ch); objIndex = (int) value - 1; } } @@ -689,7 +686,7 @@ Tcl_ScanObjCmd( if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ width = (int) strtoul(format-1, (char **) &format, 10);/* INTL: "C" locale. */ - format += Tcl_UtfToUniChar(format, &ch); + format += TclUtfToUniChar(format, &ch); } else { width = 0; } @@ -703,7 +700,7 @@ Tcl_ScanObjCmd( if (*format == 'l') { flags |= SCAN_BIG; format += 1; - format += Tcl_UtfToUniChar(format, &ch); + format += TclUtfToUniChar(format, &ch); break; } case 'L': @@ -712,7 +709,7 @@ Tcl_ScanObjCmd( * Fall through so we skip to the next character. */ case 'h': - format += Tcl_UtfToUniChar(format, &ch); + format += TclUtfToUniChar(format, &ch); } /* @@ -743,6 +740,7 @@ Tcl_ScanObjCmd( parseFlag |= TCL_PARSE_OCTAL_ONLY | TCL_PARSE_SCAN_PREFIXES; break; case 'x': + case 'X': op = 'i'; parseFlag |= TCL_PARSE_HEXADECIMAL_ONLY; break; @@ -758,7 +756,9 @@ Tcl_ScanObjCmd( case 'f': case 'e': + case 'E': case 'g': + case 'G': op = 'f'; break; @@ -793,7 +793,7 @@ Tcl_ScanObjCmd( if (!(flags & SCAN_NOSKIP)) { while (*string != '\0') { - offset = Tcl_UtfToUniChar(string, &sch); + offset = TclUtfToUniChar(string, &sch); if (!Tcl_UniCharIsSpace(sch)) { break; } @@ -820,7 +820,7 @@ Tcl_ScanObjCmd( } end = string; while (*end != '\0') { - offset = Tcl_UtfToUniChar(end, &sch); + offset = TclUtfToUniChar(end, &sch); if (Tcl_UniCharIsSpace(sch)) { break; } @@ -848,7 +848,7 @@ Tcl_ScanObjCmd( format = BuildCharSet(&cset, format); while (*end != '\0') { - offset = Tcl_UtfToUniChar(end, &sch); + offset = TclUtfToUniChar(end, &sch); if (!CharInSet(&cset, (int)sch)) { break; } @@ -879,9 +879,17 @@ Tcl_ScanObjCmd( * Scan a single Unicode character. */ - string += Tcl_UtfToUniChar(string, &sch); + offset = TclUtfToUniChar(string, &sch); + i = (int)sch; +#if TCL_UTF_MAX == 4 + if (!offset) { + offset = TclUtfToUniChar(string, &sch); + i = (((i<<10) & 0x0FFC00) + 0x10000) + (sch & 0x3FF); + } +#endif + string += offset; if (!(flags & SCAN_SUPPRESS)) { - objPtr = Tcl_NewIntObj((int)sch); + objPtr = Tcl_NewIntObj(i); Tcl_IncrRefCount(objPtr); CLANG_ASSERT(objs); objs[objIndex++] = objPtr; @@ -918,9 +926,9 @@ Tcl_ScanObjCmd( } if (flags & SCAN_LONGER) { if (Tcl_GetWideIntFromObj(NULL, objPtr, &wideValue) != TCL_OK) { - wideValue = ~(Tcl_WideUInt)0 >> 1; /* WIDE_MAX */ + wideValue = LLONG_MAX; if (TclGetString(objPtr)[0] == '-') { - wideValue++; /* WIDE_MAX + 1 = WIDE_MIN */ + wideValue = LLONG_MIN; } } if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) { @@ -928,9 +936,33 @@ Tcl_ScanObjCmd( (Tcl_WideUInt)wideValue); Tcl_SetStringObj(objPtr, buf, -1); } else { - Tcl_SetWideIntObj(objPtr, wideValue); + TclSetIntObj(objPtr, wideValue); } - } else if (!(flags & SCAN_BIG)) { + } else if (flags & SCAN_BIG) { + if (flags & SCAN_UNSIGNED) { + mp_int big; + int code = Tcl_GetBignumFromObj(interp, objPtr, &big); + + if (code == TCL_OK) { + if (mp_isneg(&big)) { + code = TCL_ERROR; + } + mp_clear(&big); + } + + if (code == TCL_ERROR) { + if (objs != NULL) { + ckfree(objs); + } + Tcl_DecrRefCount(objPtr); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unsigned bignum scans are invalid", -1)); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", + "BADUNSIGNED",NULL); + return TCL_ERROR; + } + } + } else { if (TclGetLongFromObj(NULL, objPtr, &value) != TCL_OK) { if (TclGetString(objPtr)[0] == '-') { value = LONG_MIN; @@ -942,7 +974,7 @@ Tcl_ScanObjCmd( sprintf(buf, "%lu", value); /* INTL: ISO digit */ Tcl_SetStringObj(objPtr, buf, -1); } else { - Tcl_SetLongObj(objPtr, value); + TclSetIntObj(objPtr, value); } } objs[objIndex++] = objPtr; diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 883e2ea..a46b29a 100755..100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -18,13 +18,6 @@ #include <math.h> /* - * Define KILL_OCTAL to suppress interpretation of numbers with leading zero - * as octal. (Ceterum censeo: numeros octonarios delendos esse.) - */ - -#undef KILL_OCTAL - -/* * This code supports (at least hypothetically), IBM, Cray, VAX and IEEE-754 * floating point; of these, only IEEE-754 can represent NaN. IEEE-754 can be * uniquely determined by radix and by the widths of significand and exponent. @@ -396,6 +389,9 @@ static Tcl_WideUInt Nokia770Twiddle(Tcl_WideUInt w); * - TCL_PARSE_SCAN_PREFIXES: ignore the prefixes 0b and 0o that are * not part of the [scan] command's vocabulary. Use only in * combination with TCL_PARSE_INTEGER_ONLY. + * - TCL_PARSE_BINARY_ONLY: parse only in the binary format, whether + * or not a prefix is present that would lead to binary parsing. + * Use only in combination with TCL_PARSE_INTEGER_ONLY. * - TCL_PARSE_OCTAL_ONLY: parse only in the octal format, whether * or not a prefix is present that would lead to octal parsing. * Use only in combination with TCL_PARSE_INTEGER_ONLY. @@ -486,7 +482,7 @@ TclParseNumber( { enum State { INITIAL, SIGNUM, ZERO, ZERO_X, - ZERO_O, ZERO_B, BINARY, + ZERO_O, ZERO_B, ZERO_D, BINARY, HEXADECIMAL, OCTAL, BAD_OCTAL, DECIMAL, LEADING_RADIX_POINT, FRACTION, EXPONENT_START, EXPONENT_SIGNUM, EXPONENT, @@ -543,6 +539,20 @@ TclParseNumber( */ if (bytes == NULL) { + if (interp == NULL && endPtrPtr == NULL) { + if (objPtr->typePtr == &tclDictType) { + /* A dict can never be a (single) number */ + return TCL_ERROR; + } + if (objPtr->typePtr == &tclListType) { + int length; + /* A list can only be a (single) number if its length == 1 */ + TclListObjLength(NULL, objPtr, &length); + if (length != 1) { + return TCL_ERROR; + } + } + } bytes = TclGetString(objPtr); } @@ -627,6 +637,9 @@ TclParseNumber( acceptPoint = p; acceptLen = len; if (c == 'x' || c == 'X') { + if (flags & (TCL_PARSE_OCTAL_ONLY|TCL_PARSE_BINARY_ONLY)) { + goto endgame; + } state = ZERO_X; break; } @@ -637,6 +650,9 @@ TclParseNumber( goto zeroo; } if (c == 'b' || c == 'B') { + if (flags & TCL_PARSE_OCTAL_ONLY) { + goto endgame; + } state = ZERO_B; break; } @@ -648,7 +664,11 @@ TclParseNumber( state = ZERO_O; break; } -#ifdef KILL_OCTAL + if (c == 'd' || c == 'D') { + state = ZERO_D; + break; + } +#ifdef TCL_NO_DEPRECATED goto decimal; #endif /* FALLTHROUGH */ @@ -691,7 +711,7 @@ TclParseNumber( || (octalSignificandWide > (~(Tcl_WideUInt)0 >> shift)))) { octalSignificandOverflow = 1; - TclBNInitBignumFromWideUInt(&octalSignificandBig, + TclInitBignumFromWideUInt(&octalSignificandBig, octalSignificandWide); } } @@ -731,7 +751,7 @@ TclParseNumber( goto endgame; } -#ifndef KILL_OCTAL +#ifndef TCL_NO_DEPRECATED /* * Scanned a number with a leading zero that contains an 8, 9, @@ -808,7 +828,7 @@ TclParseNumber( ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || significandWide > (~(Tcl_WideUInt)0 >> shift))) { significandOverflow = 1; - TclBNInitBignumFromWideUInt(&significandBig, + TclInitBignumFromWideUInt(&significandBig, significandWide); } } @@ -849,7 +869,7 @@ TclParseNumber( ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || significandWide > (~(Tcl_WideUInt)0 >> shift))) { significandOverflow = 1; - TclBNInitBignumFromWideUInt(&significandBig, + TclInitBignumFromWideUInt(&significandBig, significandWide); } } @@ -864,13 +884,23 @@ TclParseNumber( state = BINARY; break; + case ZERO_D: + if (c == '0') { + numTrailZeros++; + } else if ( ! isdigit(UCHAR(c))) { + goto endgame; + } + state = DECIMAL; + flags |= TCL_PARSE_INTEGER_ONLY; + /* FALLTHROUGH */ + case DECIMAL: /* * Scanned an optional + or - followed by a string of decimal * digits. */ -#ifdef KILL_OCTAL +#ifdef TCL_NO_DEPRECATED decimal: #endif acceptState = state; @@ -1160,6 +1190,7 @@ TclParseNumber( case ZERO_X: case ZERO_O: case ZERO_B: + case ZERO_D: case LEADING_RADIX_POINT: case EXPONENT_START: case EXPONENT_SIGNUM: @@ -1174,16 +1205,16 @@ TclParseNumber( case sNA: case sNANPAREN: case sNANHEX: +#endif Tcl_Panic("TclParseNumber: bad acceptState %d parsing '%s'", acceptState, bytes); -#endif case BINARY: shift = numTrailZeros; if (!significandOverflow && significandWide != 0 && ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || significandWide > (MOST_BITS + signum) >> shift)) { significandOverflow = 1; - TclBNInitBignumFromWideUInt(&significandBig, significandWide); + TclInitBignumFromWideUInt(&significandBig, significandWide); } if (shift) { if (!significandOverflow) { @@ -1204,7 +1235,7 @@ TclParseNumber( ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || significandWide > (MOST_BITS + signum) >> shift)) { significandOverflow = 1; - TclBNInitBignumFromWideUInt(&significandBig, significandWide); + TclInitBignumFromWideUInt(&significandBig, significandWide); } if (shift) { if (!significandOverflow) { @@ -1225,7 +1256,7 @@ TclParseNumber( ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || octalSignificandWide > (MOST_BITS + signum) >> shift)) { octalSignificandOverflow = 1; - TclBNInitBignumFromWideUInt(&octalSignificandBig, + TclInitBignumFromWideUInt(&octalSignificandBig, octalSignificandWide); } if (shift) { @@ -1237,32 +1268,18 @@ TclParseNumber( } } if (!octalSignificandOverflow) { - if (octalSignificandWide > - (Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) { -#ifndef TCL_WIDE_INT_IS_LONG - if (octalSignificandWide <= (MOST_BITS + signum)) { - objPtr->typePtr = &tclWideIntType; - if (signum) { - objPtr->internalRep.wideValue = - - (Tcl_WideInt) octalSignificandWide; - } else { - objPtr->internalRep.wideValue = - (Tcl_WideInt) octalSignificandWide; - } - break; - } -#endif - TclBNInitBignumFromWideUInt(&octalSignificandBig, + if (octalSignificandWide > (MOST_BITS + signum)) { + TclInitBignumFromWideUInt(&octalSignificandBig, octalSignificandWide); octalSignificandOverflow = 1; } else { objPtr->typePtr = &tclIntType; if (signum) { - objPtr->internalRep.longValue = - - (long) octalSignificandWide; + objPtr->internalRep.wideValue = + - (Tcl_WideInt) octalSignificandWide; } else { - objPtr->internalRep.longValue = - (long) octalSignificandWide; + objPtr->internalRep.wideValue = + (Tcl_WideInt) octalSignificandWide; } } } @@ -1280,36 +1297,22 @@ TclParseNumber( &significandWide, &significandBig, significandOverflow); if (!significandOverflow && (significandWide > MOST_BITS+signum)){ significandOverflow = 1; - TclBNInitBignumFromWideUInt(&significandBig, significandWide); + TclInitBignumFromWideUInt(&significandBig, significandWide); } returnInteger: if (!significandOverflow) { - if (significandWide > - (Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) { -#ifndef TCL_WIDE_INT_IS_LONG - if (significandWide <= MOST_BITS+signum) { - objPtr->typePtr = &tclWideIntType; - if (signum) { - objPtr->internalRep.wideValue = - - (Tcl_WideInt) significandWide; - } else { - objPtr->internalRep.wideValue = - (Tcl_WideInt) significandWide; - } - break; - } -#endif - TclBNInitBignumFromWideUInt(&significandBig, + if (significandWide > MOST_BITS+signum) { + TclInitBignumFromWideUInt(&significandBig, significandWide); significandOverflow = 1; } else { objPtr->typePtr = &tclIntType; if (signum) { - objPtr->internalRep.longValue = - - (long) significandWide; + objPtr->internalRep.wideValue = + - (Tcl_WideInt) significandWide; } else { - objPtr->internalRep.longValue = - (long) significandWide; + objPtr->internalRep.wideValue = + (Tcl_WideInt) significandWide; } } } @@ -1454,7 +1457,7 @@ AccumulateDecimalDigit( * bignum and fall through into the bignum case. */ - TclBNInitBignumFromWideUInt(bignumRepPtr, w); + TclInitBignumFromWideUInt(bignumRepPtr, w); } else { /* * Wide multiplication. @@ -1548,7 +1551,7 @@ MakeLowPrecisionDouble( * Test for the easy cases. */ - if (numSigDigs <= DBL_DIG) { + if (numSigDigs <= QUICK_MAX) { if (exponent >= 0) { if (exponent <= mmaxpow) { /* @@ -1561,7 +1564,7 @@ MakeLowPrecisionDouble( ((Tcl_WideInt)significand * pow10vals[exponent]); goto returnValue; } else { - int diff = DBL_DIG - numSigDigs; + int diff = QUICK_MAX - numSigDigs; if (exponent-diff <= mmaxpow) { /* @@ -1597,7 +1600,7 @@ MakeLowPrecisionDouble( * call MakeHighPrecisionDouble to do it the hard way. */ - TclBNInitBignumFromWideUInt(&significandBig, significand); + TclInitBignumFromWideUInt(&significandBig, significand); retval = MakeHighPrecisionDouble(0, &significandBig, numSigDigs, exponent); mp_clear(&significandBig); @@ -1798,6 +1801,12 @@ RefineApproximation( double quot; /* Correction term. */ double minincr; /* Lower bound on the absolute value of the * correction term. */ + int roundToEven = 0; /* Flag == TRUE if we need to invoke + * "round to even" functionality */ + double rteSignificand; /* Significand of the round-to-even result */ + int rteExponent; /* Exponent of the round-to-even result */ + Tcl_WideInt rteSigWide; /* Wide integer version of the significand + * for testing evenness */ int i; /* @@ -1893,15 +1902,33 @@ RefineApproximation( mp_div_2d(&twoMv, -multiplier, &twoMv, NULL); } - /* - * If the result is less than unity, the error is less than 1/2 unit in - * the last place, so there's no correction to make. - */ - - if (mp_cmp_mag(&twoMd, &twoMv) == MP_LT) { + switch (mp_cmp_mag(&twoMd, &twoMv)) { + case MP_LT: + /* + * If the result is less than unity, the error is less than 1/2 unit in + * the last place, so there's no correction to make. + */ mp_clear(&twoMd); mp_clear(&twoMv); return approxResult; + case MP_EQ: + /* + * If the result is exactly unity, we need to round to even. + */ + roundToEven = 1; + break; + case MP_GT: + break; + } + + if (roundToEven) { + rteSignificand = frexp(approxResult, &rteExponent); + rteSigWide = (Tcl_WideInt) ldexp(rteSignificand, FP_PRECISION); + if ((rteSigWide & 1) == 0) { + mp_clear(&twoMd); + mp_clear(&twoMv); + return approxResult; + } } /* @@ -1940,7 +1967,7 @@ RefineApproximation( *---------------------------------------------------------------------- */ -inline static void +static inline void MulPow5( mp_int *base, /* Number to multiply. */ unsigned n, /* Power of 5 to multiply by. */ @@ -1985,7 +2012,7 @@ MulPow5( *---------------------------------------------------------------------- */ -inline static int +static inline int NormalizeRightward( Tcl_WideUInt *wPtr) /* INOUT: Number to shift. */ { @@ -2076,7 +2103,7 @@ RequiredPrecision( *---------------------------------------------------------------------- */ -inline static void +static inline void DoubleToExpAndSig( double dv, /* Number to convert. */ Tcl_WideUInt *significand, /* OUTPUT: Significand of the number. */ @@ -2124,7 +2151,7 @@ DoubleToExpAndSig( *---------------------------------------------------------------------- */ -inline static void +static inline void TakeAbsoluteValue( Double *d, /* Number to replace with absolute value. */ int *sign) /* Place to put the signum. */ @@ -2155,7 +2182,7 @@ TakeAbsoluteValue( *---------------------------------------------------------------------- */ -inline static char * +static inline char * FormatInfAndNaN( Double *d, /* Exceptional number to format. */ int *decpt, /* Decimal point to set to a bogus value. */ @@ -2197,7 +2224,7 @@ FormatInfAndNaN( *---------------------------------------------------------------------- */ -inline static char * +static inline char * FormatZero( int *decpt, /* Location of the decimal point. */ char **endPtr) /* Pointer to the end of the formatted data */ @@ -2227,7 +2254,7 @@ FormatZero( *---------------------------------------------------------------------- */ -inline static int +static inline int ApproximateLog10( Tcl_WideUInt bw, /* Integer significand of the number. */ int be, /* Power of two to scale bw. */ @@ -2275,7 +2302,7 @@ ApproximateLog10( *---------------------------------------------------------------------- */ -inline static int +static inline int BetterLog10( double d, /* Original number to format. */ int k, /* Characteristic(Log base 10) of the @@ -2318,7 +2345,7 @@ BetterLog10( *---------------------------------------------------------------------- */ -inline static void +static inline void ComputeScale( int be, /* Exponent part of number: d = bw * 2**be. */ int k, /* Characteristic of log10(number). */ @@ -2381,7 +2408,7 @@ ComputeScale( *---------------------------------------------------------------------- */ -inline static void +static inline void SetPrecisionLimits( int convType, /* Type of conversion: TCL_DD_SHORTEST, * TCL_DD_STEELE0, TCL_DD_E_FMT, @@ -2442,7 +2469,7 @@ SetPrecisionLimits( *---------------------------------------------------------------------- */ -inline static char * +static inline char * BumpUp( char *s, /* Cursor pointing one past the end of the * string. */ @@ -2476,7 +2503,7 @@ BumpUp( *---------------------------------------------------------------------- */ -inline static int +static inline int AdjustRange( double *dPtr, /* INOUT: Number to adjust. */ int k) /* IN: floor(log10(d)) */ @@ -2549,7 +2576,7 @@ AdjustRange( *---------------------------------------------------------------------- */ -inline static char * +static inline char * ShorteningQuickFormat( double d, /* Number to convert. */ int k, /* floor(log10(d)) */ @@ -2624,7 +2651,7 @@ ShorteningQuickFormat( *---------------------------------------------------------------------- */ -inline static char * +static inline char * StrictQuickFormat( double d, /* Number to convert. */ int k, /* floor(log10(d)) */ @@ -2698,7 +2725,7 @@ StrictQuickFormat( *---------------------------------------------------------------------- */ -inline static char * +static inline char * QuickConversion( double e, /* Number to format. */ int k, /* floor(log10(d)), approximately. */ @@ -2803,7 +2830,7 @@ QuickConversion( *---------------------------------------------------------------------- */ -inline static void +static inline void CastOutPowersOf2( int *b2, /* Power of 2 to multiply the significand. */ int *m2, /* Power of 2 to multiply 1/2 ulp. */ @@ -2847,7 +2874,7 @@ CastOutPowersOf2( *---------------------------------------------------------------------- */ -inline static char * +static inline char * ShorteningInt64Conversion( Double *dPtr, /* Original number to convert. */ int convType, /* Type of conversion (shortest, Steele, @@ -3016,7 +3043,7 @@ ShorteningInt64Conversion( *---------------------------------------------------------------------- */ -inline static char * +static inline char * StrictInt64Conversion( Double *dPtr, /* Original number to convert. */ int convType, /* Type of conversion (shortest, Steele, @@ -3122,7 +3149,7 @@ StrictInt64Conversion( *---------------------------------------------------------------------- */ -inline static int +static inline int ShouldBankerRoundUpPowD( mp_int *b, /* Numerator of the fraction. */ int sd, /* Denominator is 2**(sd*DIGIT_BIT). */ @@ -3160,7 +3187,7 @@ ShouldBankerRoundUpPowD( *---------------------------------------------------------------------- */ -inline static int +static inline int ShouldBankerRoundUpToNextPowD( mp_int *b, /* Numerator of the fraction. */ mp_int *m, /* Numerator of the rounding tolerance. */ @@ -3223,7 +3250,7 @@ ShouldBankerRoundUpToNextPowD( *---------------------------------------------------------------------- */ -inline static char * +static inline char * ShorteningBignumConversionPowD( Double *dPtr, /* Original number to convert. */ int convType, /* Type of conversion (shortest, Steele, @@ -3260,7 +3287,7 @@ ShorteningBignumConversionPowD( * mminus = 5**m5 */ - TclBNInitBignumFromWideUInt(&b, bw); + TclInitBignumFromWideUInt(&b, bw); mp_init_set_int(&mminus, 1); MulPow5(&b, b5, &b); mp_mul_2d(&b, b2, &b); @@ -3416,7 +3443,7 @@ ShorteningBignumConversionPowD( *---------------------------------------------------------------------- */ -inline static char * +static inline char * StrictBignumConversionPowD( Double *dPtr, /* Original number to convert. */ int convType, /* Type of conversion (shortest, Steele, @@ -3447,7 +3474,7 @@ StrictBignumConversionPowD( * b = bw * 2**b2 * 5**b5 */ - TclBNInitBignumFromWideUInt(&b, bw); + TclInitBignumFromWideUInt(&b, bw); MulPow5(&b, b5, &b); mp_mul_2d(&b, b2, &b); @@ -3532,7 +3559,7 @@ StrictBignumConversionPowD( *---------------------------------------------------------------------- */ -inline static int +static inline int ShouldBankerRoundUp( mp_int *twor, /* 2x the remainder from thd division that * produced the last digit. */ @@ -3567,7 +3594,7 @@ ShouldBankerRoundUp( *---------------------------------------------------------------------- */ -inline static int +static inline int ShouldBankerRoundUpToNext( mp_int *b, /* Remainder from the division that produced * the last digit. */ @@ -3621,7 +3648,7 @@ ShouldBankerRoundUpToNext( *---------------------------------------------------------------------- */ -inline static char * +static inline char * ShorteningBignumConversion( Double *dPtr, /* Original number being converted. */ int convType, /* Conversion type. */ @@ -3655,7 +3682,7 @@ ShorteningBignumConversion( * S = 2**s2 * 5*s5 */ - TclBNInitBignumFromWideUInt(&b, bw); + TclInitBignumFromWideUInt(&b, bw); mp_mul_2d(&b, b2, &b); mp_init_set_int(&S, 1); MulPow5(&S, s5, &S); mp_mul_2d(&S, s2, &S); @@ -3765,7 +3792,7 @@ ShorteningBignumConversion( --s5; /* - * IDEA: It might possibly be a win to fall back to int64 + * IDEA: It might possibly be a win to fall back to int64_t * arithmetic here if S < 2**64/10. But it's a win only for * a fairly narrow range of magnitudes so perhaps not worth * bothering. We already know that we shorten the @@ -3837,7 +3864,7 @@ ShorteningBignumConversion( *---------------------------------------------------------------------- */ -inline static char * +static inline char * StrictBignumConversion( Double *dPtr, /* Original number being converted. */ int convType, /* Conversion type. */ @@ -3868,7 +3895,7 @@ StrictBignumConversion( */ mp_init_multi(&temp, &dig, NULL); - TclBNInitBignumFromWideUInt(&b, bw); + TclInitBignumFromWideUInt(&b, bw); mp_mul_2d(&b, b2, &b); mp_init_set_int(&S, 1); MulPow5(&S, s5, &S); mp_mul_2d(&S, s2, &S); @@ -3930,7 +3957,7 @@ StrictBignumConversion( * As with the shortening bignum conversion, it's possible at this * point that we will have reduced the denominator to less than * 2**64/10, at which point it would be possible to fall back to - * to int64 arithmetic. But the potential payoff is tremendously + * to int64_t arithmetic. But the potential payoff is tremendously * less - unless we're working in F format - because we know that * three groups of digits will always suffice for %#.17e, the * longest format that doesn't introduce empty precision. @@ -4025,7 +4052,7 @@ StrictBignumConversion( * choosing the one that is closest to the given number (and * resolving ties with 'round to even'). It is allowed to return * fewer than 'ndigits' if the number converts exactly; if the - * TCL_DD_E_FORMAT|TCL_DD_SHORTEN_FLAG is supplied instead, it + * TCL_DD_E_FORMAT|TCL_DD_SHORTEN_FLAG is supplied instead, it * also returns fewer digits if the shorter string will still * reconvert without loss to the given input number. In any case, * strings of trailing zeroes are suppressed. @@ -4516,7 +4543,7 @@ Tcl_InitBignumFromDouble( return TCL_ERROR; } - fract = frexp(d,&expt); + fract = frexp(d, &expt); if (expt <= 0) { mp_init(b); mp_zero(b); @@ -4524,7 +4551,7 @@ Tcl_InitBignumFromDouble( Tcl_WideInt w = (Tcl_WideInt) ldexp(fract, mantBits); int shift = expt - mantBits; - TclBNInitBignumFromWideInt(b, w); + TclInitBignumFromWideInt(b, w); if (shift < 0) { mp_div_2d(b, -shift, b, NULL); } else if (shift > 0) { @@ -4559,7 +4586,7 @@ TclBignumToDouble( /* - * We need a 'mantBits'-bit significand. Determine what shift will + * We need a 'mantBits'-bit significand. Determine what shift will * give us that. */ @@ -4574,7 +4601,7 @@ TclBignumToDouble( } shift = mantBits - bits; - /* + /* * If shift > 0, shift the significand left by the requisite number of * bits. If shift == 0, the significand is already exactly 'mantBits' * in length. If shift < 0, we will need to shift the significand right @@ -4670,7 +4697,7 @@ TclCeil( mp_int b; mp_init(&b); - if (mp_cmp_d(a, 0) == MP_LT) { + if (mp_isneg(a)) { mp_neg(a, &b); r = -TclFloor(&b); } else { @@ -4727,7 +4754,7 @@ TclFloor( mp_int b; mp_init(&b); - if (mp_cmp_d(a, 0) == MP_LT) { + if (mp_isneg(a)) { mp_neg(a, &b); r = -TclCeil(&b); } else { @@ -4856,7 +4883,7 @@ Pow10TimesFrExp( * Multiply by 10**exponent. */ - retval = frexp(retval * pow10vals[exponent&0xf], &j); + retval = frexp(retval * pow10vals[exponent & 0xf], &j); expt += j; for (i=4; i<9; ++i) { if (exponent & (1<<i)) { diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index e495c2e..f98180f 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -36,16 +36,9 @@ #include "tclInt.h" #include "tommath.h" +#include "tclStringRep.h" -/* - * Set COMPAT to 1 to restore the shimmering patterns to those of Tcl 8.5. - * This is an escape hatch in case the changes have some unexpected unwelcome - * impact on performance. If things go well, this mechanism can go away when - * post-8.6 development begins. - */ - -#define COMPAT 0 - +#include "assert.h" /* * Prototypes for functions defined later in this file: */ @@ -89,60 +82,6 @@ const Tcl_ObjType tclStringType = { UpdateStringOfString, /* updateStringProc */ SetStringFromAny /* setFromAnyProc */ }; - -/* - * The following structure is the internal rep for a String object. It keeps - * track of how much memory has been used and how much has been allocated for - * the Unicode and UTF string to enable growing and shrinking of the UTF and - * Unicode reps of the String object with fewer mallocs. To optimize string - * length and indexing operations, this structure also stores the number of - * characters (same of UTF and Unicode!) once that value has been computed. - * - * Under normal configurations, what Tcl calls "Unicode" is actually UTF-16 - * restricted to the Basic Multilingual Plane (i.e. U+00000 to U+0FFFF). This - * can be officially modified by altering the definition of Tcl_UniChar in - * tcl.h, but do not do that unless you are sure what you're doing! - */ - -typedef struct String { - int numChars; /* The number of chars in the string. -1 means - * this value has not been calculated. >= 0 - * means that there is a valid Unicode rep, or - * that the number of UTF bytes == the number - * of chars. */ - int allocated; /* The amount of space actually allocated for - * the UTF string (minus 1 byte for the - * termination char). */ - int maxChars; /* Max number of chars that can fit in the - * space allocated for the unicode array. */ - int hasUnicode; /* Boolean determining whether the string has - * a Unicode representation. */ - Tcl_UniChar unicode[1]; /* The array of Unicode chars. The actual size - * of this field depends on the 'maxChars' - * field above. */ -} String; - -#define STRING_MAXCHARS \ - (int)(((size_t)UINT_MAX - sizeof(String))/sizeof(Tcl_UniChar)) -#define STRING_SIZE(numChars) \ - (sizeof(String) + ((numChars) * sizeof(Tcl_UniChar))) -#define stringCheckLimits(numChars) \ - if ((numChars) < 0 || (numChars) > STRING_MAXCHARS) { \ - Tcl_Panic("max length for a Tcl unicode value (%d chars) exceeded", \ - STRING_MAXCHARS); \ - } -#define stringAttemptAlloc(numChars) \ - (String *) attemptckalloc((unsigned) STRING_SIZE(numChars) ) -#define stringAlloc(numChars) \ - (String *) ckalloc((unsigned) STRING_SIZE(numChars) ) -#define stringRealloc(ptr, numChars) \ - (String *) ckrealloc((ptr), (unsigned) STRING_SIZE(numChars) ) -#define stringAttemptRealloc(ptr, numChars) \ - (String *) attemptckrealloc((ptr), (unsigned) STRING_SIZE(numChars) ) -#define GET_STRING(objPtr) \ - ((String *) (objPtr)->internalRep.twoPtrValue.ptr1) -#define SET_STRING(objPtr, stringPtr) \ - ((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (stringPtr)) /* * TCL STRING GROWTH ALGORITHM @@ -188,7 +127,7 @@ GrowStringBuffer( int flag) { /* - * Pre-conditions: + * Pre-conditions: * objPtr->typePtr == &tclStringType * needed > stringPtr->allocated * flag || objPtr->bytes != NULL @@ -198,12 +137,12 @@ GrowStringBuffer( char *ptr = NULL; int attempt; - if (objPtr->bytes == tclEmptyStringRep) { + if (objPtr->bytes == &tclEmptyString) { objPtr->bytes = NULL; } if (flag == 0 || stringPtr->allocated > 0) { - attempt = 2 * needed; - if (attempt >= 0) { + if (needed <= INT_MAX / 2) { + attempt = 2 * needed; ptr = attemptckrealloc(objPtr->bytes, attempt + 1); } if (ptr == NULL) { @@ -238,7 +177,7 @@ GrowUnicodeBuffer( int needed) { /* - * Pre-conditions: + * Pre-conditions: * objPtr->typePtr == &tclStringType * needed > stringPtr->maxChars * needed < STRING_MAXCHARS @@ -252,8 +191,8 @@ GrowUnicodeBuffer( * Subsequent appends - apply the growth algorithm. */ - attempt = 2 * needed; - if (attempt >= 0 && attempt <= STRING_MAXCHARS) { + if (needed <= STRING_MAXCHARS / 2) { + attempt = 2 * needed; ptr = stringAttemptRealloc(stringPtr, attempt); } if (ptr == NULL) { @@ -471,9 +410,23 @@ Tcl_GetCharLength( int numChars; /* - * Optimize the case where we're really dealing with a bytearray object - * without string representation; we don't need to convert to a string to - * perform the get-length operation. + * Quick, no-shimmer return for short string reps. + */ + + if ((objPtr->bytes) && (objPtr->length < 2)) { + /* 0 bytes -> 0 chars; 1 byte -> 1 char */ + return objPtr->length; + } + + /* + * Optimize the case where we're really dealing with a bytearray object; + * we don't need to convert to a string to perform the get-length operation. + * + * Starting in Tcl 8.7, we check for a "pure" bytearray, because the + * machinery behind that test is using a proper bytearray ObjType. We + * could also compute length of an improper bytearray without shimmering + * but there's no value in that. We *want* to shimmer an improper bytearray + * because improper bytearrays have worthless internal reps. */ if (TclIsPureByteArray(objPtr)) { @@ -498,20 +451,50 @@ Tcl_GetCharLength( if (numChars == -1) { TclNumUtfChars(numChars, objPtr->bytes, objPtr->length); stringPtr->numChars = numChars; + } + return numChars; +} + +/* + *---------------------------------------------------------------------- + * + * TclCheckEmptyString -- + * + * Determine whether the string value of an object is or would be the + * empty string, without generating a string representation. + * + * Results: + * Returns 1 if empty, 0 if not, and -1 if unknown. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +int +TclCheckEmptyString( + Tcl_Obj *objPtr) +{ + int length = -1; -#if COMPAT - if (numChars < objPtr->length) { - /* - * Since we've just computed the number of chars, and not all UTF - * chars are 1-byte long, go ahead and populate the unicode - * string. - */ + if (objPtr->bytes == &tclEmptyString) { + return TCL_EMPTYSTRING_YES; + } - FillUnicodeRep(objPtr); - } -#endif + if (TclListObjIsCanonical(objPtr)) { + Tcl_ListObjLength(NULL, objPtr, &length); + return length == 0; } - return numChars; + + if (TclIsPureDict(objPtr)) { + Tcl_DictObjSize(NULL, objPtr, &length); + return length == 0; + } + + if (objPtr->bytes == NULL) { + return TCL_EMPTYSTRING_UNKNOWN; + } + return objPtr->length == 0; } /* @@ -519,8 +502,9 @@ Tcl_GetCharLength( * * Tcl_GetUniChar -- * - * Get the index'th Unicode character from the String object. The index - * is assumed to be in the appropriate range. + * Get the index'th Unicode character from the String object. If index + * is out of range or it references a low surrogate preceded by a high + * surrogate, the result = -1; * * Results: * Returns the index'th Unicode character in the Object. @@ -531,24 +515,31 @@ Tcl_GetCharLength( *---------------------------------------------------------------------- */ -Tcl_UniChar +int Tcl_GetUniChar( Tcl_Obj *objPtr, /* The object to get the Unicode charater * from. */ int index) /* Get the index'th Unicode character. */ { String *stringPtr; + int ch, length; + + if (index < 0) { + return -1; + } /* * Optimize the case where we're really dealing with a bytearray object - * without string representation; we don't need to convert to a string to - * perform the indexing operation. + * we don't need to convert to a string to perform the indexing operation. */ if (TclIsPureByteArray(objPtr)) { - unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, NULL); + unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length); + if (index >= length) { + return -1; + } - return (Tcl_UniChar) bytes[index]; + return (int) bytes[index]; } /* @@ -572,7 +563,28 @@ Tcl_GetUniChar( FillUnicodeRep(objPtr); stringPtr = GET_STRING(objPtr); } - return stringPtr->unicode[index]; + + if (index >= stringPtr->numChars) { + return -1; + } + ch = stringPtr->unicode[index]; +#if TCL_UTF_MAX <= 4 + /* See: bug [11ae2be95dac9417] */ + if ((ch & 0xF800) == 0xD800) { + if (ch & 0x400) { + if ((index > 0) + && ((stringPtr->unicode[index-1] & 0xFC00) == 0xD800)) { + ch = -1; /* low surrogate preceded by high surrogate */ + } + } else if ((++index < stringPtr->numChars) + && ((stringPtr->unicode[index] & 0xFC00) == 0xDC00)) { + /* high surrogate followed by low surrogate */ + ch = (((ch & 0x3FF) << 10) | + (stringPtr->unicode[index] & 0x3FF)) + 0x10000; + } + } +#endif + return ch; } /* @@ -582,7 +594,7 @@ Tcl_GetUniChar( * * Get the Unicode form of the String object. 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 + * object does not have a Unicode rep, then one is created from the UTF * string format. * * Results: @@ -594,6 +606,8 @@ Tcl_GetUniChar( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED +#undef Tcl_GetUnicode Tcl_UniChar * Tcl_GetUnicode( Tcl_Obj *objPtr) /* The object to find the unicode string @@ -601,6 +615,7 @@ Tcl_GetUnicode( { return Tcl_GetUnicodeFromObj(objPtr, NULL); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -672,17 +687,27 @@ Tcl_GetRange( { Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */ String *stringPtr; + int length; + + if (first < 0) { + first = 0; + } /* * Optimize the case where we're really dealing with a bytearray object - * without string representation; we don't need to convert to a string to - * perform the substring operation. + * we don't need to convert to a string to perform the substring operation. */ if (TclIsPureByteArray(objPtr)) { - unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, NULL); + unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length); - return Tcl_NewByteArrayObj(bytes+first, last-first+1); + if (last >= length) { + last = length - 1; + } + if (last < first) { + return Tcl_NewObj(); + } + return Tcl_NewByteArrayObj(bytes + first, last - first + 1); } /* @@ -701,6 +726,12 @@ Tcl_GetRange( TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length); } if (stringPtr->numChars == objPtr->length) { + if (last >= stringPtr->numChars) { + last = stringPtr->numChars - 1; + } + if (last < first) { + return Tcl_NewObj(); + } newObjPtr = Tcl_NewStringObj(objPtr->bytes + first, last-first+1); /* @@ -715,8 +746,25 @@ Tcl_GetRange( FillUnicodeRep(objPtr); stringPtr = GET_STRING(objPtr); } - - return Tcl_NewUnicodeObj(stringPtr->unicode + first, last-first+1); + if (last > stringPtr->numChars) { + last = stringPtr->numChars; + } + if (last < first) { + return Tcl_NewObj(); + } +#if TCL_UTF_MAX <= 4 + /* See: bug [11ae2be95dac9417] */ + if ((first > 0) && ((stringPtr->unicode[first] & 0xFC00) == 0xDC00) + && ((stringPtr->unicode[first-1] & 0xFC00) == 0xD800)) { + ++first; + } + if ((last + 1 < stringPtr->numChars) + && ((stringPtr->unicode[last+1] & 0xFC00) == 0xDC00) + && ((stringPtr->unicode[last] & 0xFC00) == 0xD800)) { + ++last; + } +#endif + return Tcl_NewUnicodeObj(stringPtr->unicode + first, last - first + 1); } /* @@ -832,7 +880,7 @@ Tcl_SetObjLength( /* * Need to enlarge the buffer. */ - if (objPtr->bytes == tclEmptyStringRep) { + if (objPtr->bytes == &tclEmptyString) { objPtr->bytes = ckalloc(length + 1); } else { objPtr->bytes = ckrealloc(objPtr->bytes, length + 1); @@ -938,7 +986,7 @@ Tcl_AttemptSetObjLength( char *newBytes; - if (objPtr->bytes == tclEmptyStringRep) { + if (objPtr->bytes == &tclEmptyString) { newBytes = attemptckalloc(length + 1); } else { newBytes = attemptckrealloc(objPtr->bytes, length + 1); @@ -1123,7 +1171,8 @@ Tcl_AppendLimitedToObj( if (ellipsis == NULL) { ellipsis = "..."; } - toCopy = Tcl_UtfPrev(bytes+limit+1-strlen(ellipsis), bytes) - bytes; + toCopy = (bytes == NULL) ? limit + : Tcl_UtfPrev(bytes+limit+1-strlen(ellipsis), bytes) - bytes; } /* @@ -1225,11 +1274,7 @@ Tcl_AppendUnicodeToObj( * objPtr's string rep. */ - if (stringPtr->hasUnicode -#if COMPAT - && stringPtr->numChars > 0 -#endif - ) { + if (stringPtr->hasUnicode) { AppendUnicodeToUnicodeRep(objPtr, unicode, length); } else { AppendUnicodeToUtfRep(objPtr, unicode, length); @@ -1250,6 +1295,8 @@ Tcl_AppendUnicodeToObj( * Side effects: * The string rep of appendObjPtr is appended to the string * representation of objPtr. + * IMPORTANT: This routine does not and MUST NOT shimmer appendObjPtr. + * Callers are counting on that. * *---------------------------------------------------------------------- */ @@ -1268,36 +1315,62 @@ Tcl_AppendObjToObj( * that appending nothing to anything leaves that starting anything... */ - if (appendObjPtr->bytes == tclEmptyStringRep) { + if (appendObjPtr->bytes == &tclEmptyString) { return; } /* * Handle append of one bytearray object to another as a special case. - * Note that we only do this when the objects don't have string reps; if - * it did, then appending the byte arrays together could well lose - * information; this is a special-case optimization only. + * Note that we only do this when the objects are pure so that the + * bytearray faithfully represent the true value; Otherwise appending the + * byte arrays together could lose information; */ - if ((TclIsPureByteArray(objPtr) || objPtr->bytes == tclEmptyStringRep) + if ((TclIsPureByteArray(objPtr) || objPtr->bytes == &tclEmptyString) && TclIsPureByteArray(appendObjPtr)) { - unsigned char *bytesSrc; - int lengthSrc, lengthTotal; - /* - * We do not assume that objPtr and appendObjPtr must be distinct! - * This makes this code a bit more complex than it otherwise would be, - * but in turn makes it much safer. + * You might expect the code here to be + * + * bytes = Tcl_GetByteArrayFromObj(appendObjPtr, &length); + * TclAppendBytesToByteArray(objPtr, bytes, length); + * + * and essentially all of the time that would be fine. However, it + * would run into trouble in the case where objPtr and appendObjPtr + * point to the same thing. That may never be a good idea. It seems to + * violate Copy On Write, and we don't have any tests for the + * situation, since making any Tcl commands that call + * Tcl_AppendObjToObj() do that appears impossible (They honor Copy On + * Write!). For the sake of extensions that go off into that realm, + * though, here's a more complex approach that can handle all the + * cases. + * + * First, get the lengths. */ + int lengthSrc; + (void) Tcl_GetByteArrayFromObj(objPtr, &length); (void) Tcl_GetByteArrayFromObj(appendObjPtr, &lengthSrc); - lengthTotal = length + lengthSrc; - if (((length > lengthSrc) ? length : lengthSrc) > lengthTotal) { - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); - } - bytesSrc = Tcl_GetByteArrayFromObj(appendObjPtr, NULL); - TclAppendBytesToByteArray(objPtr, bytesSrc, lengthSrc); + + /* + * Grow buffer enough for the append. + */ + + TclAppendBytesToByteArray(objPtr, NULL, lengthSrc); + + /* + * Reset objPtr back to the original value. + */ + + Tcl_SetByteArrayLength(objPtr, length); + + /* + * Now do the append knowing that buffer growth cannot cause any + * trouble. + */ + + TclAppendBytesToByteArray(objPtr, + Tcl_GetByteArrayFromObj(appendObjPtr, NULL), lengthSrc); return; } @@ -1313,11 +1386,7 @@ Tcl_AppendObjToObj( * appendObjPtr and append it. */ - if (stringPtr->hasUnicode -#if COMPAT - && stringPtr->numChars > 0 -#endif - ) { + if (stringPtr->hasUnicode) { /* * If appendObjPtr is not of the "String" type, don't convert it. */ @@ -1345,16 +1414,13 @@ Tcl_AppendObjToObj( numChars = stringPtr->numChars; if ((numChars >= 0) && (appendObjPtr->typePtr == &tclStringType)) { String *appendStringPtr = GET_STRING(appendObjPtr); + appendNumChars = appendStringPtr->numChars; } AppendUtfToUtfRep(objPtr, bytes, length); - if (numChars >= 0 && appendNumChars >= 0 -#if COMPAT - && appendNumChars == length -#endif - ) { + if (numChars >= 0 && appendNumChars >= 0) { stringPtr->numChars = numChars + appendNumChars; } } @@ -1415,7 +1481,7 @@ AppendUnicodeToUnicodeRep( * the reallocs below. */ - if (unicode >= stringPtr->unicode + if (unicode && unicode >= stringPtr->unicode && unicode <= stringPtr->unicode + stringPtr->maxChars) { offset = unicode - stringPtr->unicode; } @@ -1437,8 +1503,10 @@ AppendUnicodeToUnicodeRep( * trailing null. */ - memmove(stringPtr->unicode + stringPtr->numChars, unicode, - appendNumChars * sizeof(Tcl_UniChar)); + if (unicode) { + memmove(stringPtr->unicode + stringPtr->numChars, unicode, + appendNumChars * sizeof(Tcl_UniChar)); + } stringPtr->unicode[numChars] = 0; stringPtr->numChars = numChars; stringPtr->allocated = 0; @@ -1476,14 +1544,6 @@ AppendUnicodeToUtfRep( if (stringPtr->numChars != -1) { stringPtr->numChars += numChars; } - -#if COMPAT - /* - * Invalidate the unicode rep. - */ - - stringPtr->hasUnicode = 0; -#endif } /* @@ -1577,7 +1637,7 @@ AppendUtfToUtfRep( * the reallocs below. */ - if (bytes >= objPtr->bytes + if (bytes && bytes >= objPtr->bytes && bytes <= objPtr->bytes + objPtr->length) { offset = bytes - objPtr->bytes; } @@ -1605,7 +1665,9 @@ AppendUtfToUtfRep( stringPtr->numChars = -1; stringPtr->hasUnicode = 0; - memmove(objPtr->bytes + oldLength, bytes, numBytes); + if (bytes) { + memmove(objPtr->bytes + oldLength, bytes, numBytes); + } objPtr->bytes[newLength] = 0; objPtr->length = newLength; } @@ -1708,6 +1770,7 @@ Tcl_AppendFormatToObj( const char *span = format, *msg, *errCode; int numBytes = 0, objIndex = 0, gotXpg = 0, gotSequential = 0; int originalLength, limit; + Tcl_UniChar ch = 0; static const char *mixedXPG = "cannot mix \"%\" and \"%n$\" conversion specifiers"; static const char *const badIndex[2] = { @@ -1728,12 +1791,14 @@ Tcl_AppendFormatToObj( while (*format != '\0') { char *end; - int gotMinus, gotHash, gotZero, gotSpace, gotPlus, sawFlag; - int width, gotPrecision, precision, useShort, useWide, useBig; + int gotMinus = 0, gotHash = 0, gotZero = 0, gotSpace = 0, gotPlus = 0; + int width, gotPrecision, precision, sawFlag, useShort = 0, useBig = 0; +#ifndef TCL_WIDE_INT_IS_LONG + int useWide = 0; +#endif int newXpg, numChars, allocSegment = 0, segmentLimit, segmentNumBytes; Tcl_Obj *segment; - Tcl_UniChar ch; - int step = Tcl_UtfToUniChar(format, &ch); + int step = TclUtfToUniChar(format, &ch); format += step; if (ch != '%') { @@ -1757,7 +1822,7 @@ Tcl_AppendFormatToObj( * Step 0. Handle special case of escaped format marker (i.e., %%). */ - step = Tcl_UtfToUniChar(format, &ch); + step = TclUtfToUniChar(format, &ch); if (ch == '%') { span = format; numBytes = step; @@ -1777,7 +1842,7 @@ Tcl_AppendFormatToObj( newXpg = 1; objIndex = position - 1; format = end + 1; - step = Tcl_UtfToUniChar(format, &ch); + step = TclUtfToUniChar(format, &ch); } } if (newXpg) { @@ -1805,7 +1870,6 @@ Tcl_AppendFormatToObj( * Step 2. Set of flags. */ - gotMinus = gotHash = gotZero = gotSpace = gotPlus = 0; sawFlag = 1; do { switch (ch) { @@ -1829,7 +1893,7 @@ Tcl_AppendFormatToObj( } if (sawFlag) { format += step; - step = Tcl_UtfToUniChar(format, &ch); + step = TclUtfToUniChar(format, &ch); } } while (sawFlag); @@ -1840,8 +1904,13 @@ Tcl_AppendFormatToObj( width = 0; if (isdigit(UCHAR(ch))) { width = strtoul(format, &end, 10); + if (width < 0) { + msg = overflow; + errCode = "OVERFLOW"; + goto errorMsg; + } format = end; - step = Tcl_UtfToUniChar(format, &ch); + step = TclUtfToUniChar(format, &ch); } else if (ch == '*') { if (objIndex >= objc - 1) { msg = badIndex[gotXpg]; @@ -1857,7 +1926,7 @@ Tcl_AppendFormatToObj( } objIndex++; format += step; - step = Tcl_UtfToUniChar(format, &ch); + step = TclUtfToUniChar(format, &ch); } if (width > limit) { msg = overflow; @@ -1873,12 +1942,12 @@ Tcl_AppendFormatToObj( if (ch == '.') { gotPrecision = 1; format += step; - step = Tcl_UtfToUniChar(format, &ch); + step = TclUtfToUniChar(format, &ch); } if (isdigit(UCHAR(ch))) { precision = strtoul(format, &end, 10); format = end; - step = Tcl_UtfToUniChar(format, &ch); + step = TclUtfToUniChar(format, &ch); } else if (ch == '*') { if (objIndex >= objc - 1) { msg = badIndex[gotXpg]; @@ -1899,30 +1968,48 @@ Tcl_AppendFormatToObj( } objIndex++; format += step; - step = Tcl_UtfToUniChar(format, &ch); + step = TclUtfToUniChar(format, &ch); } /* * Step 5. Length modifier. */ - useShort = useWide = useBig = 0; if (ch == 'h') { useShort = 1; format += step; - step = Tcl_UtfToUniChar(format, &ch); + step = TclUtfToUniChar(format, &ch); } else if (ch == 'l') { format += step; - step = Tcl_UtfToUniChar(format, &ch); + step = TclUtfToUniChar(format, &ch); if (ch == 'l') { useBig = 1; format += step; - step = Tcl_UtfToUniChar(format, &ch); + step = TclUtfToUniChar(format, &ch); #ifndef TCL_WIDE_INT_IS_LONG } else { useWide = 1; #endif } + } else if (ch == 'I') { + if ((format[1] == '6') && (format[2] == '4')) { + format += (step + 2); + step = TclUtfToUniChar(format, &ch); +#ifndef TCL_WIDE_INT_IS_LONG + useWide = 1; +#endif + } else if ((format[1] == '3') && (format[2] == '2')) { + format += (step + 2); + step = TclUtfToUniChar(format, &ch); + } else { + format += step; + step = TclUtfToUniChar(format, &ch); + } + } else if ((ch == 't') || (ch == 'z') || (ch == 'q') || (ch == 'j') + || (ch == 'L')) { + format += step; + step = TclUtfToUniChar(format, &ch); + useBig = 1; } format += step; @@ -1954,13 +2041,17 @@ Tcl_AppendFormatToObj( } break; case 'c': { - char buf[TCL_UTF_MAX]; + char buf[4]; int code, length; if (TclGetIntFromObj(interp, segment, &code) != TCL_OK) { goto error; } length = Tcl_UniCharToUtf(code, buf); + if (!length) { + /* Special case for handling upper surrogates. */ + length = Tcl_UniCharToUtf(-1, buf); + } segment = Tcl_NewStringObj(buf, length); Tcl_IncrRefCount(segment); allocSegment = 1; @@ -1968,13 +2059,9 @@ Tcl_AppendFormatToObj( } case 'u': - if (useBig) { - msg = "unsigned bignum format is invalid"; - errCode = "BADUNSIGNED"; - goto errorMsg; - } case 'd': case 'o': + case 'p': case 'x': case 'X': case 'b': { @@ -1985,13 +2072,32 @@ Tcl_AppendFormatToObj( mp_int big; int toAppend, isNegative = 0; +#ifndef TCL_WIDE_INT_IS_LONG + if (ch == 'p') { + useWide = 1; + } +#endif if (useBig) { + int cmpResult; if (Tcl_GetBignumFromObj(interp, segment, &big) != TCL_OK) { goto error; } - isNegative = (mp_cmp_d(&big, 0) == MP_LT); + cmpResult = mp_cmp_d(&big, 0); + isNegative = (cmpResult == MP_LT); + if (cmpResult == MP_EQ) gotHash = 0; + if (ch == 'u') { + if (isNegative) { + mp_clear(&big); + msg = "unsigned bignum format is invalid"; + errCode = "BADUNSIGNED"; + goto errorMsg; + } else { + ch = 'd'; + } + } +#ifndef TCL_WIDE_INT_IS_LONG } else if (useWide) { - if (Tcl_GetWideIntFromObj(NULL, segment, &w) != TCL_OK) { + if (TclGetWideIntFromObj(NULL, segment, &w) != TCL_OK) { Tcl_Obj *objPtr; if (Tcl_GetBignumFromObj(interp,segment,&big) != TCL_OK) { @@ -2000,12 +2106,14 @@ Tcl_AppendFormatToObj( mp_mod_2d(&big, (int) CHAR_BIT*sizeof(Tcl_WideInt), &big); objPtr = Tcl_NewBignumObj(&big); Tcl_IncrRefCount(objPtr); - Tcl_GetWideIntFromObj(NULL, objPtr, &w); + TclGetWideIntFromObj(NULL, objPtr, &w); Tcl_DecrRefCount(objPtr); } isNegative = (w < (Tcl_WideInt) 0); + if (w == (Tcl_WideInt) 0) gotHash = 0; +#endif } else if (TclGetLongFromObj(NULL, segment, &l) != TCL_OK) { - if (Tcl_GetWideIntFromObj(NULL, segment, &w) != TCL_OK) { + if (TclGetWideIntFromObj(NULL, segment, &w) != TCL_OK) { Tcl_Obj *objPtr; if (Tcl_GetBignumFromObj(interp,segment,&big) != TCL_OK) { @@ -2022,14 +2130,18 @@ Tcl_AppendFormatToObj( if (useShort) { s = (short) l; isNegative = (s < (short) 0); + if (s == (short) 0) gotHash = 0; } else { isNegative = (l < (long) 0); + if (l == (long) 0) gotHash = 0; } } else if (useShort) { s = (short) l; isNegative = (s < (short) 0); + if (s == (short) 0) gotHash = 0; } else { isNegative = (l < (long) 0); + if (l == (long) 0) gotHash = 0; } segment = Tcl_NewObj(); @@ -2043,13 +2155,13 @@ Tcl_AppendFormatToObj( segmentLimit -= 1; } - if (gotHash) { + if (gotHash || (ch == 'p')) { switch (ch) { case 'o': - Tcl_AppendToObj(segment, "0", 1); - segmentLimit -= 1; - precision--; + Tcl_AppendToObj(segment, "0o", 2); + segmentLimit -= 2; break; + case 'p': case 'x': case 'X': Tcl_AppendToObj(segment, "0x", 2); @@ -2059,6 +2171,14 @@ Tcl_AppendFormatToObj( Tcl_AppendToObj(segment, "0b", 2); segmentLimit -= 2; break; +#if TCL_MAJOR_VERSION < 9 + case 'd': + if (gotZero) { + Tcl_AppendToObj(segment, "0d", 2); + segmentLimit -= 2; + } + break; +#endif } } @@ -2070,8 +2190,10 @@ Tcl_AppendFormatToObj( if (useShort) { pure = Tcl_NewIntObj((int) s); +#ifndef TCL_WIDE_INT_IS_LONG } else if (useWide) { pure = Tcl_NewWideIntObj(w); +#endif } else if (useBig) { pure = Tcl_NewBignumObj(&big); } else { @@ -2128,6 +2250,7 @@ Tcl_AppendFormatToObj( case 'u': case 'o': + case 'p': case 'x': case 'X': case 'b': { @@ -2154,6 +2277,7 @@ Tcl_AppendFormatToObj( numDigits++; us /= base; } +#ifndef TCL_WIDE_INT_IS_LONG } else if (useWide) { Tcl_WideUInt uw = (Tcl_WideUInt) w; @@ -2162,6 +2286,7 @@ Tcl_AppendFormatToObj( numDigits++; uw /= base; } +#endif } else if (useBig && big.used) { int leftover = (big.used * DIGIT_BIT) % numBits; mp_digit mask = (~(mp_digit)0) << (DIGIT_BIT-leftover); @@ -2191,7 +2316,7 @@ Tcl_AppendFormatToObj( * Need to be sure zero becomes "0", not "". */ - if ((numDigits == 0) && !((ch == 'o') && gotHash)) { + if (numDigits == 0) { numDigits = 1; } pure = Tcl_NewObj(); @@ -2211,7 +2336,11 @@ Tcl_AppendFormatToObj( } digitOffset = (int) (bits % base); if (digitOffset > 9) { - bytes[numDigits] = 'a' + digitOffset - 10; + if (ch == 'X') { + bytes[numDigits] = 'A' + digitOffset - 10; + } else { + bytes[numDigits] = 'a' + digitOffset - 10; + } } else { bytes[numDigits] = '0' + digitOffset; } @@ -2254,6 +2383,8 @@ Tcl_AppendFormatToObj( break; } + case 'a': + case 'A': case 'e': case 'E': case 'f': @@ -2289,7 +2420,7 @@ Tcl_AppendFormatToObj( p += sprintf(p, "%d", width); if (width > length) { length = width; - } + } } if (gotPrecision) { *p++ = '.'; @@ -2322,6 +2453,12 @@ Tcl_AppendFormatToObj( errCode = "OVERFLOW"; goto errorMsg; } + if (ch == 'A') { + char *p = TclGetString(segment) + 1; + *p = 'x'; + p = strchr(p, 'P'); + if (p) *p = 'p'; + } break; } default: @@ -2333,14 +2470,6 @@ Tcl_AppendFormatToObj( goto error; } - switch (ch) { - case 'E': - case 'G': - case 'X': { - Tcl_SetObjLength(segment, Tcl_UtfToUpper(TclGetString(segment))); - } - } - if (width>0 && numChars<0) { numChars = Tcl_GetCharLength(segment); } @@ -2354,7 +2483,7 @@ Tcl_AppendFormatToObj( } } - Tcl_GetStringFromObj(segment, &segmentNumBytes); + TclGetStringFromObj(segment, &segmentNumBytes); if (segmentNumBytes > limit) { if (allocSegment) { Tcl_DecrRefCount(segment); @@ -2406,7 +2535,7 @@ Tcl_AppendFormatToObj( /* *--------------------------------------------------------------------------- * - * Tcl_Format-- + * Tcl_Format -- * * Results: * A refcount zero Tcl_Obj. @@ -2517,6 +2646,7 @@ AppendPrintfToObjVA( case 'u': case 'd': case 'o': + case 'p': case 'x': case 'X': seekingConversion = 0; @@ -2530,15 +2660,30 @@ AppendPrintfToObjVA( Tcl_ListObjAppendElement(NULL, list, Tcl_NewLongObj( va_arg(argList, long))); break; + case 2: + Tcl_ListObjAppendElement(NULL, list, Tcl_NewWideIntObj( + va_arg(argList, Tcl_WideInt))); + break; + case 3: + Tcl_ListObjAppendElement(NULL, list, Tcl_NewBignumObj( + va_arg(argList, mp_int *))); + break; } break; + case 'a': + case 'A': case 'e': case 'E': case 'f': case 'g': case 'G': + if (size > 0) { Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj( - va_arg(argList, double))); + (double)va_arg(argList, long double))); + } else { + Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj( + va_arg(argList, double))); + } seekingConversion = 0; break; case '*': @@ -2558,9 +2703,35 @@ AppendPrintfToObjVA( gotPrecision = 1; p++; break; - /* TODO: support for wide (and bignum?) arguments */ case 'l': - size = 1; + ++size; + p++; + break; + case 't': + case 'z': + if (sizeof(size_t) == sizeof(Tcl_WideInt)) { + size = 2; + } + p++; + break; + case 'j': + case 'q': + size = 2; + p++; + break; + case 'I': + if (p[1]=='6' && p[2]=='4') { + p += 2; + size = 2; + } else if (p[1]=='3' && p[2]=='2') { + p += 2; + } else if (sizeof(size_t) == sizeof(Tcl_WideInt)) { + size = 2; + } + p++; + break; + case 'L': + size = 3; p++; break; case 'h': @@ -2638,14 +2809,923 @@ Tcl_ObjPrintf( /* *--------------------------------------------------------------------------- * - * TclStringObjReverse -- + * TclGetStringStorage -- + * + * Returns the string storage space of a Tcl_Obj. + * + * Results: + * The pointer value objPtr->bytes is returned and the number of bytes + * allocated there is written to *sizePtr (if known). + * + * Side effects: + * May set objPtr->bytes. + * + *--------------------------------------------------------------------------- + */ + +char * +TclGetStringStorage( + Tcl_Obj *objPtr, + unsigned int *sizePtr) +{ + String *stringPtr; + + if (objPtr->typePtr != &tclStringType || objPtr->bytes == NULL) { + return TclGetStringFromObj(objPtr, (int *)sizePtr); + } + + stringPtr = GET_STRING(objPtr); + *sizePtr = stringPtr->allocated; + return objPtr->bytes; +} + +/* + *--------------------------------------------------------------------------- + * + * TclStringRepeat -- + * + * Performs the [string repeat] function. + * + * Results: + * A (Tcl_Obj *) pointing to the result value, or NULL in case of an + * error. + * + * Side effects: + * On error, when interp is not NULL, error information is left in it. + * + *--------------------------------------------------------------------------- + */ + +Tcl_Obj * +TclStringRepeat( + Tcl_Interp *interp, + Tcl_Obj *objPtr, + int count, + int flags) +{ + Tcl_Obj *objResultPtr; + int inPlace = flags & TCL_STRING_IN_PLACE; + int length = 0, unichar = 0, done = 1; + int binary = TclIsPureByteArray(objPtr); + + /* assert (count >= 2) */ + + /* + * Analyze to determine what representation result should be. + * GOALS: Avoid shimmering & string rep generation. + * Produce pure bytearray when possible. + * Error on overflow. + */ + + if (!binary) { + if (objPtr->typePtr == &tclStringType) { + String *stringPtr = GET_STRING(objPtr); + if (stringPtr->hasUnicode) { + unichar = 1; + } + } + } + + if (binary) { + /* Result will be pure byte array. Pre-size it */ + Tcl_GetByteArrayFromObj(objPtr, &length); + } else if (unichar) { + /* Result will be pure Tcl_UniChar array. Pre-size it. */ + Tcl_GetUnicodeFromObj(objPtr, &length); + } else { + /* Result will be concat of string reps. Pre-size it. */ + Tcl_GetStringFromObj(objPtr, &length); + } + + if (length == 0) { + /* Any repeats of empty is empty. */ + return objPtr; + } + + if (count > INT_MAX/length) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "max size for a Tcl value (%d bytes) exceeded", INT_MAX)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return NULL; + } + + if (binary) { + /* Efficiently produce a pure byte array result */ + objResultPtr = (!inPlace || Tcl_IsShared(objPtr)) ? + Tcl_DuplicateObj(objPtr) : objPtr; + + Tcl_SetByteArrayLength(objResultPtr, count*length); /* PANIC? */ + Tcl_SetByteArrayLength(objResultPtr, length); + while (count - done > done) { + Tcl_AppendObjToObj(objResultPtr, objResultPtr); + done *= 2; + } + TclAppendBytesToByteArray(objResultPtr, + Tcl_GetByteArrayFromObj(objResultPtr, NULL), + (count - done) * length); + } else if (unichar) { + /* + * Efficiently produce a pure Tcl_UniChar array result. + */ + + if (!inPlace || Tcl_IsShared(objPtr)) { + objResultPtr = Tcl_NewUnicodeObj(Tcl_GetUnicode(objPtr), length); + } else { + TclInvalidateStringRep(objPtr); + objResultPtr = objPtr; + } + + if (0 == Tcl_AttemptSetObjLength(objResultPtr, count*length)) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "string size overflow: unable to alloc %" + TCL_Z_MODIFIER "u bytes", + STRING_SIZE(count*length))); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return NULL; + } + Tcl_SetObjLength(objResultPtr, length); + while (count - done > done) { + Tcl_AppendObjToObj(objResultPtr, objResultPtr); + done *= 2; + } + Tcl_AppendUnicodeToObj(objResultPtr, Tcl_GetUnicode(objResultPtr), + (count - done) * length); + } else { + /* + * Efficiently concatenate string reps. + */ + + if (!inPlace || Tcl_IsShared(objPtr)) { + objResultPtr = Tcl_NewStringObj(Tcl_GetString(objPtr), length); + } else { + TclFreeIntRep(objPtr); + objResultPtr = objPtr; + } + if (0 == Tcl_AttemptSetObjLength(objResultPtr, count*length)) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "string size overflow: unable to alloc %u bytes", + count*length)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return NULL; + } + Tcl_SetObjLength(objResultPtr, length); + while (count - done > done) { + Tcl_AppendObjToObj(objResultPtr, objResultPtr); + done *= 2; + } + Tcl_AppendToObj(objResultPtr, Tcl_GetString(objResultPtr), + (count - done) * length); + } + return objResultPtr; +} + +/* + *--------------------------------------------------------------------------- + * + * TclStringCat -- + * + * Performs the [string cat] function. + * + * Results: + * A (Tcl_Obj *) pointing to the result value, or NULL in case of an + * error. + * + * Side effects: + * On error, when interp is not NULL, error information is left in it. + * + *--------------------------------------------------------------------------- + */ + +Tcl_Obj * +TclStringCat( + Tcl_Interp *interp, + int objc, + Tcl_Obj * const objv[], + int flags) +{ + Tcl_Obj *objResultPtr, * const *ov; + int oc, length = 0, binary = 1; + int allowUniChar = 1, requestUniChar = 0; + int first = objc - 1; /* Index of first value possibly not empty */ + int last = 0; /* Index of last value possibly not empty */ + int inPlace = flags & TCL_STRING_IN_PLACE; + + /* assert ( objc >= 0 ) */ + + if (objc <= 1) { + /* Only one or no objects; return first or empty */ + return objc ? objv[0] : Tcl_NewObj(); + } + + /* assert ( objc >= 2 ) */ + + /* + * Analyze to determine what representation result should be. + * GOALS: Avoid shimmering & string rep generation. + * Produce pure bytearray when possible. + * Error on overflow. + */ + + ov = objv, oc = objc; + do { + Tcl_Obj *objPtr = *ov++; + + if (TclIsPureByteArray(objPtr)) { + allowUniChar = 0; + } else if (objPtr->bytes) { + /* Value has a string rep. */ + if (objPtr->length) { + /* + * Non-empty string rep. Not a pure bytearray, so we won't + * create a pure bytearray. + */ + + binary = 0; + if ((objPtr->typePtr) && (objPtr->typePtr != &tclStringType)) { + /* Prevent shimmer of non-string types. */ + allowUniChar = 0; + } + } + } else { + /* assert (objPtr->typePtr != NULL) -- stork! */ + binary = 0; + if (objPtr->typePtr == &tclStringType) { + /* Have a pure Unicode value; ask to preserve it */ + requestUniChar = 1; + } else { + /* Have another type; prevent shimmer */ + allowUniChar = 0; + } + } + } while (--oc && (binary || allowUniChar)); + + if (binary) { + /* + * Result will be pure byte array. Pre-size it + */ + + int numBytes; + ov = objv; + oc = objc; + do { + Tcl_Obj *objPtr = *ov++; + + /* + * Every argument is either a bytearray with a ("pure") + * value we know we can safely use, or it is an empty string. + * We don't need to count bytes for the empty strings. + */ + + if (TclIsPureByteArray(objPtr)) { + Tcl_GetByteArrayFromObj(objPtr, &numBytes); /* PANIC? */ + + if (numBytes) { + last = objc - oc; + if (length == 0) { + first = last; + } else if (numBytes > INT_MAX - length) { + goto overflow; + } + length += numBytes; + } + } + } while (--oc); + } else if (allowUniChar && requestUniChar) { + /* + * Result will be pure Tcl_UniChar array. Pre-size it. + */ + + ov = objv; + oc = objc; + do { + Tcl_Obj *objPtr = *ov++; + + if ((objPtr->bytes == NULL) || (objPtr->length)) { + int numChars; + + Tcl_GetUnicodeFromObj(objPtr, &numChars); /* PANIC? */ + if (numChars) { + last = objc - oc; + if (length == 0) { + first = last; + } else if (numChars > INT_MAX - length) { + goto overflow; + } + length += numChars; + } + } + } while (--oc); + } else { + /* Result will be concat of string reps. Pre-size it. */ + ov = objv; oc = objc; + do { + Tcl_Obj *pendingPtr = NULL; + + /* + * Loop until a possibly non-empty value is reached. + * Keep string rep generation pending when possible. + */ + + do { + /* assert ( pendingPtr == NULL ) */ + /* assert ( length == 0 ) */ + + Tcl_Obj *objPtr = *ov++; + + if (objPtr->bytes == NULL) { + /* No string rep; Take the chance we can avoid making it */ + pendingPtr = objPtr; + } else { + Tcl_GetStringFromObj(objPtr, &length); /* PANIC? */ + } + } while (--oc && (length == 0) && (pendingPtr == NULL)); + + /* + * Either we found a possibly non-empty value, and we remember + * this index as the first and last such value so far seen, + * or (oc == 0) and all values are known empty, + * so first = last = objc - 1 signals the right quick return. + */ + + first = last = objc - oc - 1; + + if (oc && (length == 0)) { + int numBytes; + + /* assert ( pendingPtr != NULL ) */ + + /* + * There's a pending value followed by more values. Loop over + * remaining values generating strings until a non-empty value + * is found, or the pending value gets its string generated. + */ + + do { + Tcl_Obj *objPtr = *ov++; + Tcl_GetStringFromObj(objPtr, &numBytes); /* PANIC? */ + } while (--oc && numBytes == 0 && pendingPtr->bytes == NULL); + + if (numBytes) { + last = objc -oc -1; + } + if (oc || numBytes) { + Tcl_GetStringFromObj(pendingPtr, &length); + } + if (length == 0) { + if (numBytes) { + first = last; + } + } else if (numBytes > INT_MAX - length) { + goto overflow; + } + length += numBytes; + } + } while (oc && (length == 0)); + + while (oc) { + int numBytes; + Tcl_Obj *objPtr = *ov++; + + /* assert ( length > 0 && pendingPtr == NULL ) */ + + Tcl_GetStringFromObj(objPtr, &numBytes); /* PANIC? */ + if (numBytes) { + last = objc - oc; + if (numBytes > INT_MAX - length) { + goto overflow; + } + length += numBytes; + } + --oc; + } + } + + if (last <= first /*|| length == 0 */) { + /* Only one non-empty value or zero length; return first */ + /* NOTE: (length == 0) implies (last <= first) */ + return objv[first]; + } + + objv += first; objc = (last - first + 1); + + if (binary) { + /* Efficiently produce a pure byte array result */ + unsigned char *dst; + + /* + * Broken interface! Byte array value routines offer no way to handle + * failure to allocate enough space. Following stanza may panic. + */ + + if (inPlace && !Tcl_IsShared(*objv)) { + int start; + + objResultPtr = *objv++; objc--; + Tcl_GetByteArrayFromObj(objResultPtr, &start); + dst = Tcl_SetByteArrayLength(objResultPtr, length) + start; + } else { + objResultPtr = Tcl_NewByteArrayObj(NULL, length); + dst = Tcl_SetByteArrayLength(objResultPtr, length); + } + while (objc--) { + Tcl_Obj *objPtr = *objv++; + + /* + * Every argument is either a bytearray with a ("pure") + * value we know we can safely use, or it is an empty string. + * We don't need to copy bytes from the empty strings. + */ + + if (TclIsPureByteArray(objPtr)) { + int more; + unsigned char *src = Tcl_GetByteArrayFromObj(objPtr, &more); + memcpy(dst, src, (size_t) more); + dst += more; + } + } + } else if (allowUniChar && requestUniChar) { + /* Efficiently produce a pure Tcl_UniChar array result */ + Tcl_UniChar *dst; + + if (inPlace && !Tcl_IsShared(*objv)) { + int start; + + objResultPtr = *objv++; objc--; + + /* Ugly interface! Force resize of the unicode array. */ + Tcl_GetUnicodeFromObj(objResultPtr, &start); + Tcl_InvalidateStringRep(objResultPtr); + if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "concatenation failed: unable to alloc %" + TCL_Z_MODIFIER "u bytes", + STRING_SIZE(length))); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return NULL; + } + dst = Tcl_GetUnicode(objResultPtr) + start; + } else { + Tcl_UniChar ch = 0; + + /* Ugly interface! No scheme to init array size. */ + objResultPtr = Tcl_NewUnicodeObj(&ch, 0); /* PANIC? */ + if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { + Tcl_DecrRefCount(objResultPtr); + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "concatenation failed: unable to alloc %" + TCL_Z_MODIFIER "u bytes", + STRING_SIZE(length))); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return NULL; + } + dst = Tcl_GetUnicode(objResultPtr); + } + while (objc--) { + Tcl_Obj *objPtr = *objv++; + + if ((objPtr->bytes == NULL) || (objPtr->length)) { + int more; + Tcl_UniChar *src = Tcl_GetUnicodeFromObj(objPtr, &more); + memcpy(dst, src, more * sizeof(Tcl_UniChar)); + dst += more; + } + } + } else { + /* Efficiently concatenate string reps */ + char *dst; + + if (inPlace && !Tcl_IsShared(*objv)) { + int start; + + objResultPtr = *objv++; objc--; + + Tcl_GetStringFromObj(objResultPtr, &start); + if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "concatenation failed: unable to alloc %u bytes", + length)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return NULL; + } + dst = Tcl_GetString(objResultPtr) + start; + + /* assert ( length > start ) */ + TclFreeIntRep(objResultPtr); + } else { + objResultPtr = Tcl_NewObj(); /* PANIC? */ + if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { + Tcl_DecrRefCount(objResultPtr); + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "concatenation failed: unable to alloc %u bytes", + length)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return NULL; + } + dst = Tcl_GetString(objResultPtr); + } + while (objc--) { + Tcl_Obj *objPtr = *objv++; + + if ((objPtr->bytes == NULL) || (objPtr->length)) { + int more; + char *src = Tcl_GetStringFromObj(objPtr, &more); + + memcpy(dst, src, (size_t) more); + dst += more; + } + } + /* Must NUL-terminate! */ + *dst = '\0'; + } + return objResultPtr; + + overflow: + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "max size for a Tcl value (%d bytes) exceeded", INT_MAX)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return NULL; +} + +/* + *--------------------------------------------------------------------------- + * + * TclStringCmp -- + * Compare two Tcl_Obj values as strings. + * + * Results: + * Like memcmp, return -1, 0, or 1. + * + * Side effects: + * String representations may be generated. Internal representation may + * be changed. + * + *--------------------------------------------------------------------------- + */ + +int TclStringCmp( + Tcl_Obj *value1Ptr, + Tcl_Obj *value2Ptr, + int checkEq, /* comparison is only for equality */ + int nocase, /* comparison is not case sensitive */ + int reqlength) /* requested length */ +{ + char *s1, *s2; + int empty, length, match, s1len, s2len; + memCmpFn_t memCmpFn; + + if ((reqlength == 0) || (value1Ptr == value2Ptr)) { + /* + * Always match at 0 chars of if it is the same obj. + */ + match = 0; + } else { + + if (!nocase && TclIsPureByteArray(value1Ptr) + && TclIsPureByteArray(value2Ptr)) { + /* + * Use binary versions of comparisons since that won't cause undue + * type conversions and it is much faster. Only do this if we're + * case-sensitive (which is all that really makes sense with byte + * arrays anyway, and we have no memcasecmp() for some reason... :^) + */ + + s1 = (char *) Tcl_GetByteArrayFromObj(value1Ptr, &s1len); + s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len); + memCmpFn = memcmp; + } else if ((value1Ptr->typePtr == &tclStringType) + && (value2Ptr->typePtr == &tclStringType)) { + /* + * Do a unicode-specific comparison if both of the args are of + * String type. If the char length == byte length, we can do a + * memcmp. In benchmark testing this proved the most efficient + * check between the unicode and string comparison operations. + */ + + if (nocase) { + s1 = (char *) Tcl_GetUnicodeFromObj(value1Ptr, &s1len); + s2 = (char *) Tcl_GetUnicodeFromObj(value2Ptr, &s2len); + memCmpFn = (memCmpFn_t)Tcl_UniCharNcasecmp; + } else { + s1len = Tcl_GetCharLength(value1Ptr); + s2len = Tcl_GetCharLength(value2Ptr); + if ((s1len == value1Ptr->length) + && (value1Ptr->bytes != NULL) + && (s2len == value2Ptr->length) + && (value2Ptr->bytes != NULL)) { + s1 = value1Ptr->bytes; + s2 = value2Ptr->bytes; + memCmpFn = memcmp; + } else { + s1 = (char *) Tcl_GetUnicode(value1Ptr); + s2 = (char *) Tcl_GetUnicode(value2Ptr); + if ( +#ifdef WORDS_BIGENDIAN + 1 +#else + checkEq +#endif + ) { + memCmpFn = memcmp; + s1len *= sizeof(Tcl_UniChar); + s2len *= sizeof(Tcl_UniChar); + } else { + memCmpFn = (memCmpFn_t) Tcl_UniCharNcmp; + } + } + } + } else { + if ((empty = TclCheckEmptyString(value1Ptr)) > 0) { + switch (TclCheckEmptyString(value2Ptr)) { + case -1: + s1 = 0; + s1len = 0; + s2 = TclGetStringFromObj(value2Ptr, &s2len); + break; + case 0: + match = -1; + goto matchdone; + case 1: + default: /* avoid warn: `s2` may be used uninitialized */ + match = 0; + goto matchdone; + } + } else if (TclCheckEmptyString(value2Ptr) > 0) { + switch (empty) { + case -1: + s2 = 0; + s2len = 0; + s1 = TclGetStringFromObj(value1Ptr, &s1len); + break; + case 0: + match = 1; + goto matchdone; + case 1: + default: /* avoid warn: `s1` may be used uninitialized */ + match = 0; + goto matchdone; + } + } else { + s1 = TclGetStringFromObj(value1Ptr, &s1len); + s2 = TclGetStringFromObj(value2Ptr, &s2len); + } + if (!nocase && checkEq) { + /* + * When we have equal-length we can check only for + * (in)equality. We can use memcmp in all (n)eq cases because + * we don't need to worry about lexical LE/BE variance. + */ + + memCmpFn = memcmp; + } else { + /* + * As a catch-all we will work with UTF-8. We cannot use + * memcmp() as that is unsafe with any string containing NUL + * (\xC0\x80 in Tcl's utf rep). We can use the more efficient + * TclpUtfNcmp2 if we are case-sensitive and no specific + * length was requested. + */ + + if ((reqlength < 0) && !nocase) { + memCmpFn = (memCmpFn_t) TclpUtfNcmp2; + } else { + s1len = Tcl_NumUtfChars(s1, s1len); + s2len = Tcl_NumUtfChars(s2, s2len); + memCmpFn = (memCmpFn_t) + (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp); + } + } + } + + length = (s1len < s2len) ? s1len : s2len; + if (reqlength > 0 && reqlength < length) { + length = reqlength; + } else if (reqlength < 0) { + /* + * The requested length is negative, so we ignore it by setting it + * to length + 1 so we correct the match var. + */ + + reqlength = length + 1; + } + + if (checkEq && (s1len != s2len)) { + match = 1; /* This will be reversed below. */ + } else { + /* + * The comparison function should compare up to the minimum byte + * length only. + */ + + match = memCmpFn(s1, s2, (size_t) length); + } + if ((match == 0) && (reqlength > length)) { + match = s1len - s2len; + } + match = (match > 0) ? 1 : (match < 0) ? -1 : 0; + } + matchdone: + return match; +} + +/* + *--------------------------------------------------------------------------- + * + * TclStringFirst -- + * + * Implements the [string first] operation. + * + * Results: + * If needle is found as a substring of haystack, the index of the + * first instance of such a find is returned. If needle is not present + * as a substring of haystack, -1 is returned. + * + * Side effects: + * needle and haystack may have their Tcl_ObjType changed. + * + *--------------------------------------------------------------------------- + */ + +int +TclStringFirst( + Tcl_Obj *needle, + Tcl_Obj *haystack, + int start) +{ + int lh, ln = Tcl_GetCharLength(needle); + + if (start < 0) { + start = 0; + } + if (ln == 0) { + /* We don't find empty substrings. Bizarre! + * Whenever this routine is turned into a proper substring + * finder, change to `return start` after limits imposed. */ + return -1; + } + + if (TclIsPureByteArray(needle) && TclIsPureByteArray(haystack)) { + unsigned char *end, *try, *bh; + unsigned char *bn = Tcl_GetByteArrayFromObj(needle, &ln); + + /* Find bytes in bytes */ + bh = Tcl_GetByteArrayFromObj(haystack, &lh); + end = bh + lh; + + try = bh + start; + while (try + ln <= end) { + /* + * Look for the leading byte of the needle in the haystack + * starting at try and stopping when there's not enough room + * for the needle left. + */ + try = memchr(try, bn[0], (end + 1 - ln) - try); + if (try == NULL) { + /* Leading byte not found -> needle cannot be found. */ + return -1; + } + /* Leading byte found, check rest of needle. */ + if (0 == memcmp(try+1, bn+1, ln-1)) { + /* Checks! Return the successful index. */ + return (try - bh); + } + /* Rest of needle match failed; Iterate to continue search. */ + try++; + } + return -1; + } + + /* + * TODO: It might be nice to support some cases where it is not + * necessary to shimmer to &tclStringType to compute the result, + * and instead operate just on the objPtr->bytes values directly. + * However, we also do not want the answer to change based on the + * code pathway, or if it does we want that to be for some values + * we explicitly decline to support. Getting there will involve + * locking down in practice more firmly just what encodings produce + * what supported results for the objPtr->bytes values. For now, + * do only the well-defined Tcl_UniChar array search. + */ + + { + Tcl_UniChar *try, *end, *uh; + Tcl_UniChar *un = Tcl_GetUnicodeFromObj(needle, &ln); + + uh = Tcl_GetUnicodeFromObj(haystack, &lh); + end = uh + lh; + + for (try = uh + start; try + ln <= end; try++) { + if ((*try == *un) && (0 == + memcmp(try + 1, un + 1, (ln-1) * sizeof(Tcl_UniChar)))) { + return (try - uh); + } + } + return -1; + } +} + +/* + *--------------------------------------------------------------------------- + * + * TclStringLast -- + * + * Implements the [string last] operation. + * + * Results: + * If needle is found as a substring of haystack, the index of the + * last instance of such a find is returned. If needle is not present + * as a substring of haystack, -1 is returned. + * + * Side effects: + * needle and haystack may have their Tcl_ObjType changed. + * + *--------------------------------------------------------------------------- + */ + +int +TclStringLast( + Tcl_Obj *needle, + Tcl_Obj *haystack, + int last) +{ + int lh, ln = Tcl_GetCharLength(needle); + + if (ln == 0) { + /* + * We don't find empty substrings. Bizarre! + * + * TODO: When we one day make this a true substring + * finder, change this to "return last", after limitation. + */ + return -1; + } + + lh = Tcl_GetCharLength(haystack); + if (last >= lh) { + last = lh - 1; + } + + if (last < ln - 1) { + return -1; + } + + if (TclIsPureByteArray(needle) && TclIsPureByteArray(haystack)) { + unsigned char *try, *bh = Tcl_GetByteArrayFromObj(haystack, &lh); + unsigned char *bn = Tcl_GetByteArrayFromObj(needle, &ln); + + try = bh + last + 1 - ln; + while (try >= bh) { + if ((*try == bn[0]) + && (0 == memcmp(try+1, bn+1, ln-1))) { + return (try - bh); + } + try--; + } + return -1; + } + + { + Tcl_UniChar *try, *uh = Tcl_GetUnicodeFromObj(haystack, &lh); + Tcl_UniChar *un = Tcl_GetUnicodeFromObj(needle, &ln); + + try = uh + last + 1 - ln; + while (try >= uh) { + if ((*try == un[0]) + && (0 == memcmp(try+1, un+1, (ln-1)*sizeof(Tcl_UniChar)))) { + return (try - uh); + } + try--; + } + return -1; + } +} + +/* + *--------------------------------------------------------------------------- + * + * TclStringReverse -- * * Implements the [string reverse] operation. * * Results: - * An unshared Tcl value which is the [string reverse] of the argument - * supplied. When sharing rules permit, the returned value might be the - * argument with modifications done in place. + * A Tcl value which is the [string reverse] of the argument supplied. + * When sharing rules permit and the caller requests, the returned value + * might be the argument with modifications done in place. * * Side effects: * May allocate a new Tcl_Obj. @@ -2657,18 +3737,20 @@ static void ReverseBytes( unsigned char *to, /* Copy bytes into here... */ unsigned char *from, /* ...from here... */ - int count) /* Until this many are copied, */ + int count) /* Until this many are copied, */ /* reversing as you go. */ { unsigned char *src = from + count; + if (to == from) { /* Reversing in place */ while (--src > to) { unsigned char c = *src; + *src = *to; *to++ = c; } - } else { + } else { while (--src >= from) { *to++ = *src; } @@ -2676,17 +3758,19 @@ ReverseBytes( } Tcl_Obj * -TclStringObjReverse( - Tcl_Obj *objPtr) +TclStringReverse( + Tcl_Obj *objPtr, + int flags) { String *stringPtr; - Tcl_UniChar ch; + Tcl_UniChar ch = 0; + int inPlace = flags & TCL_STRING_IN_PLACE; if (TclIsPureByteArray(objPtr)) { int numBytes; unsigned char *from = Tcl_GetByteArrayFromObj(objPtr, &numBytes); - if (Tcl_IsShared(objPtr)) { + if (!inPlace || Tcl_IsShared(objPtr)) { objPtr = Tcl_NewByteArrayObj(NULL, numBytes); } ReverseBytes(Tcl_GetByteArrayFromObj(objPtr, NULL), from, numBytes); @@ -2700,7 +3784,7 @@ TclStringObjReverse( Tcl_UniChar *from = Tcl_GetUnicode(objPtr); Tcl_UniChar *src = from + stringPtr->numChars; - if (Tcl_IsShared(objPtr)) { + if (!inPlace || Tcl_IsShared(objPtr)) { Tcl_UniChar *to; /* @@ -2708,7 +3792,6 @@ TclStringObjReverse( * Tcl_SetObjLength into growing the unicode rep buffer. */ - ch = 0; objPtr = Tcl_NewUnicodeObj(&ch, 1); Tcl_SetObjLength(objPtr, stringPtr->numChars); to = Tcl_GetUnicode(objPtr); @@ -2716,7 +3799,10 @@ TclStringObjReverse( *to++ = *src; } } else { - /* Reversing in place */ + /* + * Reversing in place. + */ + while (--src > from) { ch = *src; *src = *from; @@ -2730,7 +3816,7 @@ TclStringObjReverse( int numBytes = objPtr->length; char *to, *from = objPtr->bytes; - if (Tcl_IsShared(objPtr)) { + if (!inPlace || Tcl_IsShared(objPtr)) { objPtr = Tcl_NewObj(); Tcl_SetObjLength(objPtr, numBytes); } @@ -2740,21 +3826,23 @@ TclStringObjReverse( /* * Either numChars == -1 and we don't know how many chars are * represented by objPtr->bytes and we need Pass 1 just in case, - * or numChars >= 0 and we know we have fewer chars than bytes, - * so we know there's a multibyte character needing Pass 1. + * or numChars >= 0 and we know we have fewer chars than bytes, so + * we know there's a multibyte character needing Pass 1. * * Pass 1. Reverse the bytes of each multi-byte character. */ + int charCount = 0; int bytesLeft = numBytes; while (bytesLeft) { /* - * NOTE: We know that the from buffer is NUL-terminated. - * It's part of the contract for objPtr->bytes values. - * Thus, we can skip calling Tcl_UtfCharComplete() here. + * NOTE: We know that the from buffer is NUL-terminated. It's + * part of the contract for objPtr->bytes values. Thus, we can + * skip calling Tcl_UtfCharComplete() here. */ - int bytesInChar = Tcl_UtfToUniChar(from, &ch); + + int bytesInChar = TclUtfToUniChar(from, &ch); ReverseBytes((unsigned char *)to, (unsigned char *)from, bytesInChar); @@ -2777,6 +3865,150 @@ TclStringObjReverse( /* *--------------------------------------------------------------------------- * + * TclStringReplace -- + * + * Implements the inner engine of the [string replace] command. + * + * The result is a concatenation of a prefix from objPtr, characters + * 0 through first-1, the insertPtr string value, and a suffix from + * objPtr, characters from first + count to the end. The effect is as if + * the inner substring of characters first through first+count-1 are + * removed and replaced with insertPtr. If insertPtr is NULL, it is + * treated as an empty string. When passed the flag TCL_STRING_IN_PLACE, + * this routine will try to do the work within objPtr, so long as no + * sharing forbids it. Without that request, or as needed, a new Tcl + * value will be allocated to be the result. + * + * Results: + * A Tcl value that is the result of the substring replacement. May + * return NULL in case of an error. When NULL is returned and interp is + * non-NULL, error information is left in interp + * + *--------------------------------------------------------------------------- + */ + +Tcl_Obj * +TclStringReplace( + Tcl_Interp *interp, /* For error reporting, may be NULL */ + Tcl_Obj *objPtr, /* String to act upon */ + int first, /* First index to replace */ + int count, /* How many chars to replace */ + Tcl_Obj *insertPtr, /* Replacement string, may be NULL */ + int flags) /* TCL_STRING_IN_PLACE => attempt in-place */ +{ + int inPlace = flags & TCL_STRING_IN_PLACE; + Tcl_Obj *result; + + /* Caller is expected to pass sensible arguments */ + assert ( count >= 0 ) ; + assert ( first >= 0 ) ; + + /* Replace nothing with nothing */ + if ((insertPtr == NULL) && (count == 0)) { + if (inPlace) { + return objPtr; + } else { + return Tcl_DuplicateObj(objPtr); + } + } + + /* + * The caller very likely had to call Tcl_GetCharLength() or similar + * to be able to process index values. This means it is like that + * objPtr is either a proper "bytearray" or a "string" or else it has + * a known and short string rep. + */ + + if (TclIsPureByteArray(objPtr)) { + int numBytes; + unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &numBytes); + + if (insertPtr == NULL) { + /* Replace something with nothing. */ + + assert ( first <= numBytes ) ; + assert ( count <= numBytes ) ; + assert ( first + count <= numBytes ) ; + + result = Tcl_NewByteArrayObj(NULL, numBytes - count);/* PANIC? */ + TclAppendBytesToByteArray(result, bytes, first); + TclAppendBytesToByteArray(result, bytes + first + count, + numBytes - count - first); + return result; + } + + /* Replace everything */ + if ((first == 0) && (count == numBytes)) { + return insertPtr; + } + + if (TclIsPureByteArray(insertPtr)) { + int newBytes; + unsigned char *iBytes + = Tcl_GetByteArrayFromObj(insertPtr, &newBytes); + + if (count == newBytes && inPlace && !Tcl_IsShared(objPtr)) { + /* + * Removal count and replacement count are equal. + * Other conditions permit. Do in-place splice. + */ + + memcpy(bytes + first, iBytes, count); + Tcl_InvalidateStringRep(objPtr); + return objPtr; + } + + if (newBytes > INT_MAX - (numBytes - count)) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "max size for a Tcl value (%d bytes) exceeded", + INT_MAX)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return NULL; + } + result = Tcl_NewByteArrayObj(NULL, numBytes - count + newBytes); + /* PANIC? */ + Tcl_SetByteArrayLength(result, 0); + TclAppendBytesToByteArray(result, bytes, first); + TclAppendBytesToByteArray(result, iBytes, newBytes); + TclAppendBytesToByteArray(result, bytes + first + count, + numBytes - count - first); + return result; + } + + /* Flow through to try other approaches below */ + } + + /* + * TODO: Figure out how not to generate a Tcl_UniChar array rep + * when it can be determined objPtr->bytes points to a string of + * all single-byte characters so we can index it directly. + */ + + /* The traditional implementation... */ + { + int numChars; + Tcl_UniChar *ustring = Tcl_GetUnicodeFromObj(objPtr, &numChars); + + /* TODO: Is there an in-place option worth pursuing here? */ + + result = Tcl_NewUnicodeObj(ustring, first); + if (insertPtr) { + Tcl_AppendObjToObj(result, insertPtr); + } + if (first + count < numChars) { + Tcl_AppendUnicodeToObj(result, ustring + first + count, + numChars - first - count); + } + + return result; + } +} + +/* + *--------------------------------------------------------------------------- + * * FillUnicodeRep -- * * Populate the Unicode internal rep with the Unicode form of its string @@ -2811,7 +4043,7 @@ ExtendUnicodeRepWithString( { String *stringPtr = GET_STRING(objPtr); int needed, numOrigChars = 0; - Tcl_UniChar *dst; + Tcl_UniChar *dst, unichar = 0; if (stringPtr->hasUnicode) { numOrigChars = stringPtr->numChars; @@ -2821,16 +4053,21 @@ ExtendUnicodeRepWithString( } needed = numOrigChars + numAppendChars; stringCheckLimits(needed); - + if (needed > stringPtr->maxChars) { GrowUnicodeBuffer(objPtr, needed); stringPtr = GET_STRING(objPtr); } stringPtr->hasUnicode = 1; - stringPtr->numChars = needed; + if (bytes) { + stringPtr->numChars = needed; + } else { + numAppendChars = 0; + } for (dst=stringPtr->unicode + numOrigChars; numAppendChars-- > 0; dst++) { - bytes += TclUtfToUniChar(bytes, dst); + bytes += TclUtfToUniChar(bytes, &unichar); + *dst = unichar; } *dst = 0; } @@ -2863,7 +4100,6 @@ DupStringInternalRep( String *srcStringPtr = GET_STRING(srcPtr); String *copyStringPtr = NULL; -#if COMPAT==0 if (srcStringPtr->numChars == -1) { /* * The String struct in the source value holds zero useful data. Don't @@ -2906,41 +4142,6 @@ DupStringInternalRep( */ copyStringPtr->allocated = copyPtr->bytes ? copyPtr->length : 0; -#else /* COMPAT!=0 */ - /* - * If the src obj is a string of 1-byte Utf chars, then copy the string - * rep of the source object and create an "empty" Unicode internal rep for - * the new object. Otherwise, copy Unicode internal rep, and invalidate - * the string rep of the new object. - */ - - if (srcStringPtr->hasUnicode && srcStringPtr->numChars > 0) { - /* - * Copy the full allocation for the Unicode buffer. - */ - - copyStringPtr = stringAlloc(srcStringPtr->maxChars); - copyStringPtr->maxChars = srcStringPtr->maxChars; - memcpy(copyStringPtr->unicode, srcStringPtr->unicode, - srcStringPtr->numChars * sizeof(Tcl_UniChar)); - copyStringPtr->unicode[srcStringPtr->numChars] = 0; - copyStringPtr->allocated = 0; - } else { - copyStringPtr = stringAlloc(0); - copyStringPtr->unicode[0] = 0; - copyStringPtr->maxChars = 0; - - /* - * Tricky point: the string value was copied by generic object - * management code, so it doesn't contain any extra bytes that might - * exist in the source object. - */ - - copyStringPtr->allocated = copyPtr->length; - } - copyStringPtr->numChars = srcStringPtr->numChars; - copyStringPtr->hasUnicode = srcStringPtr->hasUnicode; -#endif /* COMPAT==0 */ SET_STRING(copyPtr, copyStringPtr); copyPtr->typePtr = &tclStringType; @@ -3017,8 +4218,18 @@ UpdateStringOfString( { String *stringPtr = GET_STRING(objPtr); + /* + * This routine is only called when we need to generate the + * string rep objPtr->bytes because it does not exist -- it is NULL. + * In that circumstance, any lingering claim about the size of + * memory pointed to by that NULL pointer is clearly bogus, and + * needs a reset. + */ + + stringPtr->allocated = 0; + if (stringPtr->numChars == 0) { - TclInitStringRep(objPtr, tclEmptyStringRep, 0); + TclInitStringRep(objPtr, &tclEmptyString, 0); } else { (void) ExtendStringRepWithUnicode(objPtr, stringPtr->unicode, stringPtr->numChars); @@ -3035,8 +4246,8 @@ ExtendStringRepWithUnicode( * Pre-condition: this is the "string" Tcl_ObjType. */ - int i, origLength, size = 0; - char *dst, buf[TCL_UTF_MAX]; + int i, origLength, size = 0; + char *dst; String *stringPtr = GET_STRING(objPtr); if (numChars < 0) { @@ -3051,18 +4262,18 @@ ExtendStringRepWithUnicode( objPtr->length = 0; } size = origLength = objPtr->length; - + /* * Quick cheap check in case we have more than enough room. */ - if (numChars <= (INT_MAX - size)/TCL_UTF_MAX + if (numChars <= (INT_MAX - size)/TCL_UTF_MAX && stringPtr->allocated >= size + numChars * TCL_UTF_MAX) { goto copyBytes; } for (i = 0; i < numChars && size >= 0; i++) { - size += Tcl_UniCharToUtf((int) unicode[i], buf); + size += TclUtfCount(unicode[i]); } if (size < 0) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); diff --git a/generic/tclStringRep.h b/generic/tclStringRep.h new file mode 100644 index 0000000..fc5a713 --- /dev/null +++ b/generic/tclStringRep.h @@ -0,0 +1,98 @@ +/* + * tclStringRep.h -- + * + * This file contains the definition of the Unicode string internal + * representation and macros to access it. + * + * A Unicode string is an internationalized string. Conceptually, a + * Unicode string is an array of 16-bit quantities organized as a + * sequence of properly formed UTF-8 characters. There is a one-to-one + * map between Unicode and UTF characters. Because Unicode characters + * have a fixed width, operations such as indexing operate on Unicode + * data. The String object is optimized for the case where each UTF char + * in a string is only one byte. In this case, we store the value of + * numChars, but we don't store the Unicode data (unless Tcl_GetUnicode + * is explicitly called). + * + * The String object type stores one or both formats. The default + * behavior is to store UTF. Once Unicode is calculated by a function, it + * is stored in the internal rep for future access (without an additional + * O(n) cost). + * + * To allow many appends to be done to an object without constantly + * reallocating the space for the string or Unicode representation, we + * allocate double the space for the string or Unicode and use the + * internal representation to keep track of how much space is used vs. + * allocated. + * + * Copyright (c) 1995-1997 Sun Microsystems, Inc. + * Copyright (c) 1999 by Scriptics Corporation. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +/* + * The following structure is the internal rep for a String object. It keeps + * track of how much memory has been used and how much has been allocated for + * the Unicode and UTF string to enable growing and shrinking of the UTF and + * Unicode reps of the String object with fewer mallocs. To optimize string + * length and indexing operations, this structure also stores the number of + * characters (same of UTF and Unicode!) once that value has been computed. + * + * Under normal configurations, what Tcl calls "Unicode" is actually UTF-16 + * restricted to the Basic Multilingual Plane (i.e. U+00000 to U+0FFFF). This + * can be officially modified by altering the definition of Tcl_UniChar in + * tcl.h, but do not do that unless you are sure what you're doing! + */ + +typedef struct { + int numChars; /* The number of chars in the string. -1 means + * this value has not been calculated. >= 0 + * means that there is a valid Unicode rep, or + * that the number of UTF bytes == the number + * of chars. */ + int allocated; /* The amount of space actually allocated for + * the UTF string (minus 1 byte for the + * termination char). */ + int maxChars; /* Max number of chars that can fit in the + * space allocated for the unicode array. */ + int hasUnicode; /* Boolean determining whether the string has + * a Unicode representation. */ + Tcl_UniChar unicode[1]; /* The array of Unicode chars. The actual size + * of this field depends on the 'maxChars' + * field above. */ +} String; + +#define STRING_MAXCHARS \ + (int)(((size_t)UINT_MAX - sizeof(String))/sizeof(Tcl_UniChar)) +#define STRING_SIZE(numChars) \ + (sizeof(String) + ((numChars) * sizeof(Tcl_UniChar))) +#define stringCheckLimits(numChars) \ + do { \ + if ((numChars) < 0 || (numChars) > STRING_MAXCHARS) { \ + Tcl_Panic("max length for a Tcl unicode value (%d chars) exceeded", \ + (int)STRING_MAXCHARS); \ + } \ + } while (0) +#define stringAttemptAlloc(numChars) \ + (String *) attemptckalloc(STRING_SIZE(numChars)) +#define stringAlloc(numChars) \ + (String *) ckalloc(STRING_SIZE(numChars)) +#define stringRealloc(ptr, numChars) \ + (String *) ckrealloc((ptr), STRING_SIZE(numChars)) +#define stringAttemptRealloc(ptr, numChars) \ + (String *) attemptckrealloc((ptr), STRING_SIZE(numChars)) +#define GET_STRING(objPtr) \ + ((String *) (objPtr)->internalRep.twoPtrValue.ptr1) +#define SET_STRING(objPtr, stringPtr) \ + ((objPtr)->internalRep.twoPtrValue.ptr2 = NULL), \ + ((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (stringPtr)) + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclStringTrim.h b/generic/tclStringTrim.h new file mode 100644 index 0000000..030e4ec --- /dev/null +++ b/generic/tclStringTrim.h @@ -0,0 +1,43 @@ +/* + * tclStringTrim.h -- + * + * This file contains the definition of what characters are to be trimmed + * from a string by [string trim] by default. It's only needed by Tcl's + * implementation; it does not form a public or private API at all. + * + * Copyright (c) 1987-1993 The Regents of the University of California. + * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 1998-2000 Scriptics Corporation. + * Copyright (c) 2002 ActiveState Corporation. + * Copyright (c) 2003-2013 Donal K. Fellows. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#ifndef TCL_STRING_TRIM_H +#define TCL_STRING_TRIM_H + +/* + * Default set of characters to trim in [string trim] and friends. This is a + * UTF-8 literal string containing all Unicode space characters. [TIP #413] + */ + +MODULE_SCOPE const char tclDefaultTrimSet[]; + +/* + * The whitespace trimming set used when [concat]enating. This is a subset of + * the above, and deliberately so. + */ + +#define CONCAT_TRIM_SET " \f\v\r\t\n" + +#endif /* TCL_STRING_TRIM_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 782bbdf..c4706df 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -31,22 +31,29 @@ #undef Tcl_NewIntObj #undef Tcl_NewListObj #undef Tcl_NewLongObj +#undef Tcl_DbNewLongObj #undef Tcl_NewObj #undef Tcl_NewStringObj +#undef Tcl_GetUnicode #undef Tcl_DumpActiveMemory #undef Tcl_ValidateAllMemory #undef Tcl_FindHashEntry #undef Tcl_CreateHashEntry #undef Tcl_Panic #undef Tcl_FindExecutable +#undef Tcl_SetPanicProc #undef TclpGetPid #undef TclSockMinimumBuffers -#define TclBackgroundException Tcl_BackgroundException #undef Tcl_SetIntObj +#undef Tcl_SetLongObj #undef TclpInetNtoa +#undef TclWinGetServByName +#undef TclWinGetSockOpt +#undef TclWinSetSockOpt +#undef TclWinNToHS /* See bug 510001: TclSockMinimumBuffers needs plat imp */ -#ifdef _WIN64 +#if defined(_WIN64) || defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 # define TclSockMinimumBuffersOld 0 #else #define TclSockMinimumBuffersOld sockMinimumBuffersOld @@ -56,6 +63,32 @@ static int TclSockMinimumBuffersOld(int sock, int size) } #endif +#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 +# define TclSetStartupScriptPath 0 +# define TclGetStartupScriptPath 0 +# define TclSetStartupScriptFileName 0 +# define TclGetStartupScriptFileName 0 +# define TclPrecTraceProc 0 +# define TclpInetNtoa 0 +# define TclWinGetServByName 0 +# define TclWinGetSockOpt 0 +# define TclWinSetSockOpt 0 +# define TclWinNToHS 0 +# define TclWinGetPlatformId 0 +# define TclWinResetInterfaces 0 +# define TclWinSetInterfaces 0 +# define TclWinGetPlatformId 0 +# define TclBNInitBignumFromWideUInt 0 +# define TclBNInitBignumFromWideInt 0 +# define TclBNInitBignumFromLong 0 +# define Tcl_Backslash 0 +# define Tcl_GetDefaultEncodingDir 0 +# define Tcl_SetDefaultEncodingDir 0 +# define Tcl_EvalTokens 0 +# define Tcl_CreateMathFunc 0 +# define Tcl_GetMathFuncInfo 0 +# define Tcl_ListMathFuncs 0 +#else #define TclSetStartupScriptPath setStartupScriptPath static void TclSetStartupScriptPath(Tcl_Obj *path) { @@ -79,18 +112,37 @@ static const char *TclGetStartupScriptFileName(void) if (path == NULL) { return NULL; } - return Tcl_GetStringFromObj(path, NULL); + return Tcl_GetString(path); } - #if defined(_WIN32) || defined(__CYGWIN__) #undef TclWinNToHS +#undef TclWinGetPlatformId +#undef TclWinResetInterfaces +#undef TclWinSetInterfaces +static void +doNothing(void) +{ + /* dummy implementation, no need to do anything */ +} #define TclWinNToHS winNToHS static unsigned short TclWinNToHS(unsigned short ns) { return ntohs(ns); } +#define TclWinGetPlatformId winGetPlatformId +static int +TclWinGetPlatformId(void) +{ + return 2; /* VER_PLATFORM_WIN32_NT */; +} +#define TclWinResetInterfaces doNothing +#define TclWinSetInterfaces (void (*) (int)) doNothing #endif +# define TclBNInitBignumFromWideUInt TclInitBignumFromWideUInt +# define TclBNInitBignumFromWideInt TclInitBignumFromWideInt +# define TclBNInitBignumFromLong TclInitBignumFromLong +#endif /* TCL_NO_DEPRECATED */ -#ifdef __WIN32__ +#ifdef _WIN32 # define TclUnixWaitForFile 0 # define TclUnixCopyFile 0 # define TclUnixOpenTemporaryFile 0 @@ -98,12 +150,15 @@ static unsigned short TclWinNToHS(unsigned short ns) { # define TclpIsAtty 0 #elif defined(__CYGWIN__) # define TclpIsAtty TclPlatIsAtty -# define TclWinSetInterfaces (void (*) (int)) doNothing +#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 +static void +doNothing(void) +{ + /* dummy implementation, no need to do anything */ +} +#endif # define TclWinAddProcess (void (*) (void *, unsigned int)) doNothing # define TclWinFlushDirtyChannels doNothing -# define TclWinResetInterfaces doNothing - -static Tcl_Encoding winTCharEncoding; static int TclpIsAtty(int fd) @@ -111,43 +166,41 @@ TclpIsAtty(int fd) return isatty(fd); } -int -TclWinGetPlatformId() -{ - /* Don't bother to determine the real platform on cygwin, - * because VER_PLATFORM_WIN32_NT is the only supported platform */ - return 2; /* VER_PLATFORM_WIN32_NT */; -} - void *TclWinGetTclInstance() { void *hInstance = NULL; GetModuleHandleExW(GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS, - (const char *)&winTCharEncoding, &hInstance); + (const char *)&TclpIsAtty, &hInstance); return hInstance; } -int +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 +#define TclWinSetSockOpt winSetSockOpt +static int TclWinSetSockOpt(SOCKET s, int level, int optname, const char *optval, int optlen) { return setsockopt((int) s, level, optname, optval, optlen); } -int +#define TclWinGetSockOpt winGetSockOpt +static int TclWinGetSockOpt(SOCKET s, int level, int optname, char *optval, int *optlen) { return getsockopt((int) s, level, optname, optval, optlen); } -struct servent * +#define TclWinGetServByName winGetServByName +static struct servent * TclWinGetServByName(const char *name, const char *proto) { return getservbyname(name, proto); } +#endif /* TCL_NO_DEPRECATED */ -char * +#define TclWinNoBackslash winNoBackslash +static char * TclWinNoBackslash(char *path) { char *p; @@ -166,23 +219,23 @@ TclpGetPid(Tcl_Pid pid) return (int) (size_t) pid; } -static void -doNothing(void) -{ - /* dummy implementation, no need to do anything */ -} - char * Tcl_WinUtfToTChar( const char *string, int len, Tcl_DString *dsPtr) { - if (!winTCharEncoding) { - winTCharEncoding = Tcl_GetEncoding(0, "unicode"); - } - return Tcl_UtfToExternalDString(winTCharEncoding, - string, len, dsPtr); + WCHAR *wp; + int size = MultiByteToWideChar(CP_UTF8, 0, string, len, 0, 0); + + Tcl_DStringInit(dsPtr); + Tcl_DStringSetLength(dsPtr, 2*size+2); + wp = (WCHAR *)Tcl_DStringValue(dsPtr); + MultiByteToWideChar(CP_UTF8, 0, string, len, wp, size+1); + if (len == -1) --size; /* account for 0-byte at string end */ + Tcl_DStringSetLength(dsPtr, 2*size); + wp[size] = 0; + return (char *)wp; } char * @@ -191,11 +244,21 @@ Tcl_WinTCharToUtf( int len, Tcl_DString *dsPtr) { - if (!winTCharEncoding) { - winTCharEncoding = Tcl_GetEncoding(0, "unicode"); + char *p; + int size; + + if (len > 0) { + len /= 2; } - return Tcl_ExternalToUtfDString(winTCharEncoding, - string, len, dsPtr); + size = WideCharToMultiByte(CP_UTF8, 0, string, len, 0, 0, NULL, NULL); + Tcl_DStringInit(dsPtr); + Tcl_DStringSetLength(dsPtr, size+1); + p = (char *)Tcl_DStringValue(dsPtr); + WideCharToMultiByte(CP_UTF8, 0, string, len, p, size, NULL, NULL); + if (len == -1) --size; /* account for 0-byte at string end */ + Tcl_DStringSetLength(dsPtr, size); + p[size] = 0; + return p; } #if defined(TCL_WIDE_INT_IS_LONG) @@ -204,28 +267,6 @@ Tcl_WinTCharToUtf( * signature. Tcl 9 must find a better solution, but that cannot be done * without introducing a binary incompatibility. */ -#define Tcl_DbNewLongObj ((Tcl_Obj*(*)(long,const char*,int))dbNewLongObj) -static Tcl_Obj *dbNewLongObj( - int intValue, - const char *file, - int line -) { -#ifdef TCL_MEM_DEBUG - register Tcl_Obj *objPtr; - - TclDbNewObj(objPtr, file, line); - objPtr->bytes = NULL; - - objPtr->internalRep.longValue = (long) intValue; - objPtr->typePtr = &tclIntType; - return objPtr; -#else - return Tcl_NewIntObj(intValue); -#endif -} -#define Tcl_GetLongFromObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))Tcl_GetIntFromObj -#define Tcl_NewLongObj (Tcl_Obj*(*)(long))Tcl_NewIntObj -#define Tcl_SetLongObj (void(*)(Tcl_Obj*,long))Tcl_SetIntObj static int exprInt(Tcl_Interp *interp, const char *expr, int *ptr){ long longValue; int result = Tcl_ExprLong(interp, expr, &longValue); @@ -234,9 +275,8 @@ static int exprInt(Tcl_Interp *interp, const char *expr, int *ptr){ && (longValue <= (long)(UINT_MAX))) { *ptr = (int)longValue; } else { - Tcl_SetResult(interp, - "integer value too large to represent as non-long integer", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "integer value too large to represent as non-long integer", -1)); result = TCL_ERROR; } } @@ -251,9 +291,8 @@ static int exprIntObj(Tcl_Interp *interp, Tcl_Obj*expr, int *ptr){ && (longValue <= (long)(UINT_MAX))) { *ptr = (int)longValue; } else { - Tcl_SetResult(interp, - "integer value too large to represent as non-long integer", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "integer value too large to represent as non-long integer", -1)); result = TCL_ERROR; } } @@ -276,17 +315,138 @@ static int uniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsig return Tcl_UniCharNcasecmp(ucs, uct, (unsigned long)n); } #define Tcl_UniCharNcasecmp (int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long))uniCharNcasecmp -static int formatInt(char *buffer, int n){ - return TclFormatInt(buffer, (long)n); -} -#define TclFormatInt (int(*)(char *, long))formatInt -#endif +#endif /* TCL_WIDE_INT_IS_LONG */ -#else /* UNIX and MAC */ +#endif /* __CYGWIN__ */ + +#if defined(TCL_NO_DEPRECATED) +# define Tcl_SeekOld 0 +# define Tcl_TellOld 0 +# undef Tcl_SetBooleanObj +# define Tcl_SetBooleanObj 0 +# undef Tcl_PkgPresent +# define Tcl_PkgPresent 0 +# undef Tcl_PkgProvide +# define Tcl_PkgProvide 0 +# undef Tcl_PkgRequire +# define Tcl_PkgRequire 0 +# undef Tcl_GetIndexFromObj +# define Tcl_GetIndexFromObj 0 +# define Tcl_NewBooleanObj 0 +# undef Tcl_DbNewBooleanObj +# define Tcl_DbNewBooleanObj 0 +# undef Tcl_SetBooleanObj +# define Tcl_SetBooleanObj 0 +# undef Tcl_SetVar +# define Tcl_SetVar 0 +# undef Tcl_UnsetVar +# define Tcl_UnsetVar 0 +# undef Tcl_GetVar +# define Tcl_GetVar 0 +# undef Tcl_TraceVar +# define Tcl_TraceVar 0 +# undef Tcl_UntraceVar +# define Tcl_UntraceVar 0 +# undef Tcl_VarTraceInfo +# define Tcl_VarTraceInfo 0 +# undef Tcl_UpVar +# define Tcl_UpVar 0 +# undef Tcl_AddErrorInfo +# define Tcl_AddErrorInfo 0 +# undef Tcl_AddObjErrorInfo +# define Tcl_AddObjErrorInfo 0 +# undef Tcl_Eval +# define Tcl_Eval 0 +# undef Tcl_GlobalEval +# define Tcl_GlobalEval 0 +# undef Tcl_SaveResult +# define Tcl_SaveResult 0 +# undef Tcl_RestoreResult +# define Tcl_RestoreResult 0 +# undef Tcl_DiscardResult +# define Tcl_DiscardResult 0 +# undef Tcl_SetResult +# define Tcl_SetResult 0 +# undef Tcl_EvalObj +# define Tcl_EvalObj 0 +# undef Tcl_GlobalEvalObj +# define Tcl_GlobalEvalObj 0 +# define TclBackgroundException 0 +# undef TclpReaddir +# define TclpReaddir 0 +# define TclSetStartupScript 0 +# define TclGetStartupScript 0 +# define TclCreateNamespace 0 +# define TclDeleteNamespace 0 +# define TclAppendExportList 0 +# define TclExport 0 +# define TclImport 0 +# define TclForgetImport 0 +# define TclGetCurrentNamespace_ 0 +# define TclGetGlobalNamespace_ 0 +# define TclFindNamespace 0 +# define TclFindCommand 0 +# define TclGetCommandFromObj 0 +# define TclGetCommandFullName 0 +# define TclCopyChannelOld 0 +# define Tcl_AppendResultVA 0 +# define Tcl_AppendStringsToObjVA 0 +# define Tcl_SetErrorCodeVA 0 +# define Tcl_PanicVA 0 +# define Tcl_VarEvalVA 0 +# undef TclpGetDate +# define TclpGetDate 0 +# undef TclpLocaltime +# define TclpLocaltime 0 +# undef TclpGmtime +# define TclpGmtime 0 +# define TclpLocaltime_unix 0 +# define TclpGmtime_unix 0 +# define Tcl_GetUnicode 0 +#else /* TCL_NO_DEPRECATED */ +# define Tcl_SeekOld seekOld +# define Tcl_TellOld tellOld +# define TclBackgroundException Tcl_BackgroundException +# define TclSetStartupScript Tcl_SetStartupScript +# define TclGetStartupScript Tcl_GetStartupScript +# define TclCreateNamespace Tcl_CreateNamespace +# define TclDeleteNamespace Tcl_DeleteNamespace +# define TclAppendExportList Tcl_AppendExportList +# define TclExport Tcl_Export +# define TclImport Tcl_Import +# define TclForgetImport Tcl_ForgetImport +# define TclGetCurrentNamespace_ Tcl_GetCurrentNamespace +# define TclGetGlobalNamespace_ Tcl_GetGlobalNamespace +# define TclFindNamespace Tcl_FindNamespace +# define TclFindCommand Tcl_FindCommand +# define TclGetCommandFromObj Tcl_GetCommandFromObj +# define TclGetCommandFullName Tcl_GetCommandFullName # define TclpLocaltime_unix TclpLocaltime # define TclpGmtime_unix TclpGmtime -#endif + +static int +seekOld( + Tcl_Channel chan, /* The channel on which to seek. */ + int offset, /* Offset to seek to. */ + int mode) /* Relative to which location to seek? */ +{ + Tcl_WideInt wOffset, wResult; + + wOffset = Tcl_LongAsWide((long) offset); + wResult = Tcl_Seek(chan, wOffset, mode); + return (int) Tcl_WideAsLong(wResult); +} + +static int +tellOld( + Tcl_Channel chan) /* The channel to return pos for. */ +{ + Tcl_WideInt wResult = Tcl_Tell(chan); + + return (int) Tcl_WideAsLong(wResult); +} +#endif /* !TCL_NO_DEPRECATED */ /* * WARNING: The contents of this file is automatically generated by the @@ -297,6 +457,15 @@ static int formatInt(char *buffer, int n){ MODULE_SCOPE const TclStubs tclStubs; MODULE_SCOPE const TclTomMathStubs tclTomMathStubs; +#ifdef __GNUC__ +/* + * The rest of this file shouldn't warn about deprecated functions; they're + * there because we intend them to be so and know that this file is OK to + * touch those fields. + */ +#pragma GCC diagnostic ignored "-Wdeprecated-declarations" +#endif + /* !BEGIN!: Do not edit below this line. */ static const TclIntStubs tclIntStubs = { @@ -414,22 +583,22 @@ static const TclIntStubs tclIntStubs = { TclUpdateReturnInfo, /* 109 */ TclSockMinimumBuffers, /* 110 */ Tcl_AddInterpResolvers, /* 111 */ - Tcl_AppendExportList, /* 112 */ - Tcl_CreateNamespace, /* 113 */ - Tcl_DeleteNamespace, /* 114 */ - Tcl_Export, /* 115 */ - Tcl_FindCommand, /* 116 */ - Tcl_FindNamespace, /* 117 */ + TclAppendExportList, /* 112 */ + TclCreateNamespace, /* 113 */ + TclDeleteNamespace, /* 114 */ + TclExport, /* 115 */ + TclFindCommand, /* 116 */ + TclFindNamespace, /* 117 */ Tcl_GetInterpResolvers, /* 118 */ Tcl_GetNamespaceResolvers, /* 119 */ Tcl_FindNamespaceVar, /* 120 */ - Tcl_ForgetImport, /* 121 */ - Tcl_GetCommandFromObj, /* 122 */ - Tcl_GetCommandFullName, /* 123 */ - Tcl_GetCurrentNamespace, /* 124 */ - Tcl_GetGlobalNamespace, /* 125 */ + TclForgetImport, /* 121 */ + TclGetCommandFromObj, /* 122 */ + TclGetCommandFullName, /* 123 */ + TclGetCurrentNamespace_, /* 124 */ + TclGetGlobalNamespace_, /* 125 */ Tcl_GetVariableFullName, /* 126 */ - Tcl_Import, /* 127 */ + TclImport, /* 127 */ Tcl_PopCallFrame, /* 128 */ Tcl_PushCallFrame, /* 129 */ Tcl_RemoveInterpResolvers, /* 130 */ @@ -480,8 +649,8 @@ static const TclIntStubs tclIntStubs = { TclCallVarTraces, /* 175 */ TclCleanupVar, /* 176 */ TclVarErrMsg, /* 177 */ - Tcl_SetStartupScript, /* 178 */ - Tcl_GetStartupScript, /* 179 */ + TclSetStartupScript, /* 178 */ + TclGetStartupScript, /* 179 */ 0, /* 180 */ 0, /* 181 */ TclpLocaltime, /* 182 */ @@ -553,12 +722,18 @@ static const TclIntStubs tclIntStubs = { TclCopyChannel, /* 248 */ TclDoubleDigits, /* 249 */ TclSetSlaveCancelFlags, /* 250 */ + TclRegisterLiteral, /* 251 */ + TclPtrGetVar, /* 252 */ + TclPtrSetVar, /* 253 */ + TclPtrIncrObjVar, /* 254 */ + TclPtrObjMakeUpvar, /* 255 */ + TclPtrUnsetVar, /* 256 */ }; static const TclIntPlatStubs tclIntPlatStubs = { TCL_STUB_MAGIC, 0, -#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ TclGetAndDetachPids, /* 0 */ TclpCloseFile, /* 1 */ TclpCreateCommandChannel, /* 2 */ @@ -591,7 +766,7 @@ static const TclIntPlatStubs tclIntPlatStubs = { TclWinCPUID, /* 29 */ TclUnixOpenTemporaryFile, /* 30 */ #endif /* UNIX */ -#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ TclWinConvertError, /* 0 */ TclWinConvertWSAError, /* 1 */ TclWinGetServByName, /* 2 */ @@ -662,7 +837,7 @@ static const TclIntPlatStubs tclIntPlatStubs = { static const TclPlatStubs tclPlatStubs = { TCL_STUB_MAGIC, 0, -#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ Tcl_WinUtfToTChar, /* 0 */ Tcl_WinTCharToUtf, /* 1 */ #endif /* WIN */ @@ -739,6 +914,15 @@ const TclTomMathStubs tclTomMathStubs = { TclBN_mp_init_set_int, /* 61 */ TclBN_mp_set_int, /* 62 */ TclBN_mp_cnt_lsb, /* 63 */ + TclBNInitBignumFromLong, /* 64 */ + TclBNInitBignumFromWideInt, /* 65 */ + TclBNInitBignumFromWideUInt, /* 66 */ + TclBN_mp_expt_d_ex, /* 67 */ + TclBN_mp_set_long_long, /* 68 */ + TclBN_mp_get_long_long, /* 69 */ + TclBN_mp_set_long, /* 70 */ + TclBN_mp_get_long, /* 71 */ + TclBN_mp_get_int, /* 72 */ }; static const TclStubHooks tclStubHooks = { @@ -759,19 +943,19 @@ const TclStubs tclStubs = { Tcl_DbCkalloc, /* 6 */ Tcl_DbCkfree, /* 7 */ Tcl_DbCkrealloc, /* 8 */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ Tcl_CreateFileHandler, /* 9 */ #endif /* UNIX */ -#if defined(__WIN32__) /* WIN */ +#if defined(_WIN32) /* WIN */ 0, /* 9 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ Tcl_CreateFileHandler, /* 9 */ #endif /* MACOSX */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ Tcl_DeleteFileHandler, /* 10 */ #endif /* UNIX */ -#if defined(__WIN32__) /* WIN */ +#if defined(_WIN32) /* WIN */ 0, /* 10 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ @@ -933,10 +1117,10 @@ const TclStubs tclStubs = { Tcl_GetMaster, /* 164 */ Tcl_GetNameOfExecutable, /* 165 */ Tcl_GetObjResult, /* 166 */ -#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ Tcl_GetOpenFile, /* 167 */ #endif /* UNIX */ -#if defined(__WIN32__) /* WIN */ +#if defined(_WIN32) /* WIN */ 0, /* 167 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ @@ -1405,6 +1589,7 @@ const TclStubs tclStubs = { Tcl_FindSymbol, /* 628 */ Tcl_FSUnloadFile, /* 629 */ Tcl_ZlibStreamSetCompressionDictionary, /* 630 */ + Tcl_OpenTcpServerEx, /* 631 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c index 859cbf9..5261591 100644 --- a/generic/tclStubLib.c +++ b/generic/tclStubLib.c @@ -24,13 +24,10 @@ const TclIntStubs *tclIntStubsPtr = NULL; const TclIntPlatStubs *tclIntPlatStubsPtr = NULL; /* - * Use our own isDigit to avoid linking to libc on windows + * Use our own ISDIGIT to avoid linking to libc on windows */ -static int isDigit(const int c) -{ - return (c >= '0' && c <= '9'); -} +#define ISDIGIT(c) (((unsigned)((c)-'0')) <= 9) /* *---------------------------------------------------------------------- @@ -54,7 +51,8 @@ MODULE_SCOPE const char * Tcl_InitStubs( Tcl_Interp *interp, const char *version, - int exact) + int exact, + int magic) { Interp *iPtr = (Interp *) interp; const char *actualVersion = NULL; @@ -67,9 +65,9 @@ Tcl_InitStubs( * times. [Bug 615304] */ - if (!stubsPtr || (stubsPtr->magic != TCL_STUB_MAGIC)) { - iPtr->result = "interpreter uses an incompatible stubs mechanism"; - iPtr->freeProc = TCL_STATIC; + if (!stubsPtr || (stubsPtr->magic != (((exact&0xff00) >= 0x900) ? magic : TCL_STUB_MAGIC))) { + iPtr->result = (char *)"interpreter uses an incompatible stubs mechanism"; + iPtr->freeProc = 0; return NULL; } @@ -77,12 +75,12 @@ Tcl_InitStubs( if (actualVersion == NULL) { return NULL; } - if (exact) { + if (exact&1) { const char *p = version; int count = 0; while (*p) { - count += !isDigit(*p++); + count += !ISDIGIT(*p++); } if (count == 1) { const char *q = actualVersion; @@ -91,7 +89,7 @@ Tcl_InitStubs( while (*p && (*p == *q)) { p++; q++; } - if (*p || isDigit(*q)) { + if (*p || ISDIGIT(*q)) { /* Construct error message */ stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL); return NULL; @@ -103,12 +101,16 @@ Tcl_InitStubs( } } } - tclStubsPtr = (TclStubs *)pkgData; + if (((exact&0xff00) < 0x900)) { + /* We are running Tcl 8.x */ + stubsPtr = (TclStubs *)pkgData; + } + tclStubsPtr = stubsPtr; - if (tclStubsPtr->hooks) { - tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs; - tclIntStubsPtr = tclStubsPtr->hooks->tclIntStubs; - tclIntPlatStubsPtr = tclStubsPtr->hooks->tclIntPlatStubs; + if (stubsPtr->hooks) { + tclPlatStubsPtr = stubsPtr->hooks->tclPlatStubs; + tclIntStubsPtr = stubsPtr->hooks->tclIntStubs; + tclIntPlatStubsPtr = stubsPtr->hooks->tclIntPlatStubs; } else { tclPlatStubsPtr = NULL; tclIntStubsPtr = NULL; diff --git a/generic/tclTest.c b/generic/tclTest.c index 27ee89c..48b4761 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -42,16 +42,8 @@ * Declare external functions used in Windows tests. */ -/* - * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the - * Tcltest_Init declaration is in the source file itself, which is only - * accessed when we are building a library. - */ - -#undef TCL_STORAGE_CLASS -#define TCL_STORAGE_CLASS DLLEXPORT -EXTERN int Tcltest_Init(Tcl_Interp *interp); -EXTERN int Tcltest_SafeInit(Tcl_Interp *interp); +DLLEXPORT int Tcltest_Init(Tcl_Interp *interp); +DLLEXPORT int Tcltest_SafeInit(Tcl_Interp *interp); /* * Dynamic string shared by TestdcallCmd and DelCallbackProc; used to collect @@ -75,6 +67,18 @@ typedef struct TestAsyncHandler { /* Next is list of handlers. */ } TestAsyncHandler; +/* + * Start of the socket driver state structure to acces field testFlags + */ + +typedef struct TcpState TcpState; + +struct TcpState { + Tcl_Channel channel; /* Channel associated with this socket. */ + int testFlags; /* bit field for tests. Is set by testsocket + * test procedure */ +}; + TCL_DECLARE_MUTEX(asyncTestMutex) static TestAsyncHandler *firstHandler = NULL; @@ -98,7 +102,7 @@ static Tcl_Trace cmdTrace; * TestdelCmd: */ -typedef struct DelCmd { +typedef struct { Tcl_Interp *interp; /* Interpreter in which command exists. */ char *deleteCmd; /* Script to execute when command is deleted. * Malloc'ed. */ @@ -109,7 +113,7 @@ typedef struct DelCmd { * command. */ -typedef struct TclEncoding { +typedef struct { Tcl_Interp *interp; char *toUtfCmd; char *fromUtfCmd; @@ -132,7 +136,7 @@ static int exitMainLoop = 0; * Event structure used in testing the event queue management procedures. */ -typedef struct TestEvent { +typedef struct { Tcl_Event header; /* Header common to all events */ Tcl_Interp *interp; /* Interpreter that will handle the event */ Tcl_Obj *command; /* Command to evaluate when the event occurs */ @@ -157,7 +161,7 @@ static TestChannel *firstDetached; static int AsyncHandlerProc(ClientData clientData, Tcl_Interp *interp, int code); -#ifdef TCL_THREADS +#if TCL_THREADS static Tcl_ThreadCreateType AsyncThreadProc(ClientData); #endif static void CleanupTestSetassocdataTests( @@ -201,8 +205,9 @@ static int EncodingFromUtfProc(ClientData clientData, int *dstCharsPtr); static void ExitProcEven(ClientData clientData); static void ExitProcOdd(ClientData clientData); -static int GetTimesCmd(ClientData clientData, - Tcl_Interp *interp, int argc, const char **argv); +static int GetTimesObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); static void MainLoop(void); static int NoopCmd(ClientData clientData, Tcl_Interp *interp, int argc, const char **argv); @@ -219,6 +224,12 @@ static void SpecialFree(char *blockPtr); static int StaticInitProc(Tcl_Interp *interp); static int TestasyncCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); +static int TestbytestringObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int TeststringbytesObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); static int TestcmdinfoCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestcmdtokenCmd(ClientData dummy, @@ -282,6 +293,8 @@ static int TestgetassocdataCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestgetintCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); +static int TestlongsizeCmd(ClientData dummy, + Tcl_Interp *interp, int argc, const char **argv); static int TestgetplatformCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestgetvarfullnameCmd( @@ -294,12 +307,6 @@ static int TestlinkCmd(ClientData dummy, static int TestlocaleCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestMathFunc(ClientData clientData, - Tcl_Interp *interp, Tcl_Value *args, - Tcl_Value *resultPtr); -static int TestMathFunc2(ClientData clientData, - Tcl_Interp *interp, Tcl_Value *args, - Tcl_Value *resultPtr); static int TestmainthreadCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestsetmainloopCmd(ClientData dummy, @@ -319,6 +326,12 @@ static int TestparsevarObjCmd(ClientData dummy, static int TestparsevarnameObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static int TestpreferstableObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int TestprintObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); static int TestregexpObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -327,12 +340,10 @@ static int TestreturnObjCmd(ClientData dummy, Tcl_Obj *const objv[]); static void TestregexpXflags(const char *string, int length, int *cflagsPtr, int *eflagsPtr); -#ifndef TCL_NO_DEPRECATED static int TestsaveresultCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static void TestsaveresultFree(char *blockPtr); -#endif /* TCL_NO_DEPRECATED */ static int TestsetassocdataCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestsetCmd(ClientData dummy, @@ -362,6 +373,8 @@ static int TestChannelCmd(ClientData clientData, Tcl_Interp *interp, int argc, const char **argv); static int TestChannelEventCmd(ClientData clientData, Tcl_Interp *interp, int argc, const char **argv); +static int TestSocketCmd(ClientData clientData, + Tcl_Interp *interp, int argc, const char **argv); static int TestFilesystemObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -405,16 +418,27 @@ static Tcl_FSMatchInDirectoryProc SimpleMatchInDirectory; static int TestNumUtfCharsCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static int TestFindFirstCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int TestFindLastCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); static int TestHashSystemHashCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); + +static Tcl_NRPostProc NREUnwind_callback; +static int TestNREUnwind(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); static int TestNRELevels(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestInterpResolverCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -#if defined(HAVE_CPUID) || defined(__WIN32__) +#if defined(HAVE_CPUID) || defined(_WIN32) static int TestcpuidCmd(ClientData dummy, Tcl_Interp* interp, int objc, Tcl_Obj *const objv[]); @@ -525,10 +549,6 @@ int Tcltest_Init( Tcl_Interp *interp) /* Interpreter for application. */ { -#ifndef TCL_NO_DEPRECATED - Tcl_ValueType t3ArgTypes[2]; -#endif /* TCL_NO_DEPRECATED */ - Tcl_Obj *listPtr; Tcl_Obj **objv; int objc, index; @@ -537,10 +557,10 @@ Tcltest_Init( "-appinitprocclosestderr", "-appinitprocsetrcfile", NULL }; - if (Tcl_InitStubs(interp, "8.5", 0) == NULL) { + if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { return TCL_ERROR; } - if (Tcl_TomMath_InitStubs(interp, "8.5") == NULL) { + if (Tcl_TomMath_InitStubs(interp, "8.5-") == NULL) { return TCL_ERROR; } if (Tcl_OOInitStubs(interp) == NULL) { @@ -548,7 +568,7 @@ Tcltest_Init( } /* TIP #268: Full patchlevel instead of just major.minor */ - if (Tcl_PkgProvide(interp, "Tcltest", TCL_PATCH_LEVEL) == TCL_ERROR) { + if (Tcl_PkgProvideEx(interp, "Tcltest", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) { return TCL_ERROR; } @@ -556,9 +576,11 @@ Tcltest_Init( * Create additional commands and math functions for testing Tcl. */ - Tcl_CreateCommand(interp, "gettimes", GetTimesCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "gettimes", GetTimesObjCmd, NULL, NULL); Tcl_CreateCommand(interp, "noop", NoopCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testbytestring", TestbytestringObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "teststringbytes", TeststringbytesObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd, @@ -625,6 +647,8 @@ Tcltest_Init( NULL, NULL); Tcl_CreateCommand(interp, "testgetint", TestgetintCmd, NULL, NULL); + Tcl_CreateCommand(interp, "testlongsize", TestlongsizeCmd, + NULL, NULL); Tcl_CreateCommand(interp, "testgetplatform", TestgetplatformCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testgetvarfullname", @@ -642,14 +666,16 @@ Tcltest_Init( NULL, NULL); Tcl_CreateObjCommand(interp, "testparsevarname", TestparsevarnameObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testpreferstable", TestpreferstableObjCmd, + NULL, NULL); + Tcl_CreateObjCommand(interp, "testprint", TestprintObjCmd, + NULL, NULL); Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd, NULL, NULL); -#ifndef TCL_NO_DEPRECATED Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd, NULL, NULL); -#endif /* TCL_NO_DEPRECATED */ Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd, @@ -664,34 +690,31 @@ Tcltest_Init( TestsetobjerrorcodeCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testnumutfchars", TestNumUtfCharsCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testfindfirst", + TestFindFirstCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testfindlast", + TestFindLastCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd, NULL, NULL); + Tcl_CreateCommand(interp, "testsocket", TestSocketCmd, + NULL, NULL); Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd, NULL, NULL); Tcl_CreateCommand(interp, "testtranslatefilename", TesttranslatefilenameCmd, NULL, NULL); Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, NULL, NULL); -#ifndef TCL_NO_DEPRECATED - Tcl_CreateMathFunc(interp, "T1", 0, NULL, TestMathFunc, (ClientData) 123); - Tcl_CreateMathFunc(interp, "T2", 0, NULL, TestMathFunc, (ClientData) 345); -#endif /* TCL_NO_DEPRECATED */ Tcl_CreateCommand(interp, "testmainthread", TestmainthreadCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetmainloop", TestsetmainloopCmd, NULL, NULL); Tcl_CreateCommand(interp, "testexitmainloop", TestexitmainloopCmd, NULL, NULL); -#if defined(HAVE_CPUID) || defined(__WIN32__) +#if defined(HAVE_CPUID) || defined(_WIN32) Tcl_CreateObjCommand(interp, "testcpuid", TestcpuidCmd, (ClientData) 0, NULL); #endif -#ifndef TCL_NO_DEPRECATED - t3ArgTypes[0] = TCL_EITHER; - t3ArgTypes[1] = TCL_EITHER; - Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2, - NULL); -#endif /* TCL_NO_DEPRECATED */ - + Tcl_CreateObjCommand(interp, "testnreunwind", TestNREUnwind, + NULL, NULL); Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels, NULL, NULL); Tcl_CreateObjCommand(interp, "testinterpresolver", TestInterpResolverCmd, @@ -703,7 +726,7 @@ Tcltest_Init( if (Procbodytest_Init(interp) != TCL_OK) { return TCL_ERROR; } -#ifdef TCL_THREADS +#if TCL_THREADS if (TclThread_Init(interp) != TCL_OK) { return TCL_ERROR; } @@ -772,7 +795,7 @@ int Tcltest_SafeInit( Tcl_Interp *interp) /* Interpreter for application. */ { - if (Tcl_InitStubs(interp, "8.5", 0) == NULL) { + if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { return TCL_ERROR; } return Procbodytest_SafeInit(interp); @@ -809,7 +832,7 @@ TestasyncCmd( if (argc < 2) { wrongNumArgs: - Tcl_SetResult(interp, "wrong # args", TCL_STATIC); + Tcl_AppendResult(interp, "wrong # args", NULL); return TCL_ERROR; } if (strcmp(argv[1], "create") == 0) { @@ -883,7 +906,7 @@ TestasyncCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj(argv[3], -1)); Tcl_MutexUnlock(&asyncTestMutex); return code; -#ifdef TCL_THREADS +#if TCL_THREADS } else if (strcmp(argv[1], "marklater") == 0) { if (argc != 3) { goto wrongNumArgs; @@ -899,7 +922,7 @@ TestasyncCmd( if (Tcl_CreateThread(&threadID, AsyncThreadProc, INT2PTR(id), TCL_THREAD_STACK_DEFAULT, TCL_THREAD_NOFLAGS) != TCL_OK) { - Tcl_SetResult(interp, "can't create thread", TCL_STATIC); + Tcl_AppendResult(interp, "can't create thread", NULL); Tcl_MutexUnlock(&asyncTestMutex); return TCL_ERROR; } @@ -923,7 +946,7 @@ TestasyncCmd( static int AsyncHandlerProc( - ClientData clientData, /* If of TestAsyncHandler structure. + ClientData clientData, /* If of TestAsyncHandler structure. * in global list. */ Tcl_Interp *interp, /* Interpreter in which command was * executed, or NULL. */ @@ -953,7 +976,7 @@ AsyncHandlerProc( listArgv[3] = NULL; cmd = Tcl_Merge(3, listArgv); if (interp != NULL) { - code = Tcl_Eval(interp, cmd); + code = Tcl_EvalEx(interp, cmd, -1, 0); } else { /* * this should not happen, but by definition of how async handlers are @@ -980,7 +1003,7 @@ AsyncHandlerProc( *---------------------------------------------------------------------- */ -#ifdef TCL_THREADS +#if TCL_THREADS static Tcl_ThreadCreateType AsyncThreadProc( ClientData clientData) /* Parameter is the id of a @@ -1046,7 +1069,7 @@ TestcmdinfoCmd( Tcl_DStringResult(interp, &delString); } else if (strcmp(argv[1], "get") == 0) { if (Tcl_GetCommandInfo(interp, argv[2], &info) ==0) { - Tcl_SetResult(interp, "??", TCL_STATIC); + Tcl_AppendResult(interp, "??", NULL); return TCL_OK; } if (info.proc == CmdProc1) { @@ -1173,7 +1196,7 @@ TestcmdtokenCmd( token = Tcl_CreateCommand(interp, argv[2], CmdProc1, (ClientData) "original", NULL); sprintf(buf, "%p", (void *)token); - Tcl_SetResult(interp, buf, TCL_VOLATILE); + Tcl_AppendResult(interp, buf, NULL); } else if (strcmp(argv[1], "name") == 0) { Tcl_Obj *objPtr; @@ -1236,7 +1259,7 @@ TestcmdtraceCmd( if (strcmp(argv[1], "tracetest") == 0) { Tcl_DStringInit(&buffer); cmdTrace = Tcl_CreateTrace(interp, 50000, CmdTraceProc, &buffer); - result = Tcl_Eval(interp, argv[2]); + result = Tcl_EvalEx(interp, argv[2], -1, 0); if (result == TCL_OK) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL); @@ -1252,13 +1275,13 @@ TestcmdtraceCmd( */ cmdTrace = Tcl_CreateTrace(interp, 50000, CmdTraceDeleteProc, NULL); - Tcl_Eval(interp, argv[2]); + Tcl_EvalEx(interp, argv[2], -1, 0); } else if (strcmp(argv[1], "leveltest") == 0) { Interp *iPtr = (Interp *) interp; Tcl_DStringInit(&buffer); cmdTrace = Tcl_CreateTrace(interp, iPtr->numLevels + 4, CmdTraceProc, &buffer); - result = Tcl_Eval(interp, argv[2]); + result = Tcl_EvalEx(interp, argv[2], -1, 0); if (result == TCL_OK) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL); @@ -1276,10 +1299,10 @@ TestcmdtraceCmd( cmdTrace = Tcl_CreateObjTrace(interp, 50000, TCL_ALLOW_INLINE_COMPILATION, ObjTraceProc, (ClientData) &deleteCalled, ObjTraceDeleteProc); - result = Tcl_Eval(interp, argv[2]); + result = Tcl_EvalEx(interp, argv[2], -1, 0); Tcl_DeleteTrace(interp, cmdTrace); if (!deleteCalled) { - Tcl_SetResult(interp, "Delete wasn't called", TCL_STATIC); + Tcl_AppendResult(interp, "Delete wasn't called", NULL); return TCL_ERROR; } else { return result; @@ -1290,7 +1313,7 @@ TestcmdtraceCmd( Tcl_DStringInit(&buffer); t1 = Tcl_CreateTrace(interp, 1, CmdTraceProc, &buffer); t2 = Tcl_CreateTrace(interp, 50000, CmdTraceProc, &buffer); - result = Tcl_Eval(interp, argv[2]); + result = Tcl_EvalEx(interp, argv[2], -1, 0); if (result == TCL_OK) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL); @@ -1555,14 +1578,14 @@ DelCallbackProc( * * TestdelCmd -- * - * This procedure implements the "testdcall" command. It is used - * to test Tcl_CallWhenDeleted. + * This procedure implements the "testdel" command. It is used + * to test calling of command deletion callbacks. * * Results: * A standard Tcl result. * * Side effects: - * Creates and deletes interpreters. + * Creates a command. * *---------------------------------------------------------------------- */ @@ -1579,7 +1602,7 @@ TestdelCmd( Tcl_Interp *slave; if (argc != 4) { - Tcl_SetResult(interp, "wrong # args", TCL_STATIC); + Tcl_AppendResult(interp, "wrong # args", NULL); return TCL_ERROR; } @@ -1619,7 +1642,7 @@ DelDeleteProc( { DelCmd *dPtr = clientData; - Tcl_Eval(dPtr->interp, dPtr->deleteCmd); + Tcl_EvalEx(dPtr->interp, dPtr->deleteCmd, -1, 0); Tcl_ResetResult(dPtr->interp); ckfree(dPtr->deleteCmd); ckfree(dPtr); @@ -1784,7 +1807,7 @@ TestdstringCmd( if (argc < 2) { wrongNumArgs: - Tcl_SetResult(interp, "wrong # args", TCL_STATIC); + Tcl_AppendResult(interp, "wrong # args", NULL); return TCL_ERROR; } if (strcmp(argv[1], "append") == 0) { @@ -1820,9 +1843,9 @@ TestdstringCmd( goto wrongNumArgs; } if (strcmp(argv[2], "staticsmall") == 0) { - Tcl_SetResult(interp, "short", TCL_STATIC); + Tcl_AppendResult(interp, "short", NULL); } else if (strcmp(argv[2], "staticlarge") == 0) { - Tcl_SetResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", TCL_STATIC); + Tcl_AppendResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", NULL); } else if (strcmp(argv[2], "free") == 0) { char *s = ckalloc(100); strcpy(s, "This is a malloc-ed string"); @@ -1957,9 +1980,12 @@ TestencodingObjCmd( if (objc != 3) { return TCL_ERROR; } - encoding = Tcl_GetEncoding(NULL, Tcl_GetString(objv[2])); - Tcl_FreeEncoding(encoding); - Tcl_FreeEncoding(encoding); + if (TCL_OK != Tcl_GetEncodingFromObj(interp, objv[2], &encoding)) { + return TCL_ERROR; + } + Tcl_FreeEncoding(encoding); /* Free returned reference */ + Tcl_FreeEncoding(encoding); /* Free to match CREATE */ + TclFreeIntRep(objv[2]); /* Free the cached ref */ break; } return TCL_OK; @@ -1982,7 +2008,7 @@ EncodingToUtfProc( TclEncoding *encodingPtr; encodingPtr = (TclEncoding *) clientData; - Tcl_GlobalEval(encodingPtr->interp, encodingPtr->toUtfCmd); + Tcl_EvalEx(encodingPtr->interp, encodingPtr->toUtfCmd, -1, TCL_EVAL_GLOBAL); len = strlen(Tcl_GetStringResult(encodingPtr->interp)); if (len > dstLen) { @@ -2014,7 +2040,7 @@ EncodingFromUtfProc( TclEncoding *encodingPtr; encodingPtr = (TclEncoding *) clientData; - Tcl_GlobalEval(encodingPtr->interp, encodingPtr->fromUtfCmd); + Tcl_EvalEx(encodingPtr->interp, encodingPtr->fromUtfCmd, -1, TCL_EVAL_GLOBAL); len = strlen(Tcl_GetStringResult(encodingPtr->interp)); if (len > dstLen) { @@ -2301,9 +2327,9 @@ TesteventDeleteProc( return 0; } targetName = (Tcl_Obj *) clientData; - targetNameStr = (char *) Tcl_GetStringFromObj(targetName, NULL); + targetNameStr = (char *) Tcl_GetString(targetName); ev = (TestEvent *) event; - evNameStr = Tcl_GetStringFromObj(ev->tag, NULL); + evNameStr = Tcl_GetString(ev->tag); if (strcmp(evNameStr, targetNameStr) == 0) { Tcl_DecrRefCount(ev->tag); Tcl_DecrRefCount(ev->command); @@ -2422,7 +2448,7 @@ TestexprlongCmd( " expression\"", NULL); return TCL_ERROR; } - Tcl_SetResult(interp, "This is a result", TCL_STATIC); + Tcl_AppendResult(interp, "This is a result", NULL); result = Tcl_ExprLong(interp, argv[1], &exprResult); if (result != TCL_OK) { return result; @@ -2464,7 +2490,7 @@ TestexprlongobjCmd( Tcl_WrongNumArgs(interp, 1, objv, "expression"); return TCL_ERROR; } - Tcl_SetResult(interp, "This is a result", TCL_STATIC); + Tcl_AppendResult(interp, "This is a result", NULL); result = Tcl_ExprLongObj(interp, objv[1], &exprResult); if (result != TCL_OK) { return result; @@ -2507,7 +2533,7 @@ TestexprdoubleCmd( " expression\"", NULL); return TCL_ERROR; } - Tcl_SetResult(interp, "This is a result", TCL_STATIC); + Tcl_AppendResult(interp, "This is a result", NULL); result = Tcl_ExprDouble(interp, argv[1], &exprResult); if (result != TCL_OK) { return result; @@ -2550,7 +2576,7 @@ TestexprdoubleobjCmd( Tcl_WrongNumArgs(interp, 1, objv, "expression"); return TCL_ERROR; } - Tcl_SetResult(interp, "This is a result", TCL_STATIC); + Tcl_AppendResult(interp, "This is a result", NULL); result = Tcl_ExprDoubleObj(interp, objv[1], &exprResult); if (result != TCL_OK) { return result; @@ -3312,144 +3338,6 @@ TestlocaleCmd( /* *---------------------------------------------------------------------- * - * TestMathFunc -- - * - * This is a user-defined math procedure to test out math procedures - * with no arguments. - * - * Results: - * A normal Tcl completion code. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -TestMathFunc( - ClientData clientData, /* Integer value to return. */ - Tcl_Interp *interp, /* Not used. */ - Tcl_Value *args, /* Not used. */ - Tcl_Value *resultPtr) /* Where to store result. */ -{ - resultPtr->type = TCL_INT; - resultPtr->intValue = PTR2INT(clientData); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TestMathFunc2 -- - * - * This is a user-defined math procedure to test out math procedures - * that do have arguments, in this case 2. - * - * Results: - * A normal Tcl completion code. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -TestMathFunc2( - ClientData clientData, /* Integer value to return. */ - Tcl_Interp *interp, /* Used to report errors. */ - Tcl_Value *args, /* Points to an array of two Tcl_Value structs - * for the two arguments. */ - Tcl_Value *resultPtr) /* Where to store the result. */ -{ - int result = TCL_OK; - - /* - * Return the maximum of the two arguments with the correct type. - */ - - if (args[0].type == TCL_INT) { - int i0 = args[0].intValue; - - if (args[1].type == TCL_INT) { - int i1 = args[1].intValue; - - resultPtr->type = TCL_INT; - resultPtr->intValue = ((i0 > i1)? i0 : i1); - } else if (args[1].type == TCL_DOUBLE) { - double d0 = i0; - double d1 = args[1].doubleValue; - - resultPtr->type = TCL_DOUBLE; - resultPtr->doubleValue = ((d0 > d1)? d0 : d1); - } else if (args[1].type == TCL_WIDE_INT) { - Tcl_WideInt w0 = Tcl_LongAsWide(i0); - Tcl_WideInt w1 = args[1].wideValue; - - resultPtr->type = TCL_WIDE_INT; - resultPtr->wideValue = ((w0 > w1)? w0 : w1); - } else { - Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC); - result = TCL_ERROR; - } - } else if (args[0].type == TCL_DOUBLE) { - double d0 = args[0].doubleValue; - - if (args[1].type == TCL_INT) { - double d1 = args[1].intValue; - - resultPtr->type = TCL_DOUBLE; - resultPtr->doubleValue = ((d0 > d1)? d0 : d1); - } else if (args[1].type == TCL_DOUBLE) { - double d1 = args[1].doubleValue; - - resultPtr->type = TCL_DOUBLE; - resultPtr->doubleValue = ((d0 > d1)? d0 : d1); - } else if (args[1].type == TCL_WIDE_INT) { - double d1 = Tcl_WideAsDouble(args[1].wideValue); - - resultPtr->type = TCL_DOUBLE; - resultPtr->doubleValue = ((d0 > d1)? d0 : d1); - } else { - Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC); - result = TCL_ERROR; - } - } else if (args[0].type == TCL_WIDE_INT) { - Tcl_WideInt w0 = args[0].wideValue; - - if (args[1].type == TCL_INT) { - Tcl_WideInt w1 = Tcl_LongAsWide(args[1].intValue); - - resultPtr->type = TCL_WIDE_INT; - resultPtr->wideValue = ((w0 > w1)? w0 : w1); - } else if (args[1].type == TCL_DOUBLE) { - double d0 = Tcl_WideAsDouble(w0); - double d1 = args[1].doubleValue; - - 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, "T3: wrong type for arg 2", TCL_STATIC); - result = TCL_ERROR; - } - } else { - Tcl_SetResult(interp, "T3: wrong type for arg 1", TCL_STATIC); - result = TCL_ERROR; - } - return result; -} - -/* - *---------------------------------------------------------------------- - * * CleanupTestSetassocdataTests -- * * This function is called when an interpreter is deleted to clean @@ -3781,6 +3669,75 @@ TestparsevarnameObjCmd( /* *---------------------------------------------------------------------- * + * TestpreferstableObjCmd -- + * + * This procedure implements the "testpreferstable" command. It is + * used for being able to test the "package" command even when the + * environment variable TCL_PKG_PREFER_LATEST is set in your environment. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestpreferstableObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ +{ + Interp *iPtr = (Interp *) interp; + iPtr->packagePrefer = PKG_PREFER_STABLE; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestprintObjCmd -- + * + * This procedure implements the "testprint" command. It is + * used for being able to test the Tcl_ObjPrintf() function. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestprintObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ +{ + Tcl_WideInt argv1 = 0; + size_t argv2; + + if (objc < 2 || objc > 3) { + Tcl_WrongNumArgs(interp, 1, objv, "format wideint"); + } + + if (objc > 1) { + Tcl_GetWideIntFromObj(interp, objv[2], &argv1); + } + argv2 = (size_t)argv1; + Tcl_SetObjResult(interp, Tcl_ObjPrintf(Tcl_GetString(objv[1]), argv1, argv2, argv2)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TestregexpObjCmd -- * * This procedure implements the "testregexp" command. It is used to give @@ -3924,7 +3881,7 @@ TestregexpObjCmd( varName = Tcl_GetString(objv[2]); TclRegExpRangeUniChar(regExpr, -1, &start, &end); sprintf(resinfo, "%d %d", start, end-1); - value = Tcl_SetVar(interp, varName, resinfo, 0); + value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0); if (value == NULL) { Tcl_AppendResult(interp, "couldn't set variable \"", varName, "\"", NULL); @@ -3938,7 +3895,7 @@ TestregexpObjCmd( Tcl_RegExpGetInfo(regExpr, &info); varName = Tcl_GetString(objv[2]); sprintf(resinfo, "%ld", info.extendStart); - value = Tcl_SetVar(interp, varName, resinfo, 0); + value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0); if (value == NULL) { Tcl_AppendResult(interp, "couldn't set variable \"", varName, "\"", NULL); @@ -4281,7 +4238,7 @@ StaticInitProc( Tcl_Interp *interp) /* Interpreter in which package is supposedly * being loaded. */ { - Tcl_SetVar(interp, "x", "loaded", TCL_GLOBAL_ONLY); + Tcl_SetVar2(interp, "x", NULL, "loaded", TCL_GLOBAL_ONLY); return TCL_OK; } @@ -4365,7 +4322,7 @@ TestupvarCmd( } else if (strcmp(argv[4], "namespace") == 0) { flags = TCL_NAMESPACE_ONLY; } - return Tcl_UpVar(interp, argv[1], argv[2], argv[3], flags); + return Tcl_UpVar2(interp, argv[1], argv[2], NULL, argv[3], flags); } else { if (strcmp(argv[5], "global") == 0) { flags = TCL_GLOBAL_ONLY; @@ -4405,11 +4362,29 @@ TestseterrorcodeCmd( const char **argv) /* Argument strings. */ { if (argc > 6) { - Tcl_SetResult(interp, "too many args", TCL_STATIC); + Tcl_AppendResult(interp, "too many args", NULL); return TCL_ERROR; } - Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], - argv[5], NULL); + switch (argc) { + case 1: + Tcl_SetErrorCode(interp, "NONE", NULL); + break; + case 2: + Tcl_SetErrorCode(interp, argv[1], NULL); + break; + case 3: + Tcl_SetErrorCode(interp, argv[1], argv[2], NULL); + break; + case 4: + Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], NULL); + break; + case 5: + Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], NULL); + break; + case 6: + Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], + argv[5], NULL); + } return TCL_ERROR; } @@ -4484,7 +4459,7 @@ TestfeventCmd( return TCL_ERROR; } if (interp2 != NULL) { - code = Tcl_GlobalEval(interp2, argv[2]); + code = Tcl_EvalEx(interp2, argv[2], -1, TCL_EVAL_GLOBAL); Tcl_SetObjResult(interp, Tcl_GetObjResult(interp2)); return code; } else { @@ -4540,7 +4515,7 @@ TestpanicCmd( int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { - const char *argString; + char *argString; /* * Put the arguments into a var args structure @@ -4648,7 +4623,6 @@ TestgetvarfullnameCmd( Tcl_Namespace *namespacePtr; Tcl_CallFrame *framePtr; Tcl_Var variable; - int result; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "name scope"); @@ -4676,11 +4650,8 @@ TestgetvarfullnameCmd( if (namespacePtr == NULL) { return TCL_ERROR; } - result = TclPushStackFrame(interp, &framePtr, namespacePtr, + (void) TclPushStackFrame(interp, &framePtr, namespacePtr, /*isProcCallFrame*/ 0); - if (result != TCL_OK) { - return result; - } } variable = Tcl_FindNamespaceVar(interp, name, NULL, @@ -4699,7 +4670,7 @@ TestgetvarfullnameCmd( /* *---------------------------------------------------------------------- * - * GetTimesCmd -- + * GetTimesObjCmd -- * * This procedure implements the "gettimes" command. It is used for * computing the time needed for various basic operations such as reading @@ -4715,11 +4686,11 @@ TestgetvarfullnameCmd( */ static int -GetTimesCmd( +GetTimesObjCmd( ClientData unused, /* Unused. */ Tcl_Interp *interp, /* The current interpreter. */ - int argc, /* The number of arguments. */ - const char **argv) /* The argument strings. */ + int notused1, /* Number of arguments. */ + Tcl_Obj *const notused2[]) /* The argument objects. */ { Interp *iPtr = (Interp *) interp; int i, n; @@ -4845,10 +4816,10 @@ GetTimesCmd( timePer/100000); /* Tcl_SetVar 100000 times */ - fprintf(stderr, "Tcl_SetVar of \"12345\" 100000 times\n"); + fprintf(stderr, "Tcl_SetVar2 of \"12345\" 100000 times\n"); Tcl_GetTime(&start); for (i = 0; i < 100000; i++) { - s = Tcl_SetVar(interp, "a", "12345", TCL_LEAVE_ERR_MSG); + s = Tcl_SetVar2(interp, "a", NULL, "12345", TCL_LEAVE_ERR_MSG); if (s == NULL) { return TCL_ERROR; } @@ -4862,7 +4833,7 @@ GetTimesCmd( fprintf(stderr, "Tcl_GetVar of a==\"12345\" 100000 times\n"); Tcl_GetTime(&start); for (i = 0; i < 100000; i++) { - s = Tcl_GetVar(interp, "a", TCL_LEAVE_ERR_MSG); + s = Tcl_GetVar2(interp, "a", NULL, TCL_LEAVE_ERR_MSG); if (s == NULL) { return TCL_ERROR; } @@ -4933,6 +4904,76 @@ NoopObjCmd( /* *---------------------------------------------------------------------- * + * TeststringbytesObjCmd -- + * Returns bytearray value of the bytes in argument string rep + * + * Results: + * Returns the TCL_OK result code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TeststringbytesObjCmd( + ClientData unused, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ +{ + int n; + const unsigned char *p; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "value"); + return TCL_ERROR; + } + p = (const unsigned char *)Tcl_GetStringFromObj(objv[1], &n); + Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(p, n)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestbytestringObjCmd -- + * + * This object-based procedure constructs a string which can + * possibly contain invalid UTF-8 bytes. + * + * Results: + * Returns the TCL_OK result code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestbytestringObjCmd( + ClientData unused, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ +{ + int n; + const char *p; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "bytearray"); + return TCL_ERROR; + } + p = (const char *)Tcl_GetByteArrayFromObj(objv[1], &n); + Tcl_SetObjResult(interp, Tcl_NewStringObj(p, n)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TestsetCmd -- * * Implements the "testset{err,noerr}" cmds that are used when testing @@ -4959,7 +5000,7 @@ TestsetCmd( const char *value; if (argc == 2) { - Tcl_SetResult(interp, "before get", TCL_STATIC); + Tcl_AppendResult(interp, "before get", NULL); value = Tcl_GetVar2(interp, argv[1], NULL, flags); if (value == NULL) { return TCL_ERROR; @@ -4967,7 +5008,7 @@ TestsetCmd( Tcl_AppendElement(interp, value); return TCL_OK; } else if (argc == 3) { - Tcl_SetResult(interp, "before set", TCL_STATIC); + Tcl_AppendResult(interp, "before set", NULL); value = Tcl_SetVar2(interp, argv[1], NULL, argv[2], flags); if (value == NULL) { return TCL_ERROR; @@ -4991,7 +5032,7 @@ Testset2Cmd( const char *value; if (argc == 3) { - Tcl_SetResult(interp, "before get", TCL_STATIC); + Tcl_AppendResult(interp, "before get", NULL); value = Tcl_GetVar2(interp, argv[1], argv[2], flags); if (value == NULL) { return TCL_ERROR; @@ -4999,7 +5040,7 @@ Testset2Cmd( Tcl_AppendElement(interp, value); return TCL_OK; } else if (argc == 4) { - Tcl_SetResult(interp, "before set", TCL_STATIC); + Tcl_AppendResult(interp, "before set", NULL); value = Tcl_SetVar2(interp, argv[1], argv[2], argv[3], flags); if (value == NULL) { return TCL_ERROR; @@ -5013,7 +5054,6 @@ Testset2Cmd( } } -#ifndef TCL_NO_DEPRECATED /* *---------------------------------------------------------------------- * @@ -5066,10 +5106,11 @@ TestsaveresultCmd( return TCL_ERROR; } + freeCount = 0; objPtr = NULL; /* Lint. */ switch ((enum options) index) { case RESULT_SMALL: - Tcl_SetResult(interp, "small result", TCL_VOLATILE); + Tcl_AppendResult(interp, "small result", NULL); break; case RESULT_APPEND: Tcl_AppendResult(interp, "append result", NULL); @@ -5090,13 +5131,12 @@ TestsaveresultCmd( break; } - freeCount = 0; Tcl_SaveResult(interp, &state); if (((enum options) index) == RESULT_OBJECT) { result = Tcl_EvalObjEx(interp, objv[2], 0); } else { - result = Tcl_Eval(interp, Tcl_GetString(objv[2])); + result = Tcl_EvalEx(interp, Tcl_GetString(objv[2]), -1, 0); } if (discard) { @@ -5108,11 +5148,9 @@ TestsaveresultCmd( switch ((enum options) index) { case RESULT_DYNAMIC: { - int present = iPtr->freeProc == TestsaveresultFree; - int called = freeCount; + int presentOrFreed = (iPtr->freeProc == TestsaveresultFree) ^ freeCount; - Tcl_AppendElement(interp, called ? "called" : "notCalled"); - Tcl_AppendElement(interp, present ? "present" : "missing"); + Tcl_AppendElement(interp, presentOrFreed ? "presentOrFreed" : "missingOrLeak"); break; } case RESULT_OBJECT: @@ -5147,7 +5185,6 @@ TestsaveresultFree( { freeCount++; } -#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -5174,12 +5211,12 @@ TestmainthreadCmd( const char **argv) /* Argument strings. */ { if (argc == 1) { - Tcl_Obj *idObj = Tcl_NewLongObj((long)(size_t)Tcl_GetCurrentThread()); + Tcl_Obj *idObj = Tcl_NewWideIntObj((Tcl_WideInt)(size_t)Tcl_GetCurrentThread()); Tcl_SetObjResult(interp, idObj); return TCL_OK; } else { - Tcl_SetResult(interp, "wrong # args", TCL_STATIC); + Tcl_AppendResult(interp, "wrong # args", NULL); return TCL_ERROR; } } @@ -5571,8 +5608,8 @@ TestChannelCmd( return TCL_ERROR; } - TclFormatInt(buf, (size_t) Tcl_GetChannelThread(chan)); - Tcl_AppendResult(interp, buf, NULL); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj( + (Tcl_WideInt) (size_t) Tcl_GetChannelThread(chan))); return TCL_OK; } @@ -5952,6 +5989,75 @@ TestChannelEventCmd( /* *---------------------------------------------------------------------- * + * TestSocketCmd -- + * + * Implements the Tcl "testsocket" debugging command and its + * subcommands. This is part of the testing environment. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestSocketCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Interpreter for result. */ + int argc, /* Count of additional args. */ + const char **argv) /* Additional arg strings. */ +{ + const char *cmdName; /* Sub command. */ + size_t len; /* Length of subcommand string. */ + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " subcommand ?additional args..?\"", NULL); + return TCL_ERROR; + } + cmdName = argv[1]; + len = strlen(cmdName); + + if ((cmdName[0] == 't') && (strncmp(cmdName, "testflags", len) == 0)) { + Tcl_Channel hChannel; + int modePtr; + TcpState *statePtr; + /* Set test value in the socket driver + */ + /* Check for argument "channel name" + */ + if (argc < 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " testflags channel flags\"", NULL); + return TCL_ERROR; + } + hChannel = Tcl_GetChannel(interp, argv[2], &modePtr); + if ( NULL == hChannel ) { + Tcl_AppendResult(interp, "unknown channel:", argv[2], NULL); + return TCL_ERROR; + } + statePtr = (TcpState *)Tcl_GetChannelInstanceData(hChannel); + if ( NULL == statePtr) { + Tcl_AppendResult(interp, "No channel instance data:", argv[2], + NULL); + return TCL_ERROR; + } + statePtr->testFlags = atoi(argv[3]); + return TCL_OK; + } + + Tcl_AppendResult(interp, "bad option \"", cmdName, "\": should be " + "testflags", NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * * TestWrongNumArgsObjCmd -- * * Test the Tcl_WrongNumArgs function. @@ -5980,7 +6086,7 @@ TestWrongNumArgsObjCmd( * Don't use Tcl_WrongNumArgs here, as that is the function * we want to test! */ - Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC); + Tcl_AppendResult(interp, "insufficient arguments", NULL); return TCL_ERROR; } @@ -5997,7 +6103,7 @@ TestWrongNumArgsObjCmd( /* * Asked for more arguments than were given. */ - Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC); + Tcl_AppendResult(interp, "insufficient arguments", NULL); return TCL_ERROR; } @@ -6199,7 +6305,7 @@ TestReport( savedResult = Tcl_GetObjResult(interp); Tcl_IncrRefCount(savedResult); Tcl_SetObjResult(interp, Tcl_NewObj()); - Tcl_Eval(interp, Tcl_DStringValue(&ds)); + Tcl_EvalEx(interp, Tcl_DStringValue(&ds), -1, 0); Tcl_DStringFree(&ds); Tcl_ResetResult(interp); Tcl_SetObjResult(interp, savedResult); @@ -6622,7 +6728,7 @@ TestNumUtfCharsCmd( int len = -1; if (objc > 2) { - (void) Tcl_GetStringFromObj(objv[1], &len); + (void) Tcl_GetIntFromObj(interp, objv[2], &len); } len = Tcl_NumUtfChars(Tcl_GetString(objv[1]), len); Tcl_SetObjResult(interp, Tcl_NewIntObj(len)); @@ -6630,7 +6736,51 @@ TestNumUtfCharsCmd( return TCL_OK; } -#if defined(HAVE_CPUID) || defined(__WIN32__) +/* + * Used to check correct operation of Tcl_UtfFindFirst + */ + +static int +TestFindFirstCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + if (objc > 1) { + int len = -1; + + if (objc > 2) { + (void) Tcl_GetIntFromObj(interp, objv[2], &len); + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_UtfFindFirst(Tcl_GetString(objv[1]), len), -1)); + } + return TCL_OK; +} + +/* + * Used to check correct operation of Tcl_UtfFindLast + */ + +static int +TestFindLastCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + if (objc > 1) { + int len = -1; + + if (objc > 2) { + (void) Tcl_GetIntFromObj(interp, objv[2], &len); + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_UtfFindLast(Tcl_GetString(objv[1]), len), -1)); + } + return TCL_OK; +} + +#if defined(HAVE_CPUID) || defined(_WIN32) /* *---------------------------------------------------------------------- * @@ -6662,7 +6812,7 @@ TestcpuidCmd( Tcl_Obj *const * objv) /* Parameter vector */ { int status, index, i; - unsigned int regs[4]; + int regs[4]; Tcl_Obj *regsObjs[4]; if (objc != 2) { @@ -6672,14 +6822,14 @@ TestcpuidCmd( if (Tcl_GetIntFromObj(interp, objv[1], &index) != TCL_OK) { return TCL_ERROR; } - status = TclWinCPUID((unsigned) index, regs); + status = TclWinCPUID(index, regs); if (status != TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewStringObj("operation not available", -1)); return status; } for (i=0 ; i<4 ; ++i) { - regsObjs[i] = Tcl_NewIntObj((int) regs[i]); + regsObjs[i] = Tcl_NewIntObj(regs[i]); } Tcl_SetObjResult(interp, Tcl_NewListObj(4, regsObjs)); return TCL_OK; @@ -6774,7 +6924,7 @@ TestgetintCmd( const char **argv) { if (argc < 2) { - Tcl_SetResult(interp, "wrong # args", TCL_STATIC); + Tcl_AppendResult(interp, "wrong # args", NULL); return TCL_ERROR; } else { int val, i, total=0; @@ -6790,6 +6940,69 @@ TestgetintCmd( } } +/* + * Used for determining sizeof(long) at script level. + */ +static int +TestlongsizeCmd( + ClientData dummy, + Tcl_Interp *interp, + int argc, + const char **argv) +{ + if (argc != 1) { + Tcl_AppendResult(interp, "wrong # args", NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewIntObj((int)sizeof(long))); + return TCL_OK; +} + +static int +NREUnwind_callback( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + int none; + + if (data[0] == INT2PTR(-1)) { + Tcl_NRAddCallback(interp, NREUnwind_callback, &none, INT2PTR(-1), + INT2PTR(-1), NULL); + } else if (data[1] == INT2PTR(-1)) { + Tcl_NRAddCallback(interp, NREUnwind_callback, data[0], &none, + INT2PTR(-1), NULL); + } else if (data[2] == INT2PTR(-1)) { + Tcl_NRAddCallback(interp, NREUnwind_callback, data[0], data[1], + &none, NULL); + } else { + Tcl_Obj *idata[3]; + idata[0] = Tcl_NewIntObj((int) ((char *) data[1] - (char *) data[0])); + idata[1] = Tcl_NewIntObj((int) ((char *) data[2] - (char *) data[0])); + idata[2] = Tcl_NewIntObj((int) ((char *) &none - (char *) data[0])); + Tcl_SetObjResult(interp, Tcl_NewListObj(3, idata)); + } + return TCL_OK; +} + +static int +TestNREUnwind( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + /* + * Insure that callbacks effectively run at the proper level during the + * unwinding of the NRE stack. + */ + + Tcl_NRAddCallback(interp, NREUnwind_callback, INT2PTR(-1), INT2PTR(-1), + INT2PTR(-1), NULL); + return TCL_OK; +} + + static int TestNRELevels( ClientData clientData, @@ -7192,24 +7405,83 @@ InterpCmdResolver( CallFrame *varFramePtr = iPtr->varFramePtr; Proc *procPtr = (varFramePtr->isProcCallFrame & FRAME_IS_PROC) ? varFramePtr->procPtr : NULL; - Namespace *ns2NsPtr = (Namespace *) - Tcl_FindNamespace(interp, "::ns2", NULL, 0); + Namespace *callerNsPtr = varFramePtr->nsPtr; + Tcl_Command resolvedCmdPtr = NULL; - if (procPtr && (procPtr->cmdPtr->nsPtr == iPtr->globalNsPtr - || (ns2NsPtr && procPtr->cmdPtr->nsPtr == ns2NsPtr))) { - const char *callingCmdName = + /* + * Just do something special on a cmd literal "z" in two cases: + * A) when the caller is a proc "x", and the proc is either in "::" or in "::ns2". + * B) the caller's namespace is "ctx1" or "ctx2" + */ + if ( (name[0] == 'z') && (name[1] == '\0') ) { + Namespace *ns2NsPtr = (Namespace *) Tcl_FindNamespace(interp, "::ns2", NULL, 0); + + if (procPtr != NULL + && ((procPtr->cmdPtr->nsPtr == iPtr->globalNsPtr) + || (ns2NsPtr != NULL && procPtr->cmdPtr->nsPtr == ns2NsPtr) + ) + ) { + /* + * Case A) + * + * - The context, in which this resolver becomes active, is + * determined by the name of the caller proc, which has to be + * named "x". + * + * - To determine the name of the caller proc, the proc is taken + * from the topmost stack frame. + * + * - Note that the context is NOT provided during byte-code + * compilation (e.g. in TclProcCompileProc) + * + * When these conditions hold, this function resolves the + * passed-in cmd literal into a cmd "y", which is taken from the + * the global namespace (for simplicity). + */ + + const char *callingCmdName = Tcl_GetCommandName(interp, (Tcl_Command) procPtr->cmdPtr); - if ((callingCmdName[0] == 'x') && (callingCmdName[1] == '\0') - && (name[0] == 'z') && (name[1] == '\0')) { - Tcl_Command sourceCmdPtr = Tcl_FindCommand(interp, "y", NULL, - TCL_GLOBAL_ONLY); + if ( callingCmdName[0] == 'x' && callingCmdName[1] == '\0' ) { + resolvedCmdPtr = Tcl_FindCommand(interp, "y", NULL, TCL_GLOBAL_ONLY); + } + } else if (callerNsPtr != NULL) { + /* + * Case B) + * + * - The context, in which this resolver becomes active, is + * determined by the name of the parent namespace, which has + * to be named "ctx1" or "ctx2". + * + * - To determine the name of the parent namesace, it is taken + * from the 2nd highest stack frame. + * + * - Note that the context can be provided during byte-code + * compilation (e.g. in TclProcCompileProc) + * + * When these conditions hold, this function resolves the + * passed-in cmd literal into a cmd "y" or "Y" depending on the + * context. The resolved procs are taken from the the global + * namespace (for simplicity). + */ + + CallFrame *parentFramePtr = varFramePtr->callerPtr; + const char *context = parentFramePtr != NULL ? parentFramePtr->nsPtr->name : "(NULL)"; + + if (strcmp(context, "ctx1") == 0 && (name[0] == 'z') && (name[1] == '\0')) { + resolvedCmdPtr = Tcl_FindCommand(interp, "y", NULL, TCL_GLOBAL_ONLY); + /* fprintf(stderr, "... y ==> %p\n", resolvedCmdPtr);*/ - if (sourceCmdPtr != NULL) { - *rPtr = sourceCmdPtr; - return TCL_OK; + } else if (strcmp(context, "ctx2") == 0 && (name[0] == 'z') && (name[1] == '\0')) { + resolvedCmdPtr = Tcl_FindCommand(interp, "Y", NULL, TCL_GLOBAL_ONLY); + /*fprintf(stderr, "... Y ==> %p\n", resolvedCmdPtr);*/ } } + + if (resolvedCmdPtr != NULL) { + *rPtr = resolvedCmdPtr; + return TCL_OK; + } } return TCL_CONTINUE; } @@ -7342,9 +7614,16 @@ TestInterpResolverCmd( int idx; #define RESOLVER_KEY "testInterpResolver" - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "up|down"); - return TCL_ERROR; + if ((objc < 2) || (objc > 3)) { + Tcl_WrongNumArgs(interp, 1, objv, "up|down ?interp?"); + return TCL_ERROR; + } + if (objc == 3) { + interp = Tcl_GetSlave(interp, Tcl_GetString(objv[2])); + if (interp == NULL) { + Tcl_AppendResult(interp, "provided interpreter not found", NULL); + return TCL_ERROR; + } } if (Tcl_GetIndexFromObj(interp, objv[1], table, "operation", TCL_EXACT, &idx) != TCL_OK) { diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index f36b07f..547792a 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -19,6 +19,7 @@ #endif #include "tclInt.h" #include "tommath.h" +#include "tclStringRep.h" /* @@ -46,13 +47,6 @@ static int TestobjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TeststringobjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); - -typedef struct TestString { - int numChars; - int allocated; - int maxChars; - Tcl_UniChar unicode[2]; -} TestString; #define VARPTR_KEY "TCLOBJTEST_VARPTR" #define NUMBER_OF_OBJECT_VARS 20 @@ -158,10 +152,11 @@ TestbignumobjCmd( Tcl_Obj *const objv[]) /* Argument vector */ { const char *const subcmds[] = { - "set", "get", "mult10", "div10", NULL + "set", "get", "mult10", "div10", "iseven", "radixsize", NULL }; enum options { - BIGNUM_SET, BIGNUM_GET, BIGNUM_MULT10, BIGNUM_DIV10 + BIGNUM_SET, BIGNUM_GET, BIGNUM_MULT10, BIGNUM_DIV10, BIGNUM_ISEVEN, + BIGNUM_RADIXSIZE }; int index, varIndex; const char *string; @@ -280,6 +275,50 @@ TestbignumobjCmd( } else { SetVarToObj(varPtr, varIndex, Tcl_NewBignumObj(&newValue)); } + break; + + case BIGNUM_ISEVEN: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "varIndex"); + return TCL_ERROR; + } + if (CheckIfVarUnset(interp, varPtr,varIndex)) { + return TCL_ERROR; + } + if (Tcl_GetBignumFromObj(interp, varPtr[varIndex], + &bignumValue) != TCL_OK) { + return TCL_ERROR; + } + if (!Tcl_IsShared(varPtr[varIndex])) { + Tcl_SetIntObj(varPtr[varIndex], mp_iseven(&bignumValue)); + } else { + SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(mp_iseven(&bignumValue))); + } + mp_clear(&bignumValue); + break; + + case BIGNUM_RADIXSIZE: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "varIndex"); + return TCL_ERROR; + } + if (CheckIfVarUnset(interp, varPtr,varIndex)) { + return TCL_ERROR; + } + if (Tcl_GetBignumFromObj(interp, varPtr[varIndex], + &bignumValue) != TCL_OK) { + return TCL_ERROR; + } + if (mp_radix_size(&bignumValue, 10, &index) != MP_OKAY) { + return TCL_ERROR; + } + if (!Tcl_IsShared(varPtr[varIndex])) { + Tcl_SetIntObj(varPtr[varIndex], index); + } else { + SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(index)); + } + mp_clear(&bignumValue); + break; } Tcl_SetObjResult(interp, varPtr[varIndex]); @@ -583,23 +622,9 @@ TestindexobjCmd( } argv[objc-4] = NULL; - /* - * Tcl_GetIndexFromObj assumes that the table is statically-allocated so - * that its address is different for each index object. If we accidently - * allocate a table at the same address as that cached in the index - * object, clear out the object's cached state. - */ - - if (objv[3]->typePtr != NULL - && !strcmp("index", objv[3]->typePtr->name)) { - indexRep = objv[3]->internalRep.twoPtrValue.ptr1; - if (indexRep->tablePtr == (void *) argv) { - TclFreeIntRep(objv[3]); - } - } - result = Tcl_GetIndexFromObj((setError? interp : NULL), objv[3], - argv, "token", (allowAbbrev? 0 : TCL_EXACT), &index); + argv, "token", INDEX_TEMP_TABLE|(allowAbbrev? 0 : TCL_EXACT), + &index); ckfree(argv); if (result == TCL_OK) { Tcl_SetIntObj(Tcl_GetObjResult(interp), index); @@ -1063,6 +1088,9 @@ TestobjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1)); } else { typeName = objv[2]->typePtr->name; +#ifndef TCL_WIDE_INT_IS_LONG + if (!strcmp(typeName, "wideInt")) typeName = "int"; +#endif Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1)); } } else if (strcmp(subCmd, "refcount") == 0) { @@ -1076,7 +1104,7 @@ TestobjCmd( if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewIntObj(varPtr[varIndex]->refCount)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(varPtr[varIndex]->refCount)); } else if (strcmp(subCmd, "type") == 0) { if (objc != 3) { goto wrongNumArgs; @@ -1090,6 +1118,11 @@ TestobjCmd( } if (varPtr[varIndex]->typePtr == NULL) { /* a string! */ Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", -1); +#ifndef TCL_WIDE_INT_IS_LONG + } else if (!strcmp(varPtr[varIndex]->typePtr->name, "wideInt")) { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "int", -1); +#endif } else { Tcl_AppendToObj(Tcl_GetObjResult(interp), varPtr[varIndex]->typePtr->name, -1); @@ -1141,7 +1174,7 @@ TeststringobjCmd( int varIndex, option, i, length; #define MAX_STRINGS 11 const char *index, *string, *strings[MAX_STRINGS+1]; - TestString *strPtr; + String *strPtr; Tcl_Obj **varPtr; static const char *const options[] = { "append", "appendstrings", "get", "get2", "length", "length2", diff --git a/generic/tclTestProcBodyObj.c b/generic/tclTestProcBodyObj.c index a3f89f6..4d32c5a 100644 --- a/generic/tclTestProcBodyObj.c +++ b/generic/tclTestProcBodyObj.c @@ -143,7 +143,7 @@ RegisterCommand( if (cmdTablePtr->exportIt) { sprintf(buf, "namespace eval %s { namespace export %s }", namespace, cmdTablePtr->cmdName); - if (Tcl_Eval(interp, buf) != TCL_OK) { + if (Tcl_EvalEx(interp, buf, -1, 0) != TCL_OK) { return TCL_ERROR; } } @@ -245,7 +245,7 @@ ProcBodyTestProcObjCmd( * Find the Command pointer to this procedure */ - fullName = Tcl_GetStringFromObj(objv[3], NULL); + fullName = Tcl_GetString(objv[3]); procCmd = Tcl_FindCommand(interp, fullName, NULL, TCL_LEAVE_ERR_MSG); if (procCmd == NULL) { return TCL_ERROR; diff --git a/generic/tclThread.c b/generic/tclThread.c index d1f2691..cafd824 100644 --- a/generic/tclThread.c +++ b/generic/tclThread.c @@ -41,21 +41,6 @@ static void RememberSyncObject(void *objPtr, SyncObjRecord *recPtr); /* - * Several functions are #defined to nothing in tcl.h if TCL_THREADS is not - * specified. Here we undo that so the functions are defined in the stubs - * table. - */ - -#ifndef TCL_THREADS -#undef Tcl_MutexLock -#undef Tcl_MutexUnlock -#undef Tcl_MutexFinalize -#undef Tcl_ConditionNotify -#undef Tcl_ConditionWait -#undef Tcl_ConditionFinalize -#endif - -/* *---------------------------------------------------------------------- * * Tcl_GetThreadData -- @@ -79,7 +64,7 @@ Tcl_GetThreadData( int size) /* Size of storage block */ { void *result; -#ifdef TCL_THREADS +#if TCL_THREADS /* * Initialize the key for this thread. */ @@ -126,7 +111,7 @@ TclThreadDataKeyGet( Tcl_ThreadDataKey *keyPtr) /* Identifier for the data chunk. */ { -#ifdef TCL_THREADS +#if TCL_THREADS return TclThreadStorageKeyGet(keyPtr); #else /* TCL_THREADS */ return *keyPtr; @@ -269,11 +254,12 @@ TclRememberMutex( *---------------------------------------------------------------------- */ +#undef Tcl_MutexFinalize void Tcl_MutexFinalize( Tcl_Mutex *mutexPtr) { -#ifdef TCL_THREADS +#if TCL_THREADS TclpFinalizeMutex(mutexPtr); #endif TclpMasterLock(); @@ -322,11 +308,12 @@ TclRememberCondition( *---------------------------------------------------------------------- */ +#undef Tcl_ConditionFinalize void Tcl_ConditionFinalize( Tcl_Condition *condPtr) { -#ifdef TCL_THREADS +#if TCL_THREADS TclpFinalizeCondition(condPtr); #endif TclpMasterLock(); @@ -339,8 +326,9 @@ Tcl_ConditionFinalize( * * TclFinalizeThreadData -- * - * This function cleans up the thread-local storage. This is called once - * for each thread. + * This function cleans up the thread-local storage. Secondary, it cleans + * thread alloc cache. + * This is called once for each thread before thread exits. * * Results: * None. @@ -352,9 +340,17 @@ Tcl_ConditionFinalize( */ void -TclFinalizeThreadData(void) +TclFinalizeThreadData(int quick) { TclFinalizeThreadDataThread(); +#if TCL_THREADS && defined(USE_THREAD_ALLOC) + if (!quick) { + /* + * Quick exit principle makes it useless to terminate allocators + */ + TclFinalizeThreadAllocThread(); + } +#endif } /* @@ -380,7 +376,7 @@ TclFinalizeSynchronization(void) int i; void *blockPtr; Tcl_ThreadDataKey *keyPtr; -#ifdef TCL_THREADS +#if TCL_THREADS Tcl_Mutex *mutexPtr; Tcl_Condition *condPtr; @@ -404,7 +400,7 @@ TclFinalizeSynchronization(void) keyRecord.max = 0; keyRecord.num = 0; -#ifdef TCL_THREADS +#if TCL_THREADS /* * Call thread storage master cleanup. */ @@ -464,12 +460,10 @@ Tcl_ExitThread( int status) { Tcl_FinalizeThread(); -#ifdef TCL_THREADS TclpThreadExit(status); -#endif } -#ifndef TCL_THREADS +#if !TCL_THREADS /* *---------------------------------------------------------------------- diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c index abd5af5..3f1abc2 100644 --- a/generic/tclThreadAlloc.c +++ b/generic/tclThreadAlloc.c @@ -13,7 +13,7 @@ */ #include "tclInt.h" -#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) +#if TCL_THREADS && defined(USE_THREAD_ALLOC) /* * If range checking is enabled, an additional byte will be allocated to store @@ -84,6 +84,7 @@ typedef union Block { typedef struct Bucket { Block *firstPtr; /* First block available */ + Block *lastPtr; /* End of block list */ long numFree; /* Number of blocks available */ /* All fields below for accounting only */ @@ -107,6 +108,7 @@ typedef struct Cache { Tcl_ThreadId owner; /* Which thread's cache is this? */ Tcl_Obj *firstObjPtr; /* List of free objects for thread */ int numObjects; /* Number of objects for thread */ + Tcl_Obj *lastPtr; /* Last object in this cache */ int totalAssigned; /* Total space assigned to thread */ Bucket buckets[NBUCKETS]; /* The buckets for this thread */ } Cache; @@ -135,6 +137,7 @@ static int GetBlocks(Cache *cachePtr, int bucket); static Block * Ptr2Block(char *ptr); static char * Block2Ptr(Block *blockPtr, int bucket, unsigned int reqSize); static void MoveObjs(Cache *fromPtr, Cache *toPtr, int numMove); +static void PutObjs(Cache *fromPtr, int numMove); /* * Local variables defined in this file and initialized at startup. @@ -193,20 +196,11 @@ GetCache(void) if (listLockPtr == NULL) { Tcl_Mutex *initLockPtr; - unsigned int i; initLockPtr = Tcl_GetAllocMutex(); Tcl_MutexLock(initLockPtr); if (listLockPtr == NULL) { - listLockPtr = TclpNewAllocMutex(); - objLockPtr = TclpNewAllocMutex(); - for (i = 0; i < NBUCKETS; ++i) { - bucketInfo[i].blockSize = MINALLOC << i; - bucketInfo[i].maxBlocks = 1 << (NBUCKETS - 1 - i); - bucketInfo[i].numMove = i < NBUCKETS - 1 ? - 1 << (NBUCKETS - 2 - i) : 1; - bucketInfo[i].lockPtr = TclpNewAllocMutex(); - } + TclInitThreadAlloc(); } Tcl_MutexUnlock(initLockPtr); } @@ -217,10 +211,11 @@ GetCache(void) cachePtr = TclpGetAllocCache(); if (cachePtr == NULL) { - cachePtr = calloc(1, sizeof(Cache)); + cachePtr = TclpSysAlloc(sizeof(Cache), 0); if (cachePtr == NULL) { Tcl_Panic("alloc: could not allocate new cache"); } + memset(cachePtr, 0, sizeof(Cache)); Tcl_MutexLock(listLockPtr); cachePtr->nextPtr = firstCachePtr; firstCachePtr = cachePtr; @@ -270,9 +265,7 @@ TclFreeAllocCache( */ if (cachePtr->numObjects > 0) { - Tcl_MutexLock(objLockPtr); - MoveObjs(cachePtr, sharedPtr, cachePtr->numObjects); - Tcl_MutexUnlock(objLockPtr); + PutObjs(cachePtr, cachePtr->numObjects); } /* @@ -287,7 +280,7 @@ TclFreeAllocCache( *nextPtrPtr = cachePtr->nextPtr; cachePtr->nextPtr = NULL; Tcl_MutexUnlock(listLockPtr); - free(cachePtr); + TclpSysFree(cachePtr); } /* @@ -332,7 +325,7 @@ TclpAlloc( /* * Increment the requested size to include room for the Block structure. - * Call malloc() directly if the required amount is greater than the + * Call TclpSysAlloc() directly if the required amount is greater than the * largest block, otherwise pop the smallest block large enough, * allocating more blocks if necessary. */ @@ -344,7 +337,7 @@ TclpAlloc( #endif if (size > MAXALLOC) { bucket = NBUCKETS; - blockPtr = malloc(size); + blockPtr = TclpSysAlloc(size, 0); if (blockPtr != NULL) { cachePtr->totalAssigned += reqSize; } @@ -407,13 +400,16 @@ TclpFree( bucket = blockPtr->sourceBucket; if (bucket == NBUCKETS) { cachePtr->totalAssigned -= blockPtr->blockReqSize; - free(blockPtr); + TclpSysFree(blockPtr); return; } cachePtr->buckets[bucket].totalAssigned -= blockPtr->blockReqSize; blockPtr->nextBlock = cachePtr->buckets[bucket].firstPtr; cachePtr->buckets[bucket].firstPtr = blockPtr; + if (cachePtr->buckets[bucket].numFree == 0) { + cachePtr->buckets[bucket].lastPtr = blockPtr; + } cachePtr->buckets[bucket].numFree++; cachePtr->buckets[bucket].numInserts++; @@ -472,7 +468,7 @@ TclpRealloc( /* * 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. + * size would also require a system block, call TclpSysRealloc() directly. */ blockPtr = Ptr2Block(ptr); @@ -495,7 +491,7 @@ TclpRealloc( } else if (size > MAXALLOC) { cachePtr->totalAssigned -= blockPtr->blockReqSize; cachePtr->totalAssigned += reqSize; - blockPtr = realloc(blockPtr, size); + blockPtr = TclpSysRealloc(blockPtr, size); if (blockPtr == NULL) { return NULL; } @@ -567,15 +563,17 @@ TclThreadAllocObj(void) Tcl_Obj *newObjsPtr; cachePtr->numObjects = numMove = NOBJALLOC; - newObjsPtr = malloc(sizeof(Tcl_Obj) * numMove); + newObjsPtr = TclpSysAlloc(sizeof(Tcl_Obj) * numMove, 0); if (newObjsPtr == NULL) { Tcl_Panic("alloc: could not allocate %d new objects", numMove); } + cachePtr->lastPtr = newObjsPtr + numMove - 1; + objPtr = cachePtr->firstObjPtr; /* NULL */ while (--numMove >= 0) { - objPtr = &newObjsPtr[numMove]; - objPtr->internalRep.twoPtrValue.ptr1 = cachePtr->firstObjPtr; - cachePtr->firstObjPtr = objPtr; + newObjsPtr[numMove].internalRep.twoPtrValue.ptr1 = objPtr; + objPtr = newObjsPtr + numMove; } + cachePtr->firstObjPtr = newObjsPtr; } } @@ -623,6 +621,9 @@ TclThreadFreeObj( objPtr->internalRep.twoPtrValue.ptr1 = cachePtr->firstObjPtr; cachePtr->firstObjPtr = objPtr; + if (cachePtr->numObjects == 0) { + cachePtr->lastPtr = objPtr; + } cachePtr->numObjects++; /* @@ -631,9 +632,7 @@ TclThreadFreeObj( */ if (cachePtr->numObjects > NOBJHIGH) { - Tcl_MutexLock(objLockPtr); - MoveObjs(cachePtr, sharedPtr, NOBJALLOC); - Tcl_MutexUnlock(objLockPtr); + PutObjs(cachePtr, NOBJALLOC); } } @@ -731,13 +730,67 @@ MoveObjs( * just have to update the first and last. */ - objPtr->internalRep.twoPtrValue.ptr1 = toPtr->firstObjPtr; + toPtr->lastPtr = objPtr; + objPtr->internalRep.twoPtrValue.ptr1 = toPtr->firstObjPtr; /* NULL */ toPtr->firstObjPtr = fromFirstObjPtr; } /* *---------------------------------------------------------------------- * + * PutObjs -- + * + * Move Tcl_Obj's from thread cache to shared cache. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +PutObjs( + Cache *fromPtr, + int numMove) +{ + int keep = fromPtr->numObjects - numMove; + Tcl_Obj *firstPtr, *lastPtr = NULL; + + fromPtr->numObjects = keep; + firstPtr = fromPtr->firstObjPtr; + if (keep == 0) { + fromPtr->firstObjPtr = NULL; + } else { + do { + lastPtr = firstPtr; + firstPtr = firstPtr->internalRep.twoPtrValue.ptr1; + } while (--keep > 0); + lastPtr->internalRep.twoPtrValue.ptr1 = NULL; + } + + /* + * Move all objects as a block - they are already linked to each other, we + * just have to update the first and last. + */ + + Tcl_MutexLock(objLockPtr); + fromPtr->lastPtr->internalRep.twoPtrValue.ptr1 = sharedPtr->firstObjPtr; + sharedPtr->firstObjPtr = firstPtr; + if (sharedPtr->numObjects == 0) { + sharedPtr->lastPtr = fromPtr->lastPtr; + } + sharedPtr->numObjects += numMove; + Tcl_MutexUnlock(objLockPtr); + + fromPtr->lastPtr = lastPtr; +} + +/* + *---------------------------------------------------------------------- + * * Block2Ptr, Ptr2Block -- * * Convert between internal blocks and user pointers. @@ -847,20 +900,25 @@ PutBlocks( int bucket, int numMove) { - register Block *lastPtr, *firstPtr; - register int n = numMove; - /* - * Before acquiring the lock, walk the block list to find the last block - * to be moved. + * We have numFree. Want to shed numMove. So compute how many + * Blocks to keep. */ - firstPtr = lastPtr = cachePtr->buckets[bucket].firstPtr; - while (--n > 0) { - lastPtr = lastPtr->nextBlock; + int keep = cachePtr->buckets[bucket].numFree - numMove; + Block *lastPtr = NULL, *firstPtr; + + cachePtr->buckets[bucket].numFree = keep; + firstPtr = cachePtr->buckets[bucket].firstPtr; + if (keep == 0) { + cachePtr->buckets[bucket].firstPtr = NULL; + } else { + do { + lastPtr = firstPtr; + firstPtr = firstPtr->nextBlock; + } while (--keep > 0); + lastPtr->nextBlock = NULL; } - cachePtr->buckets[bucket].firstPtr = lastPtr->nextBlock; - cachePtr->buckets[bucket].numFree -= numMove; /* * Aquire the lock and place the list of blocks at the front of the shared @@ -868,10 +926,17 @@ PutBlocks( */ LockBucket(cachePtr, bucket); - lastPtr->nextBlock = sharedPtr->buckets[bucket].firstPtr; + cachePtr->buckets[bucket].lastPtr->nextBlock + = sharedPtr->buckets[bucket].firstPtr; sharedPtr->buckets[bucket].firstPtr = firstPtr; + if (sharedPtr->buckets[bucket].numFree == 0) { + sharedPtr->buckets[bucket].lastPtr + = cachePtr->buckets[bucket].lastPtr; + } sharedPtr->buckets[bucket].numFree += numMove; UnlockBucket(cachePtr, bucket); + + cachePtr->buckets[bucket].lastPtr = lastPtr; } /* @@ -918,6 +983,8 @@ GetBlocks( if (n >= sharedPtr->buckets[bucket].numFree) { cachePtr->buckets[bucket].firstPtr = sharedPtr->buckets[bucket].firstPtr; + cachePtr->buckets[bucket].lastPtr = + sharedPtr->buckets[bucket].lastPtr; cachePtr->buckets[bucket].numFree = sharedPtr->buckets[bucket].numFree; sharedPtr->buckets[bucket].firstPtr = NULL; @@ -931,6 +998,7 @@ GetBlocks( blockPtr = blockPtr->nextBlock; } sharedPtr->buckets[bucket].firstPtr = blockPtr->nextBlock; + cachePtr->buckets[bucket].lastPtr = blockPtr; blockPtr->nextBlock = NULL; } } @@ -964,7 +1032,7 @@ GetBlocks( if (blockPtr == NULL) { size = MAXALLOC; - blockPtr = malloc(size); + blockPtr = TclpSysAlloc(size, 0); if (blockPtr == NULL) { return 0; } @@ -982,10 +1050,45 @@ GetBlocks( ((char *) blockPtr + bucketInfo[bucket].blockSize); blockPtr = blockPtr->nextBlock; } + cachePtr->buckets[bucket].lastPtr = blockPtr; blockPtr->nextBlock = NULL; } return 1; } + +/* + *---------------------------------------------------------------------- + * + * TclInitThreadAlloc -- + * + * Initializes the allocator cache-maintenance structures. + * It is done early and protected during the TclInitSubsystems(). + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclInitThreadAlloc(void) +{ + unsigned int i; + + listLockPtr = TclpNewAllocMutex(); + objLockPtr = TclpNewAllocMutex(); + for (i = 0; i < NBUCKETS; ++i) { + bucketInfo[i].blockSize = MINALLOC << i; + bucketInfo[i].maxBlocks = 1 << (NBUCKETS - 1 - i); + bucketInfo[i].numMove = i < NBUCKETS - 1 ? + 1 << (NBUCKETS - 2 - i) : 1; + bucketInfo[i].lockPtr = TclpNewAllocMutex(); + } + TclpInitAllocCache(); +} /* *---------------------------------------------------------------------- @@ -1023,6 +1126,33 @@ TclFinalizeThreadAlloc(void) TclpFreeAllocCache(NULL); } +/* + *---------------------------------------------------------------------- + * + * TclFinalizeThreadAllocThread -- + * + * This procedure is used to destroy single thread private resources + * defined in this file. Called either during Tcl_FinalizeThread() or + * Tcl_Finalize(). + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclFinalizeThreadAllocThread(void) +{ + Cache *cachePtr = TclpGetAllocCache(); + if (cachePtr != NULL) { + TclpFreeAllocCache(cachePtr); + } +} + #else /* !(TCL_THREADS && USE_THREAD_ALLOC) */ /* *---------------------------------------------------------------------- diff --git a/generic/tclThreadJoin.c b/generic/tclThreadJoin.c index 4b09e1c..5c70a62 100644 --- a/generic/tclThreadJoin.c +++ b/generic/tclThreadJoin.c @@ -14,7 +14,7 @@ #include "tclInt.h" -#ifdef WIN32 +#ifdef _WIN32 /* * The information about each joinable thread is remembered in a structure as @@ -305,7 +305,7 @@ TclSignalExitThread( Tcl_MutexUnlock(&threadPtr->threadMutex); } -#endif /* WIN32 */ +#endif /* _WIN32 */ /* * Local Variables: diff --git a/generic/tclThreadStorage.c b/generic/tclThreadStorage.c index f24e334..b56ec80 100644 --- a/generic/tclThreadStorage.c +++ b/generic/tclThreadStorage.c @@ -13,7 +13,7 @@ #include "tclInt.h" -#ifdef TCL_THREADS +#if TCL_THREADS #include <signal.h> /* @@ -208,12 +208,12 @@ TclThreadStorageKeyGet( * * This procedure set an association of value with the key passed. The * associated value may be retrieved with TclThreadDataKeyGet(). - * + * * Results: * None. * * Side effects: - * The thread-specific table may be created or reallocated. + * The thread-specific table may be created or reallocated. * *---------------------------------------------------------------------- */ @@ -285,7 +285,7 @@ TclThreadStorageKeySet( *---------------------------------------------------------------------- */ -void +void TclFinalizeThreadDataThread(void) { TSDTable *tsdTablePtr = TclpThreadGetMasterTSD(tsdMaster.key); diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index 02ee038..1742eb7 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -18,7 +18,7 @@ #endif #include "tclInt.h" -#ifdef TCL_THREADS +#if TCL_THREADS /* * Each thread has an single instance of the following structure. There is one * instance of this structure per thread even if that thread contains multiple @@ -174,7 +174,6 @@ TclThread_Init( Tcl_CreateObjCommand(interp, "testthread", ThreadObjCmd, NULL, NULL); return TCL_OK; } - /* *---------------------------------------------------------------------- @@ -248,7 +247,7 @@ ThreadObjCmd( switch ((enum options)option) { case THREAD_CANCEL: { - long id; + Tcl_WideInt id; const char *result; int flags, arg; @@ -264,7 +263,7 @@ ThreadObjCmd( arg++; } } - if (Tcl_GetLongFromObj(interp, objv[arg], &id) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[arg], &id) != TCL_OK) { return TCL_ERROR; } arg++; @@ -341,7 +340,7 @@ ThreadObjCmd( } else if (objc == 3 && strcmp("-main", Tcl_GetString(objv[2])) == 0) { Tcl_MutexLock(&threadMutex); - idObj = Tcl_NewLongObj((long)(size_t)mainThreadId); + idObj = Tcl_NewWideIntObj((Tcl_WideInt)(size_t)mainThreadId); Tcl_MutexUnlock(&threadMutex); } else { Tcl_WrongNumArgs(interp, 2, objv, NULL); @@ -613,7 +612,7 @@ NewTestThread( */ Tcl_Preserve(tsdPtr->interp); - result = Tcl_Eval(tsdPtr->interp, threadEvalScript); + result = Tcl_EvalEx(tsdPtr->interp, threadEvalScript, -1, 0); if (result != TCL_OK) { ThreadErrorProc(tsdPtr->interp); } @@ -655,9 +654,9 @@ ThreadErrorProc( char *script; char buf[TCL_DOUBLE_SPACE+1]; - sprintf(buf, "%" TCL_LL_MODIFIER "d", (Tcl_WideInt)(size_t)Tcl_GetCurrentThread()); + sprintf(buf, "%p", Tcl_GetCurrentThread()); - errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); + errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY); if (errorProcString == NULL) { errChannel = Tcl_GetStdChannel(TCL_STDERR); Tcl_WriteChars(errChannel, "Error from thread ", -1); @@ -834,7 +833,7 @@ ThreadSend( if (threadId == Tcl_GetCurrentThread()) { Tcl_MutexUnlock(&threadMutex); - return Tcl_GlobalEval(interp, script); + return Tcl_EvalEx(interp, script,-1,TCL_EVAL_GLOBAL); } /* @@ -1029,11 +1028,11 @@ ThreadEventProc( Tcl_Preserve(interp); Tcl_ResetResult(interp); Tcl_CreateThreadExitHandler(ThreadFreeProc, threadEventPtr->script); - code = Tcl_GlobalEval(interp, threadEventPtr->script); + code = Tcl_EvalEx(interp, threadEventPtr->script,-1,TCL_EVAL_GLOBAL); Tcl_DeleteThreadExitHandler(ThreadFreeProc, threadEventPtr->script); if (code != TCL_OK) { - errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY); - errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); + errorCode = Tcl_GetVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY); + errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY); } else { errorCode = errorInfo = NULL; } @@ -1158,6 +1157,14 @@ ThreadExitProc( Tcl_MutexLock(&threadMutex); + if (self == errorThreadId) { + if (errorProcString) { /* Extra safety */ + ckfree(errorProcString); + errorProcString = NULL; + } + errorThreadId = 0; + } + if (threadEvalScript) { ckfree(threadEvalScript); threadEvalScript = NULL; diff --git a/generic/tclTimer.c b/generic/tclTimer.c index c10986a..54854d0 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -91,7 +91,7 @@ typedef struct IdleHandler { * The structure defined below is used in this file only. */ -typedef struct ThreadSpecificData { +typedef struct { TimerHandler *firstTimerHandlerPtr; /* First event in queue. */ int lastTimerId; /* Timer identifier of most recently created * timer. */ @@ -819,9 +819,6 @@ Tcl_AfterObjCmd( */ if (objv[1]->typePtr == &tclIntType -#ifndef TCL_WIDE_INT_IS_LONG - || objv[1]->typePtr == &tclWideIntType -#endif || objv[1]->typePtr == &tclBignumType || (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0, &index) != TCL_OK)) { @@ -900,10 +897,10 @@ Tcl_AfterObjCmd( } else { commandPtr = Tcl_ConcatObj(objc-2, objv+2);; } - command = Tcl_GetStringFromObj(commandPtr, &length); + command = TclGetStringFromObj(commandPtr, &length); for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; afterPtr = afterPtr->nextPtr) { - tempCommand = Tcl_GetStringFromObj(afterPtr->commandPtr, + tempCommand = TclGetStringFromObj(afterPtr->commandPtr, &tempLength); if ((length == tempLength) && !memcmp(command, tempCommand, (unsigned) length)) { @@ -1045,31 +1042,27 @@ AfterDelay( if (iPtr->limit.timeEvent == NULL || TCL_TIME_BEFORE(endTime, iPtr->limit.time)) { diff = TCL_TIME_DIFF_MS_CEILING(endTime, now); -#ifndef TCL_WIDE_INT_IS_LONG - if (diff > LONG_MAX) { - diff = LONG_MAX; - } -#endif if (diff > TCL_TIME_MAXIMUM_SLICE) { diff = TCL_TIME_MAXIMUM_SLICE; } - if (diff == 0 && TCL_TIME_BEFORE(now, endTime)) diff = 1; + if (diff == 0 && TCL_TIME_BEFORE(now, endTime)) { + diff = 1; + } if (diff > 0) { - Tcl_Sleep((long) diff); - if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) break; - } else break; + Tcl_Sleep((int) diff); + if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) { + break; + } + } else { + break; + } } else { diff = TCL_TIME_DIFF_MS(iPtr->limit.time, now); -#ifndef TCL_WIDE_INT_IS_LONG - if (diff > LONG_MAX) { - diff = LONG_MAX; - } -#endif if (diff > TCL_TIME_MAXIMUM_SLICE) { diff = TCL_TIME_MAXIMUM_SLICE; } if (diff > 0) { - Tcl_Sleep((long) diff); + Tcl_Sleep((int) diff); } if (Tcl_AsyncReady()) { if (Tcl_AsyncInvoke(interp, TCL_OK) != TCL_OK) { @@ -1083,7 +1076,7 @@ AfterDelay( return TCL_ERROR; } } - Tcl_GetTime(&now); + Tcl_GetTime(&now); } while (TCL_TIME_BEFORE(now, endTime)); return TCL_OK; } diff --git a/generic/tclTomMath.decls b/generic/tclTomMath.decls index ea3abb1..56ab55f 100644 --- a/generic/tclTomMath.decls +++ b/generic/tclTomMath.decls @@ -1,9 +1,8 @@ # tclTomMath.decls -- # -# This file contains the declarations for the functions in -# 'libtommath' that are contained within the Tcl library. -# This file is used to generate the 'tclTomMathDecls.h' and -# 'tclTomMathStub.c' files. +# This file contains the declarations for the functions in 'libtommath' +# that are contained within the Tcl library. This file is used to +# generate the 'tclTomMathDecls.h' and 'tclStubInit.c' files. # # If you edit this file, advance the revision number (and the epoch # if the new stubs are not backward compatible) in tclTomMathDecls.h @@ -31,13 +30,13 @@ declare 1 { } declare 2 { - int TclBN_mp_add(mp_int *a, mp_int *b, mp_int *c) + int TclBN_mp_add(const mp_int *a, const mp_int *b, mp_int *c) } declare 3 { - int TclBN_mp_add_d(mp_int *a, mp_digit b, mp_int *c) + int TclBN_mp_add_d(const mp_int *a, mp_digit b, mp_int *c) } declare 4 { - int TclBN_mp_and(mp_int *a, mp_int *b, mp_int *c) + int TclBN_mp_and(const mp_int *a, const mp_int *b, mp_int *c) } declare 5 { void TclBN_mp_clamp(mp_int *a) @@ -64,25 +63,25 @@ declare 12 { int TclBN_mp_count_bits(const mp_int *a) } declare 13 { - int TclBN_mp_div(mp_int *a, mp_int *b, mp_int *q, mp_int *r) + int TclBN_mp_div(const mp_int *a, const mp_int *b, mp_int *q, mp_int *r) } declare 14 { - int TclBN_mp_div_d(mp_int *a, mp_digit b, mp_int *q, mp_digit *r) + int TclBN_mp_div_d(const mp_int *a, mp_digit b, mp_int *q, mp_digit *r) } declare 15 { - int TclBN_mp_div_2(mp_int *a, mp_int *q) + int TclBN_mp_div_2(const mp_int *a, mp_int *q) } declare 16 { int TclBN_mp_div_2d(const mp_int *a, int b, mp_int *q, mp_int *r) } declare 17 { - int TclBN_mp_div_3(mp_int *a, mp_int *q, mp_digit *r) + int TclBN_mp_div_3(const mp_int *a, mp_int *q, mp_digit *r) } declare 18 { void TclBN_mp_exch(mp_int *a, mp_int *b) } declare 19 { - int TclBN_mp_expt_d(mp_int *a, mp_digit b, mp_int *c) + int TclBN_mp_expt_d(const mp_int *a, mp_digit b, mp_int *c) } declare 20 { int TclBN_mp_grow(mp_int *a, int size) @@ -91,7 +90,7 @@ declare 21 { int TclBN_mp_init(mp_int *a) } declare 22 { - int TclBN_mp_init_copy(mp_int *a, mp_int *b) + int TclBN_mp_init_copy(mp_int *a, const mp_int *b) } declare 23 { int TclBN_mp_init_multi(mp_int *a, ...) @@ -106,19 +105,19 @@ declare 26 { int TclBN_mp_lshd(mp_int *a, int shift) } declare 27 { - int TclBN_mp_mod(mp_int *a, mp_int *b, mp_int *r) + int TclBN_mp_mod(const mp_int *a, const mp_int *b, mp_int *r) } declare 28 { int TclBN_mp_mod_2d(const mp_int *a, int b, mp_int *r) } declare 29 { - int TclBN_mp_mul(mp_int *a, mp_int *b, mp_int *p) + int TclBN_mp_mul(const mp_int *a, const mp_int *b, mp_int *p) } declare 30 { - int TclBN_mp_mul_d(mp_int *a, mp_digit b, mp_int *p) + int TclBN_mp_mul_d(const mp_int *a, mp_digit b, mp_int *p) } declare 31 { - int TclBN_mp_mul_2(mp_int *a, mp_int *p) + int TclBN_mp_mul_2(const mp_int *a, mp_int *p) } declare 32 { int TclBN_mp_mul_2d(const mp_int *a, int d, mp_int *p) @@ -127,10 +126,10 @@ declare 33 { int TclBN_mp_neg(const mp_int *a, mp_int *b) } declare 34 { - int TclBN_mp_or(mp_int *a, mp_int *b, mp_int *c) + int TclBN_mp_or(const mp_int *a, const mp_int *b, mp_int *c) } declare 35 { - int TclBN_mp_radix_size(mp_int *a, int radix, int *size) + int TclBN_mp_radix_size(const mp_int *a, int radix, int *size) } declare 36 { int TclBN_mp_read_radix(mp_int *a, const char *str, int radix) @@ -145,32 +144,32 @@ declare 39 { void TclBN_mp_set(mp_int *a, mp_digit b) } declare 40 { - int TclBN_mp_sqr(mp_int *a, mp_int *b) + int TclBN_mp_sqr(const mp_int *a, mp_int *b) } declare 41 { - int TclBN_mp_sqrt(mp_int *a, mp_int *b) + int TclBN_mp_sqrt(const mp_int *a, mp_int *b) } declare 42 { - int TclBN_mp_sub(mp_int *a, mp_int *b, mp_int *c) + int TclBN_mp_sub(const mp_int *a, const mp_int *b, mp_int *c) } declare 43 { - int TclBN_mp_sub_d(mp_int *a, mp_digit b, mp_int *c) + int TclBN_mp_sub_d(const mp_int *a, mp_digit b, mp_int *c) } declare 44 { - int TclBN_mp_to_unsigned_bin(mp_int *a, unsigned char *b) + int TclBN_mp_to_unsigned_bin(const mp_int *a, unsigned char *b) } declare 45 { - int TclBN_mp_to_unsigned_bin_n(mp_int *a, unsigned char *b, + int TclBN_mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen) } declare 46 { - int TclBN_mp_toradix_n(mp_int *a, char *str, int radix, int maxlen) + int TclBN_mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen) } declare 47 { - int TclBN_mp_unsigned_bin_size(mp_int *a) + int TclBN_mp_unsigned_bin_size(const mp_int *a) } declare 48 { - int TclBN_mp_xor(mp_int *a, mp_int *b, mp_int *c) + int TclBN_mp_xor(const mp_int *a, const mp_int *b, mp_int *c) } declare 49 { void TclBN_mp_zero(mp_int *a) @@ -183,34 +182,34 @@ declare 50 { void TclBN_reverse(unsigned char *s, int len) } declare 51 { - int TclBN_fast_s_mp_mul_digs(mp_int *a, mp_int *b, mp_int *c, int digs) + int TclBN_fast_s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs) } declare 52 { - int TclBN_fast_s_mp_sqr(mp_int *a, mp_int *b) + int TclBN_fast_s_mp_sqr(const mp_int *a, mp_int *b) } declare 53 { - int TclBN_mp_karatsuba_mul(mp_int *a, mp_int *b, mp_int *c) + int TclBN_mp_karatsuba_mul(const mp_int *a, const mp_int *b, mp_int *c) } declare 54 { - int TclBN_mp_karatsuba_sqr(mp_int *a, mp_int *b) + int TclBN_mp_karatsuba_sqr(const mp_int *a, mp_int *b) } declare 55 { - int TclBN_mp_toom_mul(mp_int *a, mp_int *b, mp_int *c) + int TclBN_mp_toom_mul(const mp_int *a, const mp_int *b, mp_int *c) } declare 56 { - int TclBN_mp_toom_sqr(mp_int *a, mp_int *b) + int TclBN_mp_toom_sqr(const mp_int *a, mp_int *b) } declare 57 { - int TclBN_s_mp_add(mp_int *a, mp_int *b, mp_int *c) + int TclBN_s_mp_add(const mp_int *a, const mp_int *b, mp_int *c) } declare 58 { - int TclBN_s_mp_mul_digs(mp_int *a, mp_int *b, mp_int *c, int digs) + int TclBN_s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs) } declare 59 { - int TclBN_s_mp_sqr(mp_int *a, mp_int *b) + int TclBN_s_mp_sqr(const mp_int *a, mp_int *b) } declare 60 { - int TclBN_s_mp_sub(mp_int *a, mp_int *b, mp_int *c) + int TclBN_s_mp_sub(const mp_int *a, const mp_int *b, mp_int *c) } declare 61 { int TclBN_mp_init_set_int(mp_int *a, unsigned long i) @@ -221,3 +220,40 @@ declare 62 { declare 63 { int TclBN_mp_cnt_lsb(const mp_int *a) } + +# Formerly internal API to allow initialisation of bignums without knowing the +# typedefs of how a bignum works internally. +declare 64 {deprecated {Use mp_init() + mp_set_long_long()}} { + void TclBNInitBignumFromLong(mp_int *bignum, long initVal) +} +declare 65 {deprecated {Use mp_init() + mp_set_long_long()}} { + void TclBNInitBignumFromWideInt(mp_int *bignum, Tcl_WideInt initVal) +} +declare 66 {deprecated {Use mp_init() + mp_set_long_long()}} { + void TclBNInitBignumFromWideUInt(mp_int *bignum, Tcl_WideUInt initVal) +} + +# Added in libtommath 1.0 +declare 67 { + int TclBN_mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast) +} +# Added in libtommath 1.0.1 +declare 68 { + int TclBN_mp_set_long_long(mp_int *a, Tcl_WideUInt i) +} +declare 69 { + Tcl_WideUInt TclBN_mp_get_long_long(const mp_int *a) +} +declare 70 { + int TclBN_mp_set_long(mp_int *a, unsigned long i) +} +declare 71 { + unsigned long TclBN_mp_get_long(const mp_int *a) +} +declare 72 { + unsigned long TclBN_mp_get_int(const mp_int *a) +} + +# Local Variables: +# mode: tcl +# End: diff --git a/generic/tclTomMath.h b/generic/tclTomMath.h index dd9edaf..e0f8497 100644 --- a/generic/tclTomMath.h +++ b/generic/tclTomMath.h @@ -10,7 +10,7 @@ * The library is free for all purposes without any express * guarantee it works. * - * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tstdenis82@gmail.com, http://math.libtomcrypt.com */ #ifndef BN_H_ #define BN_H_ @@ -22,32 +22,19 @@ -#ifndef MIN -# define MIN(x,y) ((x)<(y)?(x):(y)) -#endif - -#ifndef MAX -# define MAX(x,y) ((x)>(y)?(x):(y)) -#endif - #ifdef __cplusplus extern "C" { - -/* C++ compilers don't like assigning void * to mp_digit * */ -#define OPT_CAST(x) (x *) - -#else - -/* C on the other hand doesn't care */ -#define OPT_CAST(x) - #endif +/* MS Visual C++ doesn't have a 128bit type for words, so fall back to 32bit MPI's (where words are 64bit) */ +#if defined(_MSC_VER) || defined(__LLP64__) +# define MP_32BIT +#endif /* detect 64-bit mode if possible */ -#if defined(NEVER) /* 128-bit ints fail in too many places */ -# if !(defined(MP_64BIT) && defined(MP_16BIT) && defined(MP_8BIT)) -# define MP_64BIT +#if defined(NEVER) +# if !(defined(MP_32BIT) || defined(MP_16BIT) || defined(MP_8BIT) || defined(_MSC_VER)) +# define MP_64BIT # endif #endif @@ -61,83 +48,89 @@ extern "C" { */ #ifdef MP_8BIT #ifndef MP_DIGIT_DECLARED - typedef unsigned char mp_digit; +typedef uint8_t mp_digit; #define MP_DIGIT_DECLARED #endif - typedef unsigned short mp_word; +#ifndef MP_WORD_DECLARED +typedef uint16_t mp_word; +#define MP_WORD_DECLARED +#endif +# define MP_SIZEOF_MP_DIGIT 1 +# ifdef DIGIT_BIT +# error You must not define DIGIT_BIT when using MP_8BIT +# endif #elif defined(MP_16BIT) #ifndef MP_DIGIT_DECLARED - typedef unsigned short mp_digit; +typedef uint16_t mp_digit; #define MP_DIGIT_DECLARED #endif - typedef unsigned long mp_word; -#elif defined(MP_64BIT) - /* for GCC only on supported platforms */ -#ifndef CRYPT - typedef unsigned long long ulong64; - typedef signed long long long64; +#ifndef MP_WORD_DECLARED +typedef uint32_t mp_word; +#define MP_WORD_DECLARED #endif - +# define MP_SIZEOF_MP_DIGIT 2 +# ifdef DIGIT_BIT +# error You must not define DIGIT_BIT when using MP_16BIT +# endif +#elif defined(MP_64BIT) +/* for GCC only on supported platforms */ #ifndef MP_DIGIT_DECLARED - typedef unsigned long mp_digit; +typedef uint64_t mp_digit; #define MP_DIGIT_DECLARED #endif - typedef unsigned long mp_word __attribute__ ((mode(TI))); +# if defined(__GNUC__) +typedef unsigned long mp_word __attribute__((mode(TI))); +# else +/* it seems you have a problem + * but we assume you can somewhere define your own uint128_t */ +#ifndef MP_WORD_DECLARED +typedef uint128_t mp_word; +#define MP_WORD_DECLARED +#endif +# endif -# define DIGIT_BIT 60 +# define DIGIT_BIT 60 #else - /* this is the default case, 28-bit digits */ - - /* this is to make porting into LibTomCrypt easier :-) */ -#ifndef CRYPT -# if defined(_MSC_VER) || defined(__BORLANDC__) - typedef unsigned __int64 ulong64; - typedef signed __int64 long64; -# else - typedef unsigned long long ulong64; - typedef signed long long long64; -# endif -#endif +/* this is the default case, 28-bit digits */ +/* this is to make porting into LibTomCrypt easier :-) */ #ifndef MP_DIGIT_DECLARED - typedef unsigned int mp_digit; +typedef uint32_t mp_digit; #define MP_DIGIT_DECLARED #endif - typedef ulong64 mp_word; - -#ifdef MP_31BIT - /* this is an extension that uses 31-bit digits */ -# define DIGIT_BIT 31 -#else - /* default case is 28-bit digits, defines MP_28BIT as a handy macro to test */ -# define DIGIT_BIT 28 -# define MP_28BIT -#endif +#ifndef MP_WORD_DECLARED +typedef uint64_t mp_word; +#define MP_WORD_DECLARED #endif -/* define heap macros */ -#if 0 /* these are macros in tclTomMathDecls.h */ -#ifndef CRYPT - /* default to libc stuff */ -# ifndef XMALLOC -# define XMALLOC malloc -# define XFREE free -# define XREALLOC realloc -# define XCALLOC calloc -# else - /* prototypes for our heap functions */ - extern void *XMALLOC(size_t n); - extern void *XREALLOC(void *p, size_t n); - extern void *XCALLOC(size_t n, size_t s); - extern void XFREE(void *p); -# endif -#endif +# ifdef MP_31BIT +/* this is an extension that uses 31-bit digits */ +# define DIGIT_BIT 31 +# else +/* default case is 28-bit digits, defines MP_28BIT as a handy macro to test */ +# define DIGIT_BIT 28 +# define MP_28BIT +# endif #endif - /* otherwise the bits per digit is calculated automatically from the size of a mp_digit */ #ifndef DIGIT_BIT -# define DIGIT_BIT ((int)((CHAR_BIT * sizeof(mp_digit) - 1))) /* bits per digit */ +# define DIGIT_BIT (((CHAR_BIT * MP_SIZEOF_MP_DIGIT) - 1)) /* bits per digit */ +typedef uint_least32_t mp_min_u32; +#else +typedef mp_digit mp_min_u32; +#endif + +/* use arc4random on platforms that support it */ +#if defined(__FreeBSD__) || defined(__OpenBSD__) || defined(__NetBSD__) || defined(__DragonFly__) +# define MP_GEN_RANDOM() arc4random() +# define MP_GEN_RANDOM_MAX 0xffffffffu +#endif + +/* use rand() as fall-back if there's no better rand function */ +#ifndef MP_GEN_RANDOM +# define MP_GEN_RANDOM() rand() +# define MP_GEN_RANDOM_MAX RAND_MAX #endif #define MP_DIGIT_BIT DIGIT_BIT @@ -170,9 +163,9 @@ typedef int mp_err; /* you'll have to tune these... */ #if defined(BUILD_tcl) || !defined(_WIN32) MODULE_SCOPE int KARATSUBA_MUL_CUTOFF, - KARATSUBA_SQR_CUTOFF, - TOOM_MUL_CUTOFF, - TOOM_SQR_CUTOFF; + KARATSUBA_SQR_CUTOFF, + TOOM_MUL_CUTOFF, + TOOM_SQR_CUTOFF; #endif /* define this to use lower memory usage routines (exptmods mostly) */ @@ -180,15 +173,15 @@ MODULE_SCOPE int KARATSUBA_MUL_CUTOFF, /* default precision */ #ifndef MP_PREC -# ifndef MP_LOW_MEM -# define MP_PREC 32 /* default digits of precision */ -# else -# define MP_PREC 8 /* default digits of precision */ -# endif +# ifndef MP_LOW_MEM +# define MP_PREC 32 /* default digits of precision */ +# else +# define MP_PREC 8 /* default digits of precision */ +# endif #endif /* size of comba arrays, should be at least 2 * 2**(BITS_PER_WORD - BITS_PER_DIGIT*2) */ -#define MP_WARRAY (1 << (sizeof(mp_word) * CHAR_BIT - 2 * DIGIT_BIT + 1)) +#define MP_WARRAY (1u << (((sizeof(mp_word) * CHAR_BIT) - (2 * DIGIT_BIT)) + 1)) /* the infamous mp_int structure */ #ifndef MP_INT_DECLARED @@ -196,22 +189,20 @@ MODULE_SCOPE int KARATSUBA_MUL_CUTOFF, typedef struct mp_int mp_int; #endif struct mp_int { - int used, alloc, sign; - mp_digit *dp; + int used, alloc, sign; + mp_digit *dp; }; /* callback for mp_prime_random, should fill dst with random bytes and return how many read [upto len] */ typedef int ltm_prime_callback(unsigned char *dst, int len, void *dat); -#define USED(m) ((m)->used) -#define DIGIT(m,k) ((m)->dp[(k)]) -#define SIGN(m) ((m)->sign) +#define USED(m) ((m)->used) +#define DIGIT(m, k) ((m)->dp[(k)]) +#define SIGN(m) ((m)->sign) /* error code to char* string */ -/* -char *mp_error_to_string(int code); -*/ +const char *mp_error_to_string(int code); /* ---> init and deinit bignum functions <--- */ /* init a bignum */ @@ -256,8 +247,9 @@ int mp_init_size(mp_int *a, int size); /* ---> Basic Manipulations <--- */ #define mp_iszero(a) (((a)->used == 0) ? MP_YES : MP_NO) -#define mp_iseven(a) (((a)->used == 0 || (((a)->dp[0] & 1) == 0)) ? MP_YES : MP_NO) -#define mp_isodd(a) (((a)->used > 0 && (((a)->dp[0] & 1) == 1)) ? MP_YES : MP_NO) +#define mp_iseven(a) ((((a)->used == 0) || (((a)->dp[0] & 1u) == 0u)) ? MP_YES : MP_NO) +#define mp_isodd(a) ((((a)->used > 0) && (((a)->dp[0] & 1u) == 1u)) ? MP_YES : MP_NO) +#define mp_isneg(a) (((a)->sign != MP_ZPOS) ? MP_YES : MP_NO) /* set to zero */ /* @@ -274,17 +266,39 @@ void mp_set(mp_int *a, mp_digit b); int mp_set_int(mp_int *a, unsigned long b); */ +/* set a platform dependent unsigned long value */ +/* +int mp_set_long(mp_int *a, unsigned long b); +*/ + +/* set a platform dependent Tcl_WideUInt value */ +/* +int mp_set_long_long(mp_int *a, Tcl_WideUInt b); +*/ + /* get a 32-bit value */ -unsigned long mp_get_int(mp_int * a); +/* +unsigned long mp_get_int(const mp_int *a); +*/ + +/* get a platform dependent unsigned long value */ +/* +unsigned long mp_get_long(const mp_int *a); +*/ + +/* get a platform dependent Tcl_WideUInt value */ +/* +Tcl_WideUInt mp_get_long_long(const mp_int *a); +*/ /* initialize and set a digit */ /* -int mp_init_set (mp_int * a, mp_digit b); +int mp_init_set(mp_int *a, mp_digit b); */ /* initialize and set 32-bit value */ /* -int mp_init_set_int (mp_int * a, unsigned long b); +int mp_init_set_int(mp_int *a, unsigned long b); */ /* copy, b = a */ @@ -294,7 +308,7 @@ int mp_copy(const mp_int *a, mp_int *b); /* inits and copies, a = b */ /* -int mp_init_copy(mp_int *a, mp_int *b); +int mp_init_copy(mp_int *a, const mp_int *b); */ /* trim unused digits */ @@ -302,6 +316,16 @@ int mp_init_copy(mp_int *a, mp_int *b); void mp_clamp(mp_int *a); */ +/* import binary data */ +/* +int mp_import(mp_int *rop, size_t count, int order, size_t size, int endian, size_t nails, const void *op); +*/ + +/* export binary data */ +/* +int mp_export(void *rop, size_t *countp, int order, size_t size, int endian, size_t nails, const mp_int *op); +*/ + /* ---> digit manipulation <--- */ /* right shift by "b" digits */ @@ -314,27 +338,27 @@ void mp_rshd(mp_int *a, int b); int mp_lshd(mp_int *a, int b); */ -/* c = a / 2**b */ +/* c = a / 2**b, implemented as c = a >> b */ /* int mp_div_2d(const mp_int *a, int b, mp_int *c, mp_int *d); */ /* b = a/2 */ /* -int mp_div_2(mp_int *a, mp_int *b); +int mp_div_2(const mp_int *a, mp_int *b); */ -/* c = a * 2**b */ +/* c = a * 2**b, implemented as c = a << b */ /* int mp_mul_2d(const mp_int *a, int b, mp_int *c); */ /* b = a*2 */ /* -int mp_mul_2(mp_int *a, mp_int *b); +int mp_mul_2(const mp_int *a, mp_int *b); */ -/* c = a mod 2**d */ +/* c = a mod 2**b */ /* int mp_mod_2d(const mp_int *a, int b, mp_int *c); */ @@ -346,7 +370,7 @@ int mp_2expt(mp_int *a, int b); /* Counts the number of lsbs which are zero before the first zero bit */ /* -int mp_cnt_lsb(mp_int *a); +int mp_cnt_lsb(const mp_int *a); */ /* I Love Earth! */ @@ -359,17 +383,17 @@ int mp_rand(mp_int *a, int digits); /* ---> binary operations <--- */ /* c = a XOR b */ /* -int mp_xor(mp_int *a, mp_int *b, mp_int *c); +int mp_xor(const mp_int *a, const mp_int *b, mp_int *c); */ /* c = a OR b */ /* -int mp_or(mp_int *a, mp_int *b, mp_int *c); +int mp_or(const mp_int *a, const mp_int *b, mp_int *c); */ /* c = a AND b */ /* -int mp_and(mp_int *a, mp_int *b, mp_int *c); +int mp_and(const mp_int *a, const mp_int *b, mp_int *c); */ /* ---> Basic arithmetic <--- */ @@ -381,7 +405,7 @@ int mp_neg(const mp_int *a, mp_int *b); /* b = |a| */ /* -int mp_abs(mp_int *a, mp_int *b); +int mp_abs(const mp_int *a, mp_int *b); */ /* compare a to b */ @@ -396,32 +420,32 @@ int mp_cmp_mag(const mp_int *a, const mp_int *b); /* c = a + b */ /* -int mp_add(mp_int *a, mp_int *b, mp_int *c); +int mp_add(const mp_int *a, const mp_int *b, mp_int *c); */ /* c = a - b */ /* -int mp_sub(mp_int *a, mp_int *b, mp_int *c); +int mp_sub(const mp_int *a, const mp_int *b, mp_int *c); */ /* c = a * b */ /* -int mp_mul(mp_int *a, mp_int *b, mp_int *c); +int mp_mul(const mp_int *a, const mp_int *b, mp_int *c); */ /* b = a*a */ /* -int mp_sqr(mp_int *a, mp_int *b); +int mp_sqr(const mp_int *a, mp_int *b); */ /* a/b => cb + d == a */ /* -int mp_div(mp_int *a, mp_int *b, mp_int *c, mp_int *d); +int mp_div(const mp_int *a, const mp_int *b, mp_int *c, mp_int *d); */ /* c = a mod b, 0 <= c < b */ /* -int mp_mod(mp_int *a, mp_int *b, mp_int *c); +int mp_mod(const mp_int *a, const mp_int *b, mp_int *c); */ /* ---> single digit functions <--- */ @@ -433,79 +457,82 @@ int mp_cmp_d(const mp_int *a, mp_digit b); /* c = a + b */ /* -int mp_add_d(mp_int *a, mp_digit b, mp_int *c); +int mp_add_d(const mp_int *a, mp_digit b, mp_int *c); */ /* c = a - b */ /* -int mp_sub_d(mp_int *a, mp_digit b, mp_int *c); +int mp_sub_d(const mp_int *a, mp_digit b, mp_int *c); */ /* c = a * b */ /* -int mp_mul_d(mp_int *a, mp_digit b, mp_int *c); +int mp_mul_d(const mp_int *a, mp_digit b, mp_int *c); */ /* a/b => cb + d == a */ /* -int mp_div_d(mp_int *a, mp_digit b, mp_int *c, mp_digit *d); +int mp_div_d(const mp_int *a, mp_digit b, mp_int *c, mp_digit *d); */ /* a/3 => 3c + d == a */ /* -int mp_div_3(mp_int *a, mp_int *c, mp_digit *d); +int mp_div_3(const mp_int *a, mp_int *c, mp_digit *d); */ /* c = a**b */ /* -int mp_expt_d(mp_int *a, mp_digit b, mp_int *c); +int mp_expt_d(const mp_int *a, mp_digit b, mp_int *c); +*/ +/* +int mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast); */ /* c = a mod b, 0 <= c < b */ /* -int mp_mod_d(mp_int *a, mp_digit b, mp_digit *c); +int mp_mod_d(const mp_int *a, mp_digit b, mp_digit *c); */ /* ---> number theory <--- */ /* d = a + b (mod c) */ /* -int mp_addmod(mp_int *a, mp_int *b, mp_int *c, mp_int *d); +int mp_addmod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d); */ /* d = a - b (mod c) */ /* -int mp_submod(mp_int *a, mp_int *b, mp_int *c, mp_int *d); +int mp_submod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d); */ /* d = a * b (mod c) */ /* -int mp_mulmod(mp_int *a, mp_int *b, mp_int *c, mp_int *d); +int mp_mulmod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d); */ /* c = a * a (mod b) */ /* -int mp_sqrmod(mp_int *a, mp_int *b, mp_int *c); +int mp_sqrmod(const mp_int *a, const mp_int *b, mp_int *c); */ /* c = 1/a (mod b) */ /* -int mp_invmod(mp_int *a, mp_int *b, mp_int *c); +int mp_invmod(const mp_int *a, const mp_int *b, mp_int *c); */ /* c = (a, b) */ /* -int mp_gcd(mp_int *a, mp_int *b, mp_int *c); +int mp_gcd(const mp_int *a, const mp_int *b, mp_int *c); */ /* produces value such that U1*a + U2*b = U3 */ /* -int mp_exteuclid(mp_int *a, mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3); +int mp_exteuclid(const mp_int *a, const mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3); */ /* c = [a, b] or (a*b)/(a, b) */ /* -int mp_lcm(mp_int *a, mp_int *b, mp_int *c); +int mp_lcm(const mp_int *a, const mp_int *b, mp_int *c); */ /* finds one of the b'th root of a, such that |c|**b <= |a| @@ -513,140 +540,148 @@ int mp_lcm(mp_int *a, mp_int *b, mp_int *c); * returns error if a < 0 and b is even */ /* -int mp_n_root(mp_int *a, mp_digit b, mp_int *c); +int mp_n_root(const mp_int *a, mp_digit b, mp_int *c); +*/ +/* +int mp_n_root_ex(const mp_int *a, mp_digit b, mp_int *c, int fast); */ /* special sqrt algo */ /* -int mp_sqrt(mp_int *arg, mp_int *ret); +int mp_sqrt(const mp_int *arg, mp_int *ret); +*/ + +/* special sqrt (mod prime) */ +/* +int mp_sqrtmod_prime(const mp_int *n, const mp_int *prime, mp_int *ret); */ /* is number a square? */ /* -int mp_is_square(mp_int *arg, int *ret); +int mp_is_square(const mp_int *arg, int *ret); */ /* computes the jacobi c = (a | n) (or Legendre if b is prime) */ /* -int mp_jacobi(mp_int *a, mp_int *n, int *c); +int mp_jacobi(const mp_int *a, const mp_int *n, int *c); */ /* used to setup the Barrett reduction for a given modulus b */ /* -int mp_reduce_setup(mp_int *a, mp_int *b); +int mp_reduce_setup(mp_int *a, const mp_int *b); */ /* Barrett Reduction, computes a (mod b) with a precomputed value c * - * Assumes that 0 < a <= b*b, note if 0 > a > -(b*b) then you can merely - * compute the reduction as -1 * mp_reduce(mp_abs(a)) [pseudo code]. + * Assumes that 0 < x <= m*m, note if 0 > x > -(m*m) then you can merely + * compute the reduction as -1 * mp_reduce(mp_abs(x)) [pseudo code]. */ /* -int mp_reduce(mp_int *a, mp_int *b, mp_int *c); +int mp_reduce(mp_int *x, const mp_int *m, const mp_int *mu); */ /* setups the montgomery reduction */ /* -int mp_montgomery_setup(mp_int *a, mp_digit *mp); +int mp_montgomery_setup(const mp_int *n, mp_digit *rho); */ /* computes a = B**n mod b without division or multiplication useful for * normalizing numbers in a Montgomery system. */ /* -int mp_montgomery_calc_normalization(mp_int *a, mp_int *b); +int mp_montgomery_calc_normalization(mp_int *a, const mp_int *b); */ /* computes x/R == x (mod N) via Montgomery Reduction */ /* -int mp_montgomery_reduce(mp_int *a, mp_int *m, mp_digit mp); +int mp_montgomery_reduce(mp_int *x, const mp_int *n, mp_digit rho); */ /* returns 1 if a is a valid DR modulus */ /* -int mp_dr_is_modulus(mp_int *a); +int mp_dr_is_modulus(const mp_int *a); */ /* sets the value of "d" required for mp_dr_reduce */ /* -void mp_dr_setup(mp_int *a, mp_digit *d); +void mp_dr_setup(const mp_int *a, mp_digit *d); */ -/* reduces a modulo b using the Diminished Radix method */ +/* reduces a modulo n using the Diminished Radix method */ /* -int mp_dr_reduce(mp_int *a, mp_int *b, mp_digit mp); +int mp_dr_reduce(mp_int *x, const mp_int *n, mp_digit k); */ /* returns true if a can be reduced with mp_reduce_2k */ /* -int mp_reduce_is_2k(mp_int *a); +int mp_reduce_is_2k(const mp_int *a); */ /* determines k value for 2k reduction */ /* -int mp_reduce_2k_setup(mp_int *a, mp_digit *d); +int mp_reduce_2k_setup(const mp_int *a, mp_digit *d); */ /* reduces a modulo b where b is of the form 2**p - k [0 <= a] */ /* -int mp_reduce_2k(mp_int *a, mp_int *n, mp_digit d); +int mp_reduce_2k(mp_int *a, const mp_int *n, mp_digit d); */ /* returns true if a can be reduced with mp_reduce_2k_l */ /* -int mp_reduce_is_2k_l(mp_int *a); +int mp_reduce_is_2k_l(const mp_int *a); */ /* determines k value for 2k reduction */ /* -int mp_reduce_2k_setup_l(mp_int *a, mp_int *d); +int mp_reduce_2k_setup_l(const mp_int *a, mp_int *d); */ /* reduces a modulo b where b is of the form 2**p - k [0 <= a] */ /* -int mp_reduce_2k_l(mp_int *a, mp_int *n, mp_int *d); +int mp_reduce_2k_l(mp_int *a, const mp_int *n, const mp_int *d); */ -/* d = a**b (mod c) */ +/* Y = G**X (mod P) */ /* -int mp_exptmod(mp_int *a, mp_int *b, mp_int *c, mp_int *d); +int mp_exptmod(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y); */ /* ---> Primes <--- */ /* number of primes */ #ifdef MP_8BIT -# define PRIME_SIZE 31 +# define PRIME_SIZE 31 #else -# define PRIME_SIZE 256 +# define PRIME_SIZE 256 #endif /* table of first PRIME_SIZE primes */ #if defined(BUILD_tcl) || !defined(_WIN32) -MODULE_SCOPE const mp_digit ltm_prime_tab[]; +MODULE_SCOPE const mp_digit ltm_prime_tab[PRIME_SIZE]; #endif /* result=1 if a is divisible by one of the first PRIME_SIZE primes */ /* -int mp_prime_is_divisible(mp_int *a, int *result); +int mp_prime_is_divisible(const mp_int *a, int *result); */ /* performs one Fermat test of "a" using base "b". * Sets result to 0 if composite or 1 if probable prime */ /* -int mp_prime_fermat(mp_int *a, mp_int *b, int *result); +int mp_prime_fermat(const mp_int *a, const mp_int *b, int *result); */ /* performs one Miller-Rabin test of "a" using base "b". * Sets result to 0 if composite or 1 if probable prime */ /* -int mp_prime_miller_rabin(mp_int *a, mp_int *b, int *result); +int mp_prime_miller_rabin(const mp_int *a, const mp_int *b, int *result); */ /* This gives [for a given bit size] the number of trials required - * such that Miller-Rabin gives a prob of failure lower than 2^-96 + * such that Miller-Rabin gives a prob of failure lower than 2^-96 */ /* int mp_prime_rabin_miller_trials(int size); @@ -660,7 +695,7 @@ int mp_prime_rabin_miller_trials(int size); * Sets result to 1 if probably prime, 0 otherwise */ /* -int mp_prime_is_prime(mp_int *a, int t, int *result); +int mp_prime_is_prime(const mp_int *a, int t, int *result); */ /* finds the next prime after the number "a" using "t" trials @@ -673,7 +708,7 @@ int mp_prime_next_prime(mp_int *a, int t, int bbs_style); */ /* makes a truly random prime of a given size (bytes), - * call with bbs = 1 if you want it to be congruent to 3 mod 4 + * call with bbs = 1 if you want it to be congruent to 3 mod 4 * * You have to supply a callback which fills in a buffer with random bytes. "dat" is a parameter you can * have passed to the callback (e.g. a state or something). This function doesn't use "dat" itself @@ -686,10 +721,9 @@ int mp_prime_next_prime(mp_int *a, int t, int bbs_style); /* makes a truly random prime of a given size (bits), * * Flags are as follows: - * + * * LTM_PRIME_BBS - make prime congruent to 3 mod 4 * LTM_PRIME_SAFE - make sure (p-1)/2 is prime as well (implies LTM_PRIME_BBS) - * LTM_PRIME_2MSB_OFF - make the 2nd highest bit zero * LTM_PRIME_2MSB_ON - make the 2nd highest bit one * * You have to supply a callback which fills in a buffer with random bytes. "dat" is a parameter you can @@ -707,50 +741,52 @@ int mp_count_bits(const mp_int *a); */ /* -int mp_unsigned_bin_size(mp_int *a); +int mp_unsigned_bin_size(const mp_int *a); */ /* int mp_read_unsigned_bin(mp_int *a, const unsigned char *b, int c); */ /* -int mp_to_unsigned_bin(mp_int *a, unsigned char *b); +int mp_to_unsigned_bin(const mp_int *a, unsigned char *b); */ /* -int mp_to_unsigned_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen); +int mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen); */ /* -int mp_signed_bin_size(mp_int *a); +int mp_signed_bin_size(const mp_int *a); */ /* int mp_read_signed_bin(mp_int *a, const unsigned char *b, int c); */ /* -int mp_to_signed_bin(mp_int *a, unsigned char *b); +int mp_to_signed_bin(const mp_int *a, unsigned char *b); */ /* -int mp_to_signed_bin_n (mp_int * a, unsigned char *b, unsigned long *outlen); +int mp_to_signed_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen); */ /* int mp_read_radix(mp_int *a, const char *str, int radix); */ /* -int mp_toradix(mp_int *a, char *str, int radix); +int mp_toradix(const mp_int *a, char *str, int radix); */ /* -int mp_toradix_n(mp_int * a, char *str, int radix, int maxlen); +int mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen); */ /* -int mp_radix_size(mp_int *a, int radix, int *size); +int mp_radix_size(const mp_int *a, int radix, int *size); */ +#ifndef LTM_NO_FILE /* int mp_fread(mp_int *a, int radix, FILE *stream); */ /* -int mp_fwrite(mp_int *a, int radix, FILE *stream); +int mp_fwrite(const mp_int *a, int radix, FILE *stream); */ +#endif #define mp_read_raw(mp, str, len) mp_read_signed_bin((mp), (str), (len)) #define mp_raw_size(mp) mp_signed_bin_size(mp) @@ -764,69 +800,14 @@ int mp_fwrite(mp_int *a, int radix, FILE *stream); #define mp_todecimal(M, S) mp_toradix((M), (S), 10) #define mp_tohex(M, S) mp_toradix((M), (S), 16) -/* lowlevel functions, do not call! */ -/* -int s_mp_add(mp_int *a, mp_int *b, mp_int *c); -*/ -/* -int s_mp_sub(mp_int *a, mp_int *b, mp_int *c); -*/ -#define s_mp_mul(a, b, c) s_mp_mul_digs(a, b, c, (a)->used + (b)->used + 1) -/* -int fast_s_mp_mul_digs(mp_int *a, mp_int *b, mp_int *c, int digs); -*/ -/* -int s_mp_mul_digs(mp_int *a, mp_int *b, mp_int *c, int digs); -*/ -/* -int fast_s_mp_mul_high_digs(mp_int *a, mp_int *b, mp_int *c, int digs); -*/ -/* -int s_mp_mul_high_digs(mp_int *a, mp_int *b, mp_int *c, int digs); -*/ -/* -int fast_s_mp_sqr(mp_int *a, mp_int *b); -*/ -/* -int s_mp_sqr(mp_int *a, mp_int *b); -*/ -/* -int mp_karatsuba_mul(mp_int *a, mp_int *b, mp_int *c); -*/ -/* -int mp_toom_mul(mp_int *a, mp_int *b, mp_int *c); -*/ -/* -int mp_karatsuba_sqr(mp_int *a, mp_int *b); -*/ -/* -int mp_toom_sqr(mp_int *a, mp_int *b); -*/ -/* -int fast_mp_invmod(mp_int *a, mp_int *b, mp_int *c); -*/ -/* -int mp_invmod_slow (mp_int * a, mp_int * b, mp_int * c); -*/ -/* -int fast_mp_montgomery_reduce(mp_int *a, mp_int *m, mp_digit mp); -*/ -/* -int mp_exptmod_fast(mp_int *G, mp_int *X, mp_int *P, mp_int *Y, int mode); -*/ -/* -int s_mp_exptmod (mp_int * G, mp_int * X, mp_int * P, mp_int * Y, int mode); -*/ -/* -void bn_reverse(unsigned char *s, int len); -*/ - -#if defined(BUILD_tcl) || !defined(_WIN32) -MODULE_SCOPE const char *mp_s_rmap; -#endif - #ifdef __cplusplus } #endif #endif + + +/* ref: $Format:%D$ */ +/* git commit: $Format:%H$ */ +/* commit time: $Format:%ai$ */ + diff --git a/generic/tclTomMathDecls.h b/generic/tclTomMathDecls.h index ef22153..9fc034f 100644 --- a/generic/tclTomMathDecls.h +++ b/generic/tclTomMathDecls.h @@ -73,6 +73,10 @@ #define mp_div_d TclBN_mp_div_d #define mp_exch TclBN_mp_exch #define mp_expt_d TclBN_mp_expt_d +#define mp_expt_d_ex TclBN_mp_expt_d_ex +#define mp_get_int TclBN_mp_get_int +#define mp_get_long TclBN_mp_get_long +#define mp_get_long_long TclBN_mp_get_long_long #define mp_grow TclBN_mp_grow #define mp_init TclBN_mp_init #define mp_init_copy TclBN_mp_init_copy @@ -94,9 +98,10 @@ #define mp_radix_size TclBN_mp_radix_size #define mp_read_radix TclBN_mp_read_radix #define mp_rshd TclBN_mp_rshd -#define mp_s_rmap TclBNMpSRmap #define mp_set TclBN_mp_set #define mp_set_int TclBN_mp_set_int +#define mp_set_long TclBN_mp_set_long +#define mp_set_long_long TclBN_mp_set_long_long #define mp_shrink TclBN_mp_shrink #define mp_sqr TclBN_mp_sqr #define mp_sqrt TclBN_mp_sqrt @@ -134,6 +139,10 @@ /* !BEGIN!: Do not edit below this line. */ +#ifdef __cplusplus +extern "C" { +#endif + /* * Exported function declarations: */ @@ -143,11 +152,14 @@ EXTERN int TclBN_epoch(void); /* 1 */ EXTERN int TclBN_revision(void); /* 2 */ -EXTERN int TclBN_mp_add(mp_int *a, mp_int *b, mp_int *c); +EXTERN int TclBN_mp_add(const mp_int *a, const mp_int *b, + mp_int *c); /* 3 */ -EXTERN int TclBN_mp_add_d(mp_int *a, mp_digit b, mp_int *c); +EXTERN int TclBN_mp_add_d(const mp_int *a, mp_digit b, + mp_int *c); /* 4 */ -EXTERN int TclBN_mp_and(mp_int *a, mp_int *b, mp_int *c); +EXTERN int TclBN_mp_and(const mp_int *a, const mp_int *b, + mp_int *c); /* 5 */ EXTERN void TclBN_mp_clamp(mp_int *a); /* 6 */ @@ -165,28 +177,30 @@ EXTERN int TclBN_mp_copy(const mp_int *a, mp_int *b); /* 12 */ EXTERN int TclBN_mp_count_bits(const mp_int *a); /* 13 */ -EXTERN int TclBN_mp_div(mp_int *a, mp_int *b, mp_int *q, - mp_int *r); +EXTERN int TclBN_mp_div(const mp_int *a, const mp_int *b, + mp_int *q, mp_int *r); /* 14 */ -EXTERN int TclBN_mp_div_d(mp_int *a, mp_digit b, mp_int *q, - mp_digit *r); +EXTERN int TclBN_mp_div_d(const mp_int *a, mp_digit b, + mp_int *q, mp_digit *r); /* 15 */ -EXTERN int TclBN_mp_div_2(mp_int *a, mp_int *q); +EXTERN int TclBN_mp_div_2(const mp_int *a, mp_int *q); /* 16 */ EXTERN int TclBN_mp_div_2d(const mp_int *a, int b, mp_int *q, mp_int *r); /* 17 */ -EXTERN int TclBN_mp_div_3(mp_int *a, mp_int *q, mp_digit *r); +EXTERN int TclBN_mp_div_3(const mp_int *a, mp_int *q, + mp_digit *r); /* 18 */ EXTERN void TclBN_mp_exch(mp_int *a, mp_int *b); /* 19 */ -EXTERN int TclBN_mp_expt_d(mp_int *a, mp_digit b, mp_int *c); +EXTERN int TclBN_mp_expt_d(const mp_int *a, mp_digit b, + mp_int *c); /* 20 */ EXTERN int TclBN_mp_grow(mp_int *a, int size); /* 21 */ EXTERN int TclBN_mp_init(mp_int *a); /* 22 */ -EXTERN int TclBN_mp_init_copy(mp_int *a, mp_int *b); +EXTERN int TclBN_mp_init_copy(mp_int *a, const mp_int *b); /* 23 */ EXTERN int TclBN_mp_init_multi(mp_int *a, ...); /* 24 */ @@ -196,23 +210,28 @@ EXTERN int TclBN_mp_init_size(mp_int *a, int size); /* 26 */ EXTERN int TclBN_mp_lshd(mp_int *a, int shift); /* 27 */ -EXTERN int TclBN_mp_mod(mp_int *a, mp_int *b, mp_int *r); +EXTERN int TclBN_mp_mod(const mp_int *a, const mp_int *b, + mp_int *r); /* 28 */ EXTERN int TclBN_mp_mod_2d(const mp_int *a, int b, mp_int *r); /* 29 */ -EXTERN int TclBN_mp_mul(mp_int *a, mp_int *b, mp_int *p); +EXTERN int TclBN_mp_mul(const mp_int *a, const mp_int *b, + mp_int *p); /* 30 */ -EXTERN int TclBN_mp_mul_d(mp_int *a, mp_digit b, mp_int *p); +EXTERN int TclBN_mp_mul_d(const mp_int *a, mp_digit b, + mp_int *p); /* 31 */ -EXTERN int TclBN_mp_mul_2(mp_int *a, mp_int *p); +EXTERN int TclBN_mp_mul_2(const mp_int *a, mp_int *p); /* 32 */ EXTERN int TclBN_mp_mul_2d(const mp_int *a, int d, mp_int *p); /* 33 */ EXTERN int TclBN_mp_neg(const mp_int *a, mp_int *b); /* 34 */ -EXTERN int TclBN_mp_or(mp_int *a, mp_int *b, mp_int *c); +EXTERN int TclBN_mp_or(const mp_int *a, const mp_int *b, + mp_int *c); /* 35 */ -EXTERN int TclBN_mp_radix_size(mp_int *a, int radix, int *size); +EXTERN int TclBN_mp_radix_size(const mp_int *a, int radix, + int *size); /* 36 */ EXTERN int TclBN_mp_read_radix(mp_int *a, const char *str, int radix); @@ -223,58 +242,89 @@ EXTERN int TclBN_mp_shrink(mp_int *a); /* 39 */ EXTERN void TclBN_mp_set(mp_int *a, mp_digit b); /* 40 */ -EXTERN int TclBN_mp_sqr(mp_int *a, mp_int *b); +EXTERN int TclBN_mp_sqr(const mp_int *a, mp_int *b); /* 41 */ -EXTERN int TclBN_mp_sqrt(mp_int *a, mp_int *b); +EXTERN int TclBN_mp_sqrt(const mp_int *a, mp_int *b); /* 42 */ -EXTERN int TclBN_mp_sub(mp_int *a, mp_int *b, mp_int *c); +EXTERN int TclBN_mp_sub(const mp_int *a, const mp_int *b, + mp_int *c); /* 43 */ -EXTERN int TclBN_mp_sub_d(mp_int *a, mp_digit b, mp_int *c); +EXTERN int TclBN_mp_sub_d(const mp_int *a, mp_digit b, + mp_int *c); /* 44 */ -EXTERN int TclBN_mp_to_unsigned_bin(mp_int *a, unsigned char *b); +EXTERN int TclBN_mp_to_unsigned_bin(const mp_int *a, + unsigned char *b); /* 45 */ -EXTERN int TclBN_mp_to_unsigned_bin_n(mp_int *a, +EXTERN int TclBN_mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen); /* 46 */ -EXTERN int TclBN_mp_toradix_n(mp_int *a, char *str, int radix, - int maxlen); +EXTERN int TclBN_mp_toradix_n(const mp_int *a, char *str, + int radix, int maxlen); /* 47 */ -EXTERN int TclBN_mp_unsigned_bin_size(mp_int *a); +EXTERN int TclBN_mp_unsigned_bin_size(const mp_int *a); /* 48 */ -EXTERN int TclBN_mp_xor(mp_int *a, mp_int *b, mp_int *c); +EXTERN int TclBN_mp_xor(const mp_int *a, const mp_int *b, + mp_int *c); /* 49 */ EXTERN void TclBN_mp_zero(mp_int *a); /* 50 */ EXTERN void TclBN_reverse(unsigned char *s, int len); /* 51 */ -EXTERN int TclBN_fast_s_mp_mul_digs(mp_int *a, mp_int *b, - mp_int *c, int digs); +EXTERN int TclBN_fast_s_mp_mul_digs(const mp_int *a, + const mp_int *b, mp_int *c, int digs); /* 52 */ -EXTERN int TclBN_fast_s_mp_sqr(mp_int *a, mp_int *b); +EXTERN int TclBN_fast_s_mp_sqr(const mp_int *a, mp_int *b); /* 53 */ -EXTERN int TclBN_mp_karatsuba_mul(mp_int *a, mp_int *b, - mp_int *c); +EXTERN int TclBN_mp_karatsuba_mul(const mp_int *a, + const mp_int *b, mp_int *c); /* 54 */ -EXTERN int TclBN_mp_karatsuba_sqr(mp_int *a, mp_int *b); +EXTERN int TclBN_mp_karatsuba_sqr(const mp_int *a, mp_int *b); /* 55 */ -EXTERN int TclBN_mp_toom_mul(mp_int *a, mp_int *b, mp_int *c); +EXTERN int TclBN_mp_toom_mul(const mp_int *a, const mp_int *b, + mp_int *c); /* 56 */ -EXTERN int TclBN_mp_toom_sqr(mp_int *a, mp_int *b); +EXTERN int TclBN_mp_toom_sqr(const mp_int *a, mp_int *b); /* 57 */ -EXTERN int TclBN_s_mp_add(mp_int *a, mp_int *b, mp_int *c); +EXTERN int TclBN_s_mp_add(const mp_int *a, const mp_int *b, + mp_int *c); /* 58 */ -EXTERN int TclBN_s_mp_mul_digs(mp_int *a, mp_int *b, mp_int *c, - int digs); +EXTERN int TclBN_s_mp_mul_digs(const mp_int *a, const mp_int *b, + mp_int *c, int digs); /* 59 */ -EXTERN int TclBN_s_mp_sqr(mp_int *a, mp_int *b); +EXTERN int TclBN_s_mp_sqr(const mp_int *a, mp_int *b); /* 60 */ -EXTERN int TclBN_s_mp_sub(mp_int *a, mp_int *b, mp_int *c); +EXTERN int TclBN_s_mp_sub(const mp_int *a, const mp_int *b, + mp_int *c); /* 61 */ EXTERN int TclBN_mp_init_set_int(mp_int *a, unsigned long i); /* 62 */ EXTERN int TclBN_mp_set_int(mp_int *a, unsigned long i); /* 63 */ EXTERN int TclBN_mp_cnt_lsb(const mp_int *a); +/* 64 */ +TCL_DEPRECATED("Use mp_init() + mp_set_long_long()") +void TclBNInitBignumFromLong(mp_int *bignum, long initVal); +/* 65 */ +TCL_DEPRECATED("Use mp_init() + mp_set_long_long()") +void TclBNInitBignumFromWideInt(mp_int *bignum, + Tcl_WideInt initVal); +/* 66 */ +TCL_DEPRECATED("Use mp_init() + mp_set_long_long()") +void TclBNInitBignumFromWideUInt(mp_int *bignum, + Tcl_WideUInt initVal); +/* 67 */ +EXTERN int TclBN_mp_expt_d_ex(const mp_int *a, mp_digit b, + mp_int *c, int fast); +/* 68 */ +EXTERN int TclBN_mp_set_long_long(mp_int *a, Tcl_WideUInt i); +/* 69 */ +EXTERN Tcl_WideUInt TclBN_mp_get_long_long(const mp_int *a); +/* 70 */ +EXTERN int TclBN_mp_set_long(mp_int *a, unsigned long i); +/* 71 */ +EXTERN unsigned long TclBN_mp_get_long(const mp_int *a); +/* 72 */ +EXTERN unsigned long TclBN_mp_get_int(const mp_int *a); typedef struct TclTomMathStubs { int magic; @@ -282,9 +332,9 @@ typedef struct TclTomMathStubs { int (*tclBN_epoch) (void); /* 0 */ int (*tclBN_revision) (void); /* 1 */ - int (*tclBN_mp_add) (mp_int *a, mp_int *b, mp_int *c); /* 2 */ - int (*tclBN_mp_add_d) (mp_int *a, mp_digit b, mp_int *c); /* 3 */ - int (*tclBN_mp_and) (mp_int *a, mp_int *b, mp_int *c); /* 4 */ + int (*tclBN_mp_add) (const mp_int *a, const mp_int *b, mp_int *c); /* 2 */ + int (*tclBN_mp_add_d) (const mp_int *a, mp_digit b, mp_int *c); /* 3 */ + int (*tclBN_mp_and) (const mp_int *a, const mp_int *b, mp_int *c); /* 4 */ void (*tclBN_mp_clamp) (mp_int *a); /* 5 */ void (*tclBN_mp_clear) (mp_int *a); /* 6 */ void (*tclBN_mp_clear_multi) (mp_int *a, ...); /* 7 */ @@ -293,63 +343,70 @@ typedef struct TclTomMathStubs { int (*tclBN_mp_cmp_mag) (const mp_int *a, const mp_int *b); /* 10 */ int (*tclBN_mp_copy) (const mp_int *a, mp_int *b); /* 11 */ int (*tclBN_mp_count_bits) (const mp_int *a); /* 12 */ - int (*tclBN_mp_div) (mp_int *a, mp_int *b, mp_int *q, mp_int *r); /* 13 */ - int (*tclBN_mp_div_d) (mp_int *a, mp_digit b, mp_int *q, mp_digit *r); /* 14 */ - int (*tclBN_mp_div_2) (mp_int *a, mp_int *q); /* 15 */ + int (*tclBN_mp_div) (const mp_int *a, const mp_int *b, mp_int *q, mp_int *r); /* 13 */ + int (*tclBN_mp_div_d) (const mp_int *a, mp_digit b, mp_int *q, mp_digit *r); /* 14 */ + int (*tclBN_mp_div_2) (const mp_int *a, mp_int *q); /* 15 */ int (*tclBN_mp_div_2d) (const mp_int *a, int b, mp_int *q, mp_int *r); /* 16 */ - int (*tclBN_mp_div_3) (mp_int *a, mp_int *q, mp_digit *r); /* 17 */ + int (*tclBN_mp_div_3) (const mp_int *a, mp_int *q, mp_digit *r); /* 17 */ void (*tclBN_mp_exch) (mp_int *a, mp_int *b); /* 18 */ - int (*tclBN_mp_expt_d) (mp_int *a, mp_digit b, mp_int *c); /* 19 */ + int (*tclBN_mp_expt_d) (const mp_int *a, mp_digit b, mp_int *c); /* 19 */ int (*tclBN_mp_grow) (mp_int *a, int size); /* 20 */ int (*tclBN_mp_init) (mp_int *a); /* 21 */ - int (*tclBN_mp_init_copy) (mp_int *a, mp_int *b); /* 22 */ + int (*tclBN_mp_init_copy) (mp_int *a, const mp_int *b); /* 22 */ int (*tclBN_mp_init_multi) (mp_int *a, ...); /* 23 */ int (*tclBN_mp_init_set) (mp_int *a, mp_digit b); /* 24 */ int (*tclBN_mp_init_size) (mp_int *a, int size); /* 25 */ int (*tclBN_mp_lshd) (mp_int *a, int shift); /* 26 */ - int (*tclBN_mp_mod) (mp_int *a, mp_int *b, mp_int *r); /* 27 */ + int (*tclBN_mp_mod) (const mp_int *a, const mp_int *b, mp_int *r); /* 27 */ int (*tclBN_mp_mod_2d) (const mp_int *a, int b, mp_int *r); /* 28 */ - int (*tclBN_mp_mul) (mp_int *a, mp_int *b, mp_int *p); /* 29 */ - int (*tclBN_mp_mul_d) (mp_int *a, mp_digit b, mp_int *p); /* 30 */ - int (*tclBN_mp_mul_2) (mp_int *a, mp_int *p); /* 31 */ + int (*tclBN_mp_mul) (const mp_int *a, const mp_int *b, mp_int *p); /* 29 */ + int (*tclBN_mp_mul_d) (const mp_int *a, mp_digit b, mp_int *p); /* 30 */ + int (*tclBN_mp_mul_2) (const mp_int *a, mp_int *p); /* 31 */ int (*tclBN_mp_mul_2d) (const mp_int *a, int d, mp_int *p); /* 32 */ int (*tclBN_mp_neg) (const mp_int *a, mp_int *b); /* 33 */ - int (*tclBN_mp_or) (mp_int *a, mp_int *b, mp_int *c); /* 34 */ - int (*tclBN_mp_radix_size) (mp_int *a, int radix, int *size); /* 35 */ + int (*tclBN_mp_or) (const mp_int *a, const mp_int *b, mp_int *c); /* 34 */ + int (*tclBN_mp_radix_size) (const mp_int *a, int radix, int *size); /* 35 */ int (*tclBN_mp_read_radix) (mp_int *a, const char *str, int radix); /* 36 */ void (*tclBN_mp_rshd) (mp_int *a, int shift); /* 37 */ int (*tclBN_mp_shrink) (mp_int *a); /* 38 */ void (*tclBN_mp_set) (mp_int *a, mp_digit b); /* 39 */ - int (*tclBN_mp_sqr) (mp_int *a, mp_int *b); /* 40 */ - int (*tclBN_mp_sqrt) (mp_int *a, mp_int *b); /* 41 */ - int (*tclBN_mp_sub) (mp_int *a, mp_int *b, mp_int *c); /* 42 */ - int (*tclBN_mp_sub_d) (mp_int *a, mp_digit b, mp_int *c); /* 43 */ - int (*tclBN_mp_to_unsigned_bin) (mp_int *a, unsigned char *b); /* 44 */ - int (*tclBN_mp_to_unsigned_bin_n) (mp_int *a, unsigned char *b, unsigned long *outlen); /* 45 */ - int (*tclBN_mp_toradix_n) (mp_int *a, char *str, int radix, int maxlen); /* 46 */ - int (*tclBN_mp_unsigned_bin_size) (mp_int *a); /* 47 */ - int (*tclBN_mp_xor) (mp_int *a, mp_int *b, mp_int *c); /* 48 */ + int (*tclBN_mp_sqr) (const mp_int *a, mp_int *b); /* 40 */ + int (*tclBN_mp_sqrt) (const mp_int *a, mp_int *b); /* 41 */ + int (*tclBN_mp_sub) (const mp_int *a, const mp_int *b, mp_int *c); /* 42 */ + int (*tclBN_mp_sub_d) (const mp_int *a, mp_digit b, mp_int *c); /* 43 */ + int (*tclBN_mp_to_unsigned_bin) (const mp_int *a, unsigned char *b); /* 44 */ + int (*tclBN_mp_to_unsigned_bin_n) (const mp_int *a, unsigned char *b, unsigned long *outlen); /* 45 */ + int (*tclBN_mp_toradix_n) (const mp_int *a, char *str, int radix, int maxlen); /* 46 */ + int (*tclBN_mp_unsigned_bin_size) (const mp_int *a); /* 47 */ + int (*tclBN_mp_xor) (const mp_int *a, const mp_int *b, mp_int *c); /* 48 */ void (*tclBN_mp_zero) (mp_int *a); /* 49 */ void (*tclBN_reverse) (unsigned char *s, int len); /* 50 */ - int (*tclBN_fast_s_mp_mul_digs) (mp_int *a, mp_int *b, mp_int *c, int digs); /* 51 */ - int (*tclBN_fast_s_mp_sqr) (mp_int *a, mp_int *b); /* 52 */ - int (*tclBN_mp_karatsuba_mul) (mp_int *a, mp_int *b, mp_int *c); /* 53 */ - int (*tclBN_mp_karatsuba_sqr) (mp_int *a, mp_int *b); /* 54 */ - int (*tclBN_mp_toom_mul) (mp_int *a, mp_int *b, mp_int *c); /* 55 */ - int (*tclBN_mp_toom_sqr) (mp_int *a, mp_int *b); /* 56 */ - int (*tclBN_s_mp_add) (mp_int *a, mp_int *b, mp_int *c); /* 57 */ - int (*tclBN_s_mp_mul_digs) (mp_int *a, mp_int *b, mp_int *c, int digs); /* 58 */ - int (*tclBN_s_mp_sqr) (mp_int *a, mp_int *b); /* 59 */ - int (*tclBN_s_mp_sub) (mp_int *a, mp_int *b, mp_int *c); /* 60 */ + int (*tclBN_fast_s_mp_mul_digs) (const mp_int *a, const mp_int *b, mp_int *c, int digs); /* 51 */ + int (*tclBN_fast_s_mp_sqr) (const mp_int *a, mp_int *b); /* 52 */ + int (*tclBN_mp_karatsuba_mul) (const mp_int *a, const mp_int *b, mp_int *c); /* 53 */ + int (*tclBN_mp_karatsuba_sqr) (const mp_int *a, mp_int *b); /* 54 */ + int (*tclBN_mp_toom_mul) (const mp_int *a, const mp_int *b, mp_int *c); /* 55 */ + int (*tclBN_mp_toom_sqr) (const mp_int *a, mp_int *b); /* 56 */ + int (*tclBN_s_mp_add) (const mp_int *a, const mp_int *b, mp_int *c); /* 57 */ + int (*tclBN_s_mp_mul_digs) (const mp_int *a, const mp_int *b, mp_int *c, int digs); /* 58 */ + int (*tclBN_s_mp_sqr) (const mp_int *a, mp_int *b); /* 59 */ + int (*tclBN_s_mp_sub) (const mp_int *a, const mp_int *b, mp_int *c); /* 60 */ int (*tclBN_mp_init_set_int) (mp_int *a, unsigned long i); /* 61 */ int (*tclBN_mp_set_int) (mp_int *a, unsigned long i); /* 62 */ int (*tclBN_mp_cnt_lsb) (const mp_int *a); /* 63 */ + TCL_DEPRECATED_API("Use mp_init() + mp_set_long_long()") void (*tclBNInitBignumFromLong) (mp_int *bignum, long initVal); /* 64 */ + TCL_DEPRECATED_API("Use mp_init() + mp_set_long_long()") void (*tclBNInitBignumFromWideInt) (mp_int *bignum, Tcl_WideInt initVal); /* 65 */ + TCL_DEPRECATED_API("Use mp_init() + mp_set_long_long()") void (*tclBNInitBignumFromWideUInt) (mp_int *bignum, Tcl_WideUInt initVal); /* 66 */ + int (*tclBN_mp_expt_d_ex) (const mp_int *a, mp_digit b, mp_int *c, int fast); /* 67 */ + int (*tclBN_mp_set_long_long) (mp_int *a, Tcl_WideUInt i); /* 68 */ + Tcl_WideUInt (*tclBN_mp_get_long_long) (const mp_int *a); /* 69 */ + int (*tclBN_mp_set_long) (mp_int *a, unsigned long i); /* 70 */ + unsigned long (*tclBN_mp_get_long) (const mp_int *a); /* 71 */ + unsigned long (*tclBN_mp_get_int) (const mp_int *a); /* 72 */ } TclTomMathStubs; -#ifdef __cplusplus -extern "C" { -#endif extern const TclTomMathStubs *tclTomMathStubsPtr; + #ifdef __cplusplus } #endif @@ -488,6 +545,24 @@ extern const TclTomMathStubs *tclTomMathStubsPtr; (tclTomMathStubsPtr->tclBN_mp_set_int) /* 62 */ #define TclBN_mp_cnt_lsb \ (tclTomMathStubsPtr->tclBN_mp_cnt_lsb) /* 63 */ +#define TclBNInitBignumFromLong \ + (tclTomMathStubsPtr->tclBNInitBignumFromLong) /* 64 */ +#define TclBNInitBignumFromWideInt \ + (tclTomMathStubsPtr->tclBNInitBignumFromWideInt) /* 65 */ +#define TclBNInitBignumFromWideUInt \ + (tclTomMathStubsPtr->tclBNInitBignumFromWideUInt) /* 66 */ +#define TclBN_mp_expt_d_ex \ + (tclTomMathStubsPtr->tclBN_mp_expt_d_ex) /* 67 */ +#define TclBN_mp_set_long_long \ + (tclTomMathStubsPtr->tclBN_mp_set_long_long) /* 68 */ +#define TclBN_mp_get_long_long \ + (tclTomMathStubsPtr->tclBN_mp_get_long_long) /* 69 */ +#define TclBN_mp_set_long \ + (tclTomMathStubsPtr->tclBN_mp_set_long) /* 70 */ +#define TclBN_mp_get_long \ + (tclTomMathStubsPtr->tclBN_mp_get_long) /* 71 */ +#define TclBN_mp_get_int \ + (tclTomMathStubsPtr->tclBN_mp_get_int) /* 72 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclTomMathInterface.c b/generic/tclTomMathInterface.c index 48db8c3..9e7bf4b 100644 --- a/generic/tclTomMathInterface.c +++ b/generic/tclTomMathInterface.c @@ -89,86 +89,11 @@ TclBN_revision(void) { return TCLTOMMATH_REVISION; } -#if 0 /* *---------------------------------------------------------------------- * - * TclBNAlloc -- - * - * Allocate memory for libtommath. - * - * Results: - * Returns a pointer to the allocated block. - * - * This procedure is a wrapper around Tcl_Alloc, needed because of a - * mismatched type signature between Tcl_Alloc and malloc. - * - *---------------------------------------------------------------------- - */ - -extern void * -TclBNAlloc( - size_t x) -{ - return (void *) ckalloc((unsigned int) x); -} - -/* - *---------------------------------------------------------------------- - * - * TclBNRealloc -- - * - * Change the size of an allocated block of memory in libtommath - * - * Results: - * Returns a pointer to the allocated block. - * - * This procedure is a wrapper around Tcl_Realloc, needed because of a - * mismatched type signature between Tcl_Realloc and realloc. - * - *---------------------------------------------------------------------- - */ - -void * -TclBNRealloc( - void *p, - size_t s) -{ - return (void *) ckrealloc((char *) p, (unsigned int) s); -} - -/* - *---------------------------------------------------------------------- - * - * TclBNFree -- - * - * Free allocated memory in libtommath. - * - * Results: - * None. - * - * Side effects: - * Memory is freed. - * - * This function is simply a wrapper around Tcl_Free, needed in libtommath - * because of a type mismatch between free and Tcl_Free. - * - *---------------------------------------------------------------------- - */ - -extern void -TclBNFree( - void *p) -{ - ckree((char *) p); -} -#endif - -/* - *---------------------------------------------------------------------- - * - * TclBNInitBignumFromLong -- + * TclInitBignumFromLong -- * * Allocate and initialize a 'bignum' from a native 'long'. * @@ -181,47 +106,20 @@ TclBNFree( *---------------------------------------------------------------------- */ -extern void -TclBNInitBignumFromLong( +void +TclInitBignumFromLong( mp_int *a, - long initVal) + long v) { - int status; - unsigned long v; - mp_digit *p; - - /* - * Allocate enough memory to hold the largest possible long - */ - - status = mp_init_size(a, - (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1) / DIGIT_BIT); - if (status != MP_OKAY) { - Tcl_Panic("initialization failure in TclBNInitBignumFromLong"); + if (mp_init_size(a, (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1) / DIGIT_BIT) != MP_OKAY) { + Tcl_Panic("initialization failure in TclInitBignumFromLong"); } - - /* - * Convert arg to sign and magnitude. - */ - - if (initVal < 0) { - a->sign = MP_NEG; - v = -initVal; + if (v < (long)0) { + mp_set_long_long(a, (Tcl_WideUInt)(-(Tcl_WideInt)v)); + mp_neg(a, a); } else { - a->sign = MP_ZPOS; - v = initVal; - } - - /* - * Store the magnitude in the bignum. - */ - - p = a->dp; - while (v) { - *p++ = (mp_digit) (v & MP_MASK); - v >>= MP_DIGIT_BIT; + mp_set_long_long(a, (Tcl_WideUInt)v); } - a->used = p - a->dp; } /* @@ -240,16 +138,19 @@ TclBNInitBignumFromLong( *---------------------------------------------------------------------- */ -extern void -TclBNInitBignumFromWideInt( +void +TclInitBignumFromWideInt( mp_int *a, /* Bignum to initialize */ Tcl_WideInt v) /* Initial value */ { + if (mp_init_size(a, (CHAR_BIT * sizeof(Tcl_WideUInt) + DIGIT_BIT - 1) / DIGIT_BIT) != MP_OKAY) { + Tcl_Panic("initialization failure in TclInitBignumFromWideInt"); + } if (v < (Tcl_WideInt)0) { - TclBNInitBignumFromWideUInt(a, (Tcl_WideUInt)(-v)); + mp_set_long_long(a, (Tcl_WideUInt)(-v)); mp_neg(a, a); } else { - TclBNInitBignumFromWideUInt(a, (Tcl_WideUInt)v); + mp_set_long_long(a, (Tcl_WideUInt)v); } } @@ -269,36 +170,15 @@ TclBNInitBignumFromWideInt( *---------------------------------------------------------------------- */ -extern void -TclBNInitBignumFromWideUInt( +void +TclInitBignumFromWideUInt( mp_int *a, /* Bignum to initialize */ Tcl_WideUInt v) /* Initial value */ { - int status; - mp_digit *p; - - /* - * Allocate enough memory to hold the largest possible Tcl_WideUInt. - */ - - status = mp_init_size(a, - (CHAR_BIT * sizeof(Tcl_WideUInt) + DIGIT_BIT - 1) / DIGIT_BIT); - if (status != MP_OKAY) { - Tcl_Panic("initialization failure in TclBNInitBignumFromWideUInt"); - } - - a->sign = MP_ZPOS; - - /* - * Store the magnitude in the bignum. - */ - - p = a->dp; - while (v) { - *p++ = (mp_digit) (v & MP_MASK); - v >>= MP_DIGIT_BIT; - } - a->used = p - a->dp; + if (mp_init_size(a, (CHAR_BIT * sizeof(Tcl_WideUInt) + DIGIT_BIT - 1) / DIGIT_BIT) != MP_OKAY) { + Tcl_Panic("initialization failure in TclInitBignumFromWideUInt"); + } + mp_set_long_long(a, v); } /* diff --git a/generic/tclTrace.c b/generic/tclTrace.c index c0cde49..8663eae 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -52,7 +52,7 @@ typedef struct { * invoked step trace */ int curFlags; /* Trace flags for the current command */ int curCode; /* Return code for the current command */ - int refCount; /* Used to ensure this structure is not + size_t refCount; /* Used to ensure this structure is not * deleted too early. Keeps track of how many * pieces of code have a pointer to this * structure. */ @@ -143,7 +143,7 @@ static int TraceVarEx(Tcl_Interp *interp, const char *part1, * trace procs */ -typedef struct StringTraceData { +typedef struct { ClientData clientData; /* Client data from Tcl_CreateTrace */ Tcl_CmdTraceProc *proc; /* Trace function from Tcl_CreateTrace */ } StringTraceData; @@ -191,8 +191,10 @@ Tcl_TraceObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { int optionIndex; +#ifndef TCL_REMOVE_OBSOLETE_TRACES const char *name; const char *flagOps, *p; +#endif /* Main sub commands to 'trace' */ static const char *const traceOptions[] = { "add", "info", "remove", @@ -278,7 +280,7 @@ Tcl_TraceObjCmd( opsList = Tcl_NewObj(); Tcl_IncrRefCount(opsList); - flagOps = Tcl_GetStringFromObj(objv[3], &numFlags); + flagOps = TclGetStringFromObj(objv[3], &numFlags); if (numFlags == 0) { Tcl_DecrRefCount(opsList); goto badVarOps; @@ -365,12 +367,14 @@ Tcl_TraceObjCmd( } return TCL_OK; +#ifndef TCL_REMOVE_OBSOLETE_TRACES badVarOps: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad operations \"%s\": should be one or more of rwua", flagOps)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "BADOPS", NULL); return TCL_ERROR; +#endif } /* @@ -462,7 +466,7 @@ TraceExecutionObjCmd( break; } } - command = Tcl_GetStringFromObj(objv[5], &commandLength); + command = TclGetStringFromObj(objv[5], &commandLength); length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { TraceCommandInfo *tcmdPtr = ckalloc( @@ -544,7 +548,7 @@ TraceExecutionObjCmd( tcmdPtr->flags = 0; } - if ((--tcmdPtr->refCount) <= 0) { + if (tcmdPtr->refCount-- <= 1) { ckfree(tcmdPtr); } break; @@ -701,7 +705,7 @@ TraceCommandObjCmd( } } - command = Tcl_GetStringFromObj(objv[5], &commandLength); + command = TclGetStringFromObj(objv[5], &commandLength); length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { TraceCommandInfo *tcmdPtr = ckalloc( @@ -748,7 +752,7 @@ TraceCommandObjCmd( Tcl_UntraceCommand(interp, name, flags | TCL_TRACE_DELETE, TraceCommandProc, clientData); tcmdPtr->flags |= TCL_TRACE_DESTROYED; - if ((--tcmdPtr->refCount) <= 0) { + if (tcmdPtr->refCount-- <= 1) { ckfree(tcmdPtr); } break; @@ -904,7 +908,7 @@ TraceVariableObjCmd( break; } } - command = Tcl_GetStringFromObj(objv[5], &commandLength); + command = TclGetStringFromObj(objv[5], &commandLength); length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { CombinedTraceVarInfo *ctvarPtr = ckalloc( @@ -912,9 +916,11 @@ TraceVariableObjCmd( + 1 + length); ctvarPtr->traceCmdInfo.flags = flags; +#ifndef TCL_REMOVE_OBSOLETE_TRACES if (objv[0] == NULL) { ctvarPtr->traceCmdInfo.flags |= TCL_TRACE_OLD_STYLE; } +#endif ctvarPtr->traceCmdInfo.length = length; flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT; memcpy(ctvarPtr->traceCmdInfo.command, command, length+1); @@ -939,7 +945,11 @@ TraceVariableObjCmd( TraceVarInfo *tvarPtr = clientData; if ((tvarPtr->length == length) - && ((tvarPtr->flags & ~TCL_TRACE_OLD_STYLE)==flags) + && ((tvarPtr->flags +#ifndef TCL_REMOVE_OBSOLETE_TRACES +& ~TCL_TRACE_OLD_STYLE +#endif + )==flags) && (strncmp(command, tvarPtr->command, (size_t) length) == 0)) { Tcl_UntraceVar2(interp, name, NULL, @@ -1130,7 +1140,7 @@ Tcl_TraceCommand( /* * Bug 3484621: up the interp's epoch if this is a BC'ed command */ - + if ((cmdPtr->compileProc != NULL) && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES)){ Interp *iPtr = (Interp *) interp; iPtr->compileEpoch++; @@ -1138,7 +1148,7 @@ Tcl_TraceCommand( cmdPtr->flags |= CMD_HAS_EXEC_TRACES; } - + return TCL_OK; } @@ -1223,7 +1233,7 @@ Tcl_UntraceCommand( } tracePtr->flags = 0; - if ((--tracePtr->refCount) <= 0) { + if (tracePtr->refCount-- <= 1) { ckfree(tracePtr); } @@ -1245,7 +1255,7 @@ Tcl_UntraceCommand( /* * Bug 3484621: up the interp's epoch if this is a BC'ed command */ - + if (cmdPtr->compileProc != NULL) { Interp *iPtr = (Interp *) interp; iPtr->compileEpoch++; @@ -1382,7 +1392,7 @@ TraceCommandProc( Tcl_RestoreInterpState(interp, state); tcmdPtr->refCount--; } - if ((--tcmdPtr->refCount) <= 0) { + if (tcmdPtr->refCount-- <= 1) { ckfree(tcmdPtr); } } @@ -1474,7 +1484,7 @@ TclCheckExecutionTraces( } traceCode = TraceExecutionProc(tcmdPtr, interp, curLevel, command, (Tcl_Command) cmdPtr, objc, objv); - if ((--tcmdPtr->refCount) <= 0) { + if (tcmdPtr->refCount-- <= 1) { ckfree(tcmdPtr); } } @@ -1721,7 +1731,7 @@ CommandObjTraceDeleted( { TraceCommandInfo *tcmdPtr = clientData; - if ((--tcmdPtr->refCount) <= 0) { + if (tcmdPtr->refCount-- <= 1) { ckfree(tcmdPtr); } } @@ -1889,7 +1899,8 @@ TraceExecutionProc( * interpreter. */ - traceCode = Tcl_Eval(interp, Tcl_DStringValue(&cmd)); + traceCode = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd), + Tcl_DStringLength(&cmd), 0); tcmdPtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS; /* @@ -1936,7 +1947,7 @@ TraceExecutionProc( } } if (call) { - if ((--tcmdPtr->refCount) <= 0) { + if (tcmdPtr->refCount-- <= 1) { ckfree(tcmdPtr); } } @@ -2467,6 +2478,47 @@ TclVarTraceExists( /* *---------------------------------------------------------------------- * + * TclCheckArrayTraces -- + * + * This function is invoked to when we operate on an array variable, + * to allow any array traces to fire. + * + * Results: + * Returns TCL_OK to indicate normal operation. Returns TCL_ERROR if + * invocation of a trace function indicated an error. When TCL_ERROR is + * returned, then error information is left in interp. + * + * Side effects: + * Almost anything can happen, depending on trace; this function itself + * doesn't have any side effects. + * + *---------------------------------------------------------------------- + */ + +int +TclCheckArrayTraces( + Tcl_Interp *interp, + Var *varPtr, + Var *arrayPtr, + Tcl_Obj *name, + int index) +{ + int code = TCL_OK; + + if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) + && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { + Interp *iPtr = (Interp *)interp; + + code = TclObjCallVarTraces(iPtr, arrayPtr, varPtr, name, NULL, + (TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| TCL_TRACE_ARRAY), + /* leaveErrMsg */ 1, index); + } + return code; +} + +/* + *---------------------------------------------------------------------- + * * TclCallVarTraces -- * * This function is invoked to find and invoke relevant trace functions @@ -2511,6 +2563,9 @@ TclObjCallVarTraces( if (!part1Ptr) { part1Ptr = localName(iPtr->varFramePtr, index); } + if (!part1Ptr) { + Tcl_Panic("Cannot trace a variable with no name"); + } part1 = TclGetString(part1Ptr); part2 = part2Ptr? TclGetString(part2Ptr) : NULL; @@ -2815,6 +2870,7 @@ DisposeTraceResult( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_UntraceVar void Tcl_UntraceVar( @@ -2830,6 +2886,7 @@ Tcl_UntraceVar( { Tcl_UntraceVar2(interp, varName, NULL, flags, proc, clientData); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -2984,6 +3041,7 @@ Tcl_UntraceVar2( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_VarTraceInfo ClientData Tcl_VarTraceInfo( @@ -3001,6 +3059,7 @@ Tcl_VarTraceInfo( return Tcl_VarTraceInfo2(interp, varName, NULL, flags, proc, prevClientData); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -3093,6 +3152,7 @@ Tcl_VarTraceInfo2( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_TraceVar int Tcl_TraceVar( @@ -3110,6 +3170,7 @@ Tcl_TraceVar( { return Tcl_TraceVar2(interp, varName, NULL, flags, proc, clientData); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- diff --git a/generic/tclUniData.c b/generic/tclUniData.c index 5c88639..faca93d 100644 --- a/generic/tclUniData.c +++ b/generic/tclUniData.c @@ -29,36 +29,36 @@ static const unsigned short pageMap[] = { 832, 864, 896, 928, 960, 992, 224, 1024, 224, 1056, 224, 224, 1088, 1120, 1152, 1184, 1216, 1248, 1280, 1312, 1344, 1376, 1408, 1344, 1344, 1440, 1472, 1504, 1536, 1568, 1344, 1344, 1600, 1632, 1664, 1696, 1728, - 1760, 1792, 1792, 1824, 1792, 1856, 1888, 1920, 1952, 1984, 2016, 2048, - 2080, 2112, 2144, 2176, 2208, 2240, 2272, 2304, 2336, 2368, 2016, 2400, - 2432, 2464, 2496, 2528, 2560, 2592, 2624, 2656, 2688, 2720, 2752, 2784, - 2816, 2848, 2752, 2880, 2912, 2944, 2976, 3008, 3040, 3072, 3104, 3136, - 3168, 1792, 3200, 3232, 3264, 1792, 3296, 3328, 3360, 3392, 3424, 3456, - 3488, 1792, 1344, 3520, 3552, 3584, 3616, 3648, 3680, 3712, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 3744, 1344, 3776, 3808, - 3840, 1344, 3872, 1344, 3904, 3936, 3968, 1344, 1344, 4000, 4032, 1344, + 1760, 1792, 1824, 1856, 1888, 1920, 1952, 1984, 2016, 2048, 2080, 2112, + 2144, 2176, 2208, 2240, 2272, 2304, 2336, 2368, 2400, 2432, 2464, 2496, + 2528, 2560, 2592, 2624, 2656, 2688, 2720, 2752, 2784, 2816, 2848, 2880, + 2912, 2944, 2976, 3008, 3040, 3072, 3104, 3136, 3168, 3200, 3232, 3264, + 3296, 1824, 3328, 3360, 3392, 1824, 3424, 3456, 3488, 3520, 3552, 3584, + 3616, 1824, 1344, 3648, 3680, 3712, 3744, 3776, 3808, 3840, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 3872, 1344, 3904, 3936, + 3968, 1344, 4000, 1344, 4032, 4064, 4096, 4128, 4128, 4160, 4192, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 4064, 4096, 1344, 1344, 4128, 4160, 4192, - 4224, 4256, 1344, 4288, 4320, 4352, 4384, 1344, 4416, 4448, 1344, 4480, - 1344, 4512, 4544, 4576, 4608, 4640, 1344, 4672, 4704, 4736, 4768, 1344, - 4800, 4832, 4864, 4896, 1792, 1792, 4928, 4960, 4992, 5024, 5056, 5088, - 1344, 5120, 1344, 5152, 5184, 5216, 1792, 1792, 5248, 5280, 5312, 5344, - 5376, 5408, 5440, 5376, 704, 5472, 224, 224, 224, 224, 5504, 224, 224, - 224, 5536, 5568, 5600, 5632, 5664, 5696, 5728, 5760, 5792, 5824, 5856, - 5888, 5920, 5952, 5984, 6016, 6048, 6080, 6112, 6144, 6176, 6208, 6240, - 6272, 6304, 6304, 6304, 6304, 6304, 6304, 6304, 6304, 6336, 6368, 4736, - 6400, 6432, 6464, 6496, 6528, 4736, 6560, 6592, 6624, 6656, 6688, 6720, - 6752, 4736, 4736, 4736, 4736, 4736, 6784, 6816, 6848, 4736, 4736, 4736, - 6880, 4736, 4736, 4736, 4736, 6912, 4736, 4736, 6944, 6976, 4736, 7008, - 7040, 4736, 4736, 4736, 4736, 4736, 4736, 4736, 4736, 6304, 6304, 6304, - 6304, 7072, 6304, 7104, 7136, 6304, 6304, 6304, 6304, 6304, 6304, 6304, - 6304, 4736, 7168, 7200, 1792, 1792, 1792, 1792, 1792, 7232, 7264, 7296, - 7328, 224, 224, 224, 7360, 7392, 7424, 1344, 7456, 7488, 7520, 7520, - 704, 7552, 7584, 1792, 1792, 7616, 4736, 4736, 7648, 4736, 4736, 4736, - 4736, 4736, 4736, 7680, 7712, 7744, 7776, 3104, 1344, 7808, 4032, 1344, - 7840, 7872, 7904, 1344, 1344, 7936, 7968, 4736, 8000, 8032, 8064, 8096, - 4736, 8064, 8128, 4736, 8032, 4736, 4736, 4736, 4736, 4736, 4736, 4736, - 4736, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 4224, 4256, 1344, 1344, 4288, 4320, 4352, + 4384, 4416, 1344, 4448, 4480, 4512, 4544, 1344, 4576, 4608, 4640, 4672, + 1344, 4704, 4736, 4768, 4800, 4832, 1344, 4864, 4896, 4928, 4960, 1344, + 4992, 5024, 5056, 5088, 1824, 1824, 5120, 5152, 5184, 5216, 5248, 5280, + 1344, 5312, 1344, 5344, 5376, 5408, 5440, 5472, 5504, 5536, 5568, 5600, + 5632, 5664, 5696, 5632, 704, 5728, 224, 224, 224, 224, 5760, 224, 224, + 224, 5792, 5824, 5856, 5888, 5920, 5952, 5984, 6016, 6048, 6080, 6112, + 6144, 6176, 6208, 6240, 6272, 6304, 6336, 6368, 6400, 6432, 6464, 6496, + 6528, 6560, 6560, 6560, 6560, 6560, 6560, 6560, 6560, 6592, 6624, 4928, + 6656, 6688, 6720, 6752, 6784, 4928, 6816, 6848, 6880, 6912, 6944, 6976, + 7008, 4928, 4928, 4928, 4928, 4928, 7040, 7072, 7104, 4928, 4928, 4928, + 7136, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 7168, 7200, 4928, 7232, + 7264, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 6560, 6560, 6560, + 6560, 7296, 6560, 7328, 7360, 6560, 6560, 6560, 6560, 6560, 6560, 6560, + 6560, 4928, 7392, 7424, 7456, 7488, 4928, 7520, 7552, 7584, 7616, 7648, + 7680, 224, 224, 224, 7712, 7744, 7776, 1344, 7808, 7840, 7872, 7872, + 704, 7904, 7936, 7968, 1824, 8000, 4928, 4928, 8032, 4928, 4928, 4928, + 4928, 4928, 4928, 8064, 8096, 8128, 8160, 3232, 1344, 8192, 4192, 1344, + 8224, 8256, 8288, 1344, 1344, 8320, 8352, 4928, 8384, 7552, 8416, 8448, + 4928, 8416, 8480, 4928, 7552, 4928, 4928, 4928, 4928, 4928, 4928, 4928, + 4928, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, @@ -75,7 +75,7 @@ static const unsigned short pageMap[] = { 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 4512, 4736, 4736, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 4704, 4928, 4928, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, @@ -129,17 +129,16 @@ static const unsigned short pageMap[] = { 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 8160, - 1792, 8192, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 8512, 8544, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 8224, 4736, 8256, 5216, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 8288, 8320, 224, 8352, 8384, 1344, 1344, 8416, 8448, 8480, 224, - 8512, 8544, 8576, 1792, 8608, 8640, 8672, 1344, 8704, 8736, 8768, 8800, - 8832, 1632, 8864, 8896, 4544, 1888, 8928, 8960, 1792, 1344, 8992, 9024, - 9056, 1344, 9088, 9120, 9152, 9184, 9216, 1792, 1792, 1792, 1792, 1344, - 9248, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 8576, 4928, 8608, 5408, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 8640, 8672, 224, 8704, 8736, 1344, 1344, 8768, 8800, 8832, 224, + 8864, 8896, 8928, 1824, 8960, 8992, 9024, 1344, 9056, 9088, 9120, 9152, + 9184, 1632, 9216, 9248, 9280, 1952, 9312, 9344, 9376, 1344, 9408, 9440, + 9472, 1344, 9504, 9536, 9568, 9600, 9632, 9664, 9696, 9728, 9728, 1344, + 9760, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, @@ -167,209 +166,235 @@ static const unsigned short pageMap[] = { 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 9280, 9312, 9344, 9376, 9376, 9376, 9376, 9376, 9376, 9376, - 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, - 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, - 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, - 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, - 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9376, 9408, 9408, 9408, - 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, - 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, - 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, - 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, - 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, - 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, - 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, - 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, - 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, - 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, - 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, - 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, - 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, - 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, - 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, - 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, 9408, - 9408, 9408, 9408, 9408, 9408, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 9440, 1344, 1344, 9472, 1792, 9504, 9536, 9568, - 1344, 1344, 9600, 9632, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 9664, 9696, 1344, 9728, 1344, 9760, 9792, 9824, 9856, 9888, - 9920, 1344, 1344, 1344, 9952, 9984, 64, 10016, 10048, 10080, 10112, - 10144, 10176 + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 9792, 9824, 9856, 9888, 9888, 9888, 9888, 9888, 9888, 9888, + 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, + 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, + 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, + 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, + 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9920, 9920, 9920, + 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, + 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, + 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, + 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, + 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, + 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, + 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, + 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, + 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, + 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, + 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, + 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, + 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, + 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, + 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, + 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, 9920, + 9920, 9920, 9920, 9920, 9920, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 9952, 1344, 1344, 9984, 1824, 10016, 10048, + 10080, 1344, 1344, 10112, 10144, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 10176, 10208, 1344, 10240, 1344, 10272, 10304, + 10336, 10368, 10400, 10432, 1344, 1344, 1344, 10464, 10496, 64, 10528, + 10560, 10592, 4736, 10624, 10656 #if TCL_UTF_MAX > 3 - ,10208, 10240, 10272, 1792, 1344, 1344, 1344, 7968, 10304, 10336, 10368, - 10400, 10432, 1792, 10464, 10496, 1792, 1792, 1792, 1792, 4544, 1344, - 10528, 1792, 10112, 10560, 10592, 1792, 10624, 1344, 10656, 1792, 10688, - 10720, 10752, 1344, 10784, 10816, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 10848, 10880, 10912, - 1792, 1792, 1792, 1792, 1792, 10944, 10976, 1792, 1792, 1344, 11008, - 1792, 1792, 11040, 11072, 11104, 11136, 1792, 1792, 1792, 1792, 1344, - 11168, 11200, 11232, 1792, 1792, 1792, 1792, 1344, 1344, 11264, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 11296, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 11328, 11360, 11392, 11424, 5056, 11456, - 11488, 11520, 11552, 11584, 11616, 1792, 5056, 11648, 11680, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1344, 11712, 10816, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 11744, 1792, 1792, - 1792, 1792, 10368, 10368, 10368, 11776, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 11744, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 11808, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1344, 1344, 11840, 11872, 11904, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 11936, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 4736, 4736, 4736, 4736, 4736, 4736, 4736, 7680, 4736, - 11968, 4736, 12000, 12032, 12064, 12096, 1792, 4736, 4736, 12128, 1792, - 1792, 1792, 1792, 1792, 4736, 4736, 12160, 12192, 1792, 1792, 1792, - 1792, 12224, 12256, 12288, 12320, 12352, 12384, 12416, 12448, 12480, - 12512, 12544, 12576, 12608, 12224, 12256, 12640, 12320, 12672, 12704, - 12736, 12448, 12768, 12800, 12832, 12864, 12896, 12928, 12960, 12992, - 13024, 13056, 13088, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 13120, 13152, 13184, 13216, 13248, 13280, 1792, 13312, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 4736, 13344, 4736, 4736, 7648, - 13376, 13408, 1792, 13440, 13472, 4736, 13344, 13504, 1792, 1792, 13536, - 13568, 13504, 13600, 1792, 1792, 1792, 1792, 1792, 4736, 13632, 4736, - 13664, 7648, 4736, 13696, 13728, 4736, 8032, 13760, 4736, 4736, 4736, - 4736, 13792, 4736, 12096, 13824, 13856, 1792, 1792, 1792, 13888, 4736, - 4736, 13920, 1792, 4736, 4736, 13952, 1792, 4736, 4736, 4736, 7648, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1344, 1344, 1344, 1344, + ,10688, 10720, 10752, 1824, 1344, 1344, 1344, 8352, 10784, 10816, 10848, + 10880, 10912, 10944, 10976, 11008, 1824, 1824, 1824, 1824, 9280, 1344, + 11040, 11072, 1344, 11104, 11136, 11168, 11200, 1344, 11232, 1824, + 11264, 11296, 11328, 1344, 11360, 11392, 11424, 11456, 1344, 11488, + 1344, 11520, 1824, 1824, 1824, 1824, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 7840, 4704, 10272, 1824, 1824, 1824, 1824, + 11552, 11584, 11616, 11648, 4736, 11680, 1824, 11712, 11744, 11776, + 1824, 1824, 1344, 11808, 11840, 6880, 11872, 11904, 11936, 11968, 12000, + 1824, 12032, 12064, 1344, 12096, 12128, 12160, 12192, 12224, 1824, + 1824, 1344, 1344, 12256, 1824, 12288, 12320, 12352, 12384, 1344, 12416, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 12448, 1824, + 1824, 1824, 1824, 12000, 12480, 12512, 1824, 1824, 1824, 1824, 1824, + 12544, 12576, 12608, 12640, 5248, 12672, 12704, 12736, 12768, 12800, + 12832, 12864, 5248, 12896, 12928, 12960, 12992, 13024, 1824, 1824, + 13056, 13088, 13120, 13152, 13184, 13216, 13248, 13280, 1824, 1824, + 1824, 1824, 1344, 13312, 13344, 1824, 1344, 13376, 13408, 1824, 1824, + 1824, 1824, 1824, 1344, 13440, 13472, 1824, 1344, 13504, 13536, 13568, + 1344, 13600, 13632, 1824, 4032, 13664, 1824, 1824, 1824, 1824, 1824, + 1824, 1344, 13696, 1824, 1824, 1824, 13728, 13760, 13792, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 13824, 13856, 13888, 1344, 13920, + 13952, 1344, 4608, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 13984, 14016, 14048, 14080, 14112, 14144, 1824, 1824, 14176, 14208, + 14240, 14272, 14304, 13632, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 14336, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 9984, 1824, 1824, 1824, 10848, 10848, 10848, + 14368, 1344, 1344, 1344, 1344, 1344, 1344, 14400, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 14432, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 14464, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 4608, 4736, 14496, + 1824, 1824, 10208, 14528, 1344, 14560, 14592, 14624, 8512, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 13728, 13760, 14656, 1824, + 1824, 1824, 1344, 1344, 14688, 14720, 14752, 1824, 1824, 14784, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 14816, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 14848, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 4736, 1824, 1824, 10208, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 9856, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1344, 1344, 1344, + 14880, 14912, 14944, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 8064, 4928, 14976, + 4928, 15008, 15040, 15072, 4928, 15104, 4928, 4928, 15136, 1824, 1824, + 1824, 1824, 15168, 4928, 4928, 15200, 15232, 1824, 1824, 1824, 1824, + 15264, 15296, 15328, 15360, 15392, 15424, 15456, 15488, 15520, 15552, + 15584, 15616, 15648, 15264, 15296, 15680, 15360, 15712, 15744, 15776, + 15488, 15808, 15840, 15872, 15904, 15936, 15968, 16000, 16032, 16064, + 16096, 16128, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, + 4928, 4928, 4928, 4928, 4928, 4928, 4928, 704, 16160, 704, 16192, 16224, + 16256, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 16288, 16320, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1344, 1344, 1344, 1344, 1344, 1344, 16352, 1824, 16384, 16416, + 16448, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 16480, 6880, 16512, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 16544, 16576, 16608, 16640, 16672, 16704, 1824, + 16736, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 4928, 16768, + 4928, 4928, 8032, 16800, 16832, 8064, 16864, 4928, 4928, 16768, 4928, + 16896, 1824, 16928, 16960, 16992, 17024, 17056, 1824, 1824, 1824, 1824, + 4928, 4928, 4928, 4928, 4928, 4928, 4928, 17088, 4928, 4928, 4928, + 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, + 4928, 4928, 4928, 4928, 4928, 4928, 4928, 17120, 17152, 4928, 4928, + 4928, 8032, 4928, 4928, 17184, 1824, 16768, 4928, 17216, 4928, 17248, + 17280, 1824, 1824, 16768, 7552, 4928, 17312, 4928, 17344, 16960, 4928, + 1824, 1824, 1824, 17280, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, @@ -458,6 +483,7 @@ static const unsigned short pageMap[] = { 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 7840, 1824, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, @@ -468,6 +494,7 @@ static const unsigned short pageMap[] = { 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 17376, 1344, 1344, 1344, 1344, 1344, 1344, 11360, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, @@ -480,9 +507,9 @@ static const unsigned short pageMap[] = { 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 7488, 1792, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 17408, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, @@ -491,52 +518,27 @@ static const unsigned short pageMap[] = { 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 4000, 1344, 1344, - 1344, 1344, 1344, 1344, 10784, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, - 1792, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, - 1344, 1344, 1344, 1344, 1344, 10784 + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 17440, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, + 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 11360 #endif /* TCL_UTF_MAX > 3 */ }; @@ -577,546 +579,579 @@ static const unsigned char groupMap[] = { 21, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 21, 21, 21, 21, 21, 21, 55, 23, 24, 56, 57, 58, 58, 23, 24, 59, 60, 61, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 62, 63, 64, 65, - 66, 21, 67, 67, 21, 68, 21, 69, 21, 21, 21, 21, 67, 21, 21, 70, 21, - 71, 72, 21, 73, 74, 21, 75, 21, 21, 21, 74, 21, 76, 77, 21, 21, 78, - 21, 21, 21, 21, 21, 21, 21, 79, 21, 21, 80, 21, 21, 80, 21, 21, 21, - 21, 80, 81, 82, 82, 83, 21, 21, 21, 21, 21, 84, 21, 15, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, - 85, 85, 85, 85, 85, 85, 85, 85, 11, 11, 11, 11, 85, 85, 85, 85, 85, - 85, 85, 85, 85, 85, 85, 85, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, - 11, 11, 11, 11, 85, 85, 85, 85, 85, 11, 11, 11, 11, 11, 11, 11, 85, - 11, 85, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, - 11, 11, 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, 87, 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, 86, 86, 86, 86, 23, 24, 23, - 24, 85, 11, 23, 24, 0, 0, 85, 42, 42, 42, 3, 0, 0, 0, 0, 0, 11, 11, - 88, 3, 89, 89, 89, 0, 90, 0, 91, 91, 21, 10, 10, 10, 10, 10, 10, 10, + 66, 21, 67, 67, 21, 68, 21, 69, 70, 21, 21, 21, 67, 71, 21, 72, 21, + 73, 74, 21, 75, 76, 74, 77, 78, 21, 21, 76, 21, 79, 80, 21, 21, 81, + 21, 21, 21, 21, 21, 21, 21, 82, 21, 21, 83, 21, 21, 83, 21, 21, 21, + 84, 83, 85, 86, 86, 87, 21, 21, 21, 21, 21, 88, 21, 15, 21, 21, 21, + 21, 21, 21, 21, 21, 89, 90, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, + 91, 91, 91, 91, 91, 91, 91, 91, 11, 11, 11, 11, 91, 91, 91, 91, 91, + 91, 91, 91, 91, 91, 91, 91, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, + 11, 11, 11, 11, 91, 91, 91, 91, 91, 11, 11, 11, 11, 11, 11, 11, 91, + 11, 91, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, + 11, 11, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 92, 92, 92, 92, 93, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 23, 24, 23, + 24, 91, 11, 23, 24, 0, 0, 91, 42, 42, 42, 3, 94, 0, 0, 0, 0, 11, 11, + 95, 3, 96, 96, 96, 0, 97, 0, 98, 98, 21, 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, 92, 93, 93, 93, 21, 13, 13, 13, 13, 13, 13, 13, 13, 13, - 13, 13, 13, 13, 13, 13, 13, 13, 94, 13, 13, 13, 13, 13, 13, 13, 13, - 13, 95, 96, 96, 97, 98, 99, 100, 100, 100, 101, 102, 103, 23, 24, 23, - 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, - 23, 24, 23, 24, 104, 105, 106, 21, 107, 108, 7, 23, 24, 109, 23, 24, - 21, 54, 54, 54, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, - 110, 110, 110, 110, 110, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, + 10, 10, 10, 99, 100, 100, 100, 21, 13, 13, 13, 13, 13, 13, 13, 13, + 13, 13, 13, 13, 13, 13, 13, 13, 13, 101, 13, 13, 13, 13, 13, 13, 13, + 13, 13, 102, 103, 103, 104, 105, 106, 107, 107, 107, 108, 109, 110, + 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, + 24, 23, 24, 23, 24, 23, 24, 111, 112, 113, 114, 115, 116, 7, 23, 24, + 117, 23, 24, 21, 54, 54, 54, 118, 118, 118, 118, 118, 118, 118, 118, + 118, 118, 118, 118, 118, 118, 118, 118, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, - 10, 10, 10, 10, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, + 10, 10, 10, 10, 10, 10, 10, 10, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, - 13, 13, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, - 105, 105, 105, 105, 23, 24, 14, 86, 86, 86, 86, 86, 111, 111, 23, 24, - 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, - 24, 23, 24, 112, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, - 24, 113, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, - 24, 23, 24, 23, 24, 23, 24, 23, 24, 0, 0, 0, 0, 0, 0, 0, 0, 0, 114, - 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, - 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, - 114, 114, 114, 114, 114, 114, 114, 114, 114, 0, 0, 85, 3, 3, 3, 3, - 3, 3, 0, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, - 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, - 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 21, 0, - 3, 8, 0, 0, 0, 0, 4, 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, 86, 86, 86, 86, 86, 86, 86, - 8, 86, 3, 86, 86, 3, 86, 86, 3, 86, 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, 0, 0, 0, 0, 0, 15, 15, 15, 3, 3, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 17, 17, 17, 17, 0, 7, 7, 7, 3, 3, - 4, 3, 3, 14, 14, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 3, 0, - 0, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 85, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 86, 86, 86, 86, 86, - 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 9, 9, 9, - 9, 9, 9, 9, 9, 9, 9, 3, 3, 3, 3, 15, 15, 86, 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, 3, 15, 86, 86, 86, - 86, 86, 86, 86, 17, 14, 86, 86, 86, 86, 86, 86, 85, 85, 86, 86, 14, - 86, 86, 86, 86, 15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 14, - 14, 15, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 0, 17, 15, 86, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 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, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 86, 86, - 86, 86, 86, 86, 86, 86, 86, 86, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 86, 86, 86, 86, 86, 86, 86, - 86, 85, 85, 14, 3, 3, 3, 85, 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, 86, - 86, 86, 86, 85, 86, 86, 86, 86, 86, 86, 86, 86, 86, 85, 86, 86, 86, - 85, 86, 86, 86, 86, 86, 0, 0, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, - 3, 3, 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, 86, 86, 86, 0, 0, 3, 0, 0, + 13, 13, 13, 13, 13, 13, 112, 112, 112, 112, 112, 112, 112, 112, 112, + 112, 112, 112, 112, 112, 112, 112, 23, 24, 14, 92, 92, 92, 92, 92, + 119, 119, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, + 24, 23, 24, 23, 24, 23, 24, 120, 23, 24, 23, 24, 23, 24, 23, 24, 23, + 24, 23, 24, 23, 24, 121, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, + 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, + 23, 24, 23, 24, 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, 122, 122, 122, 122, 122, 122, 122, + 0, 0, 91, 3, 3, 3, 3, 3, 3, 21, 123, 123, 123, 123, 123, 123, 123, + 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, + 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, + 123, 123, 123, 21, 21, 3, 8, 0, 0, 14, 14, 4, 0, 92, 92, 92, 92, 92, + 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 92, 92, 92, 92, 92, 8, 92, 3, 92, 92, 3, 92, 92, 3, 92, 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, 0, 0, 0, 0, + 15, 15, 15, 15, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 17, 17, + 17, 17, 17, 7, 7, 7, 3, 3, 4, 3, 3, 14, 14, 92, 92, 92, 92, 92, 92, + 92, 92, 92, 92, 92, 3, 17, 0, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 91, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 92, 92, 92, 92, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 3, 3, 15, 15, + 92, 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, 3, 15, 92, 92, 92, 92, 92, 92, 92, 17, 14, 92, 92, 92, 92, + 92, 92, 91, 91, 92, 92, 14, 92, 92, 92, 92, 15, 15, 9, 9, 9, 9, 9, + 9, 9, 9, 9, 9, 15, 15, 15, 14, 14, 15, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 3, 3, 0, 17, 15, 92, 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, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 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, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 15, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, + 9, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 92, 92, 92, 92, 92, 92, 92, 92, 92, 91, 91, 14, 3, 3, 3, 91, 0, 0, + 92, 4, 4, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 92, 92, 92, 92, 91, 92, 92, 92, 92, 92, + 92, 92, 92, 92, 91, 92, 92, 92, 91, 92, 92, 92, 92, 92, 0, 0, 3, 3, + 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 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, 92, 92, 92, 0, 0, 3, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 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, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, - 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 0, 86, 86, 86, 116, + 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, 0, 15, 15, 15, 15, 15, + 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 17, + 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 124, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 86, 116, 86, 15, 116, 116, 116, 86, 86, 86, 86, 86, 86, - 86, 86, 116, 116, 116, 116, 86, 116, 116, 15, 86, 86, 86, 86, 86, 86, - 86, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 86, 3, 3, 9, 9, 9, - 9, 9, 9, 9, 9, 9, 9, 3, 85, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, - 15, 15, 15, 15, 0, 86, 116, 116, 0, 15, 15, 15, 15, 15, 15, 15, 15, - 0, 0, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, - 15, 0, 15, 0, 0, 0, 15, 15, 15, 15, 0, 0, 86, 15, 116, 116, 116, 86, - 86, 86, 86, 0, 0, 116, 116, 0, 0, 116, 116, 86, 15, 0, 0, 0, 0, 0, - 0, 0, 0, 116, 0, 0, 0, 0, 15, 15, 0, 15, 15, 15, 86, 86, 0, 0, 9, 9, - 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 4, 4, 18, 18, 18, 18, 18, 18, 14, 4, - 0, 0, 0, 0, 0, 86, 86, 116, 0, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, + 15, 15, 92, 124, 92, 15, 124, 124, 124, 92, 92, 92, 92, 92, 92, 92, + 92, 124, 124, 124, 124, 92, 124, 124, 15, 92, 92, 92, 92, 92, 92, 92, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 92, 92, 3, 3, 9, 9, 9, 9, 9, + 9, 9, 9, 9, 9, 3, 91, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 92, 124, 124, 0, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, - 15, 0, 15, 15, 0, 15, 15, 0, 0, 86, 0, 116, 116, 116, 86, 86, 0, 0, - 0, 0, 86, 86, 0, 0, 86, 86, 86, 0, 0, 0, 86, 0, 0, 0, 0, 0, 0, 0, 15, - 15, 15, 15, 0, 15, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, - 9, 86, 86, 15, 15, 15, 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 86, 86, - 116, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 0, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 15, 15, 15, - 15, 15, 0, 0, 86, 15, 116, 116, 116, 86, 86, 86, 86, 86, 0, 86, 86, - 116, 0, 116, 116, 86, 0, 0, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 15, 15, 86, 86, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 4, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 15, 15, 15, 15, - 15, 0, 0, 86, 15, 116, 86, 116, 86, 86, 86, 86, 0, 0, 116, 116, 0, - 0, 116, 116, 86, 0, 0, 0, 0, 0, 0, 0, 0, 86, 116, 0, 0, 0, 0, 15, 15, - 0, 15, 15, 15, 86, 86, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 14, 15, - 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 86, 15, 0, 15, - 15, 15, 15, 15, 15, 0, 0, 0, 15, 15, 15, 0, 15, 15, 15, 15, 0, 0, 0, - 15, 15, 0, 15, 0, 15, 15, 0, 0, 0, 15, 15, 0, 0, 0, 15, 15, 15, 0, - 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 116, - 116, 86, 116, 116, 0, 0, 0, 116, 116, 116, 0, 116, 116, 116, 86, 0, - 0, 15, 0, 0, 0, 0, 0, 0, 116, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, 18, 18, 14, 14, 14, 14, 14, 14, - 4, 14, 0, 0, 0, 0, 0, 0, 116, 116, 116, 0, 15, 15, 15, 15, 15, 15, - 15, 15, 0, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 0, 0, 0, 15, 86, 86, - 86, 116, 116, 116, 116, 0, 86, 86, 86, 0, 86, 86, 86, 86, 0, 0, 0, - 0, 0, 0, 0, 86, 86, 0, 15, 15, 0, 0, 0, 0, 0, 0, 15, 15, 86, 86, 0, - 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, - 18, 18, 18, 18, 14, 0, 0, 116, 116, 0, 15, 15, 15, 15, 15, 15, 15, - 15, 0, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 0, 0, 86, 15, 116, 86, 116, - 116, 116, 116, 116, 0, 86, 116, 116, 0, 116, 116, 86, 86, 0, 0, 0, - 0, 0, 0, 0, 116, 116, 0, 0, 0, 0, 0, 0, 0, 15, 0, 15, 15, 86, 86, 0, + 0, 0, 0, 15, 15, 15, 15, 0, 0, 92, 15, 124, 124, 124, 92, 92, 92, 92, + 0, 0, 124, 124, 0, 0, 124, 124, 92, 15, 0, 0, 0, 0, 0, 0, 0, 0, 124, + 0, 0, 0, 0, 15, 15, 0, 15, 15, 15, 92, 92, 0, 0, 9, 9, 9, 9, 9, 9, + 9, 9, 9, 9, 15, 15, 4, 4, 18, 18, 18, 18, 18, 18, 14, 4, 15, 3, 92, + 0, 0, 92, 92, 124, 0, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 15, 15, 0, + 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, + 15, 15, 0, 15, 15, 0, 0, 92, 0, 124, 124, 124, 92, 92, 0, 0, 0, 0, + 92, 92, 0, 0, 92, 92, 92, 0, 0, 0, 92, 0, 0, 0, 0, 0, 0, 0, 15, 15, + 15, 15, 0, 15, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 92, + 92, 15, 15, 15, 92, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 92, 92, 124, 0, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 0, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 15, 15, 15, 15, 15, + 0, 0, 92, 15, 124, 124, 124, 92, 92, 92, 92, 92, 0, 92, 92, 124, 0, + 124, 124, 92, 0, 0, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 15, 15, 92, 92, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 4, 0, 0, 0, + 0, 0, 0, 0, 15, 92, 92, 92, 92, 92, 92, 0, 92, 124, 124, 0, 15, 15, + 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, + 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 15, 15, 15, 15, 15, 0, 0, + 92, 15, 124, 92, 124, 92, 92, 92, 92, 0, 0, 124, 124, 0, 0, 124, 124, + 92, 0, 0, 0, 0, 0, 0, 0, 0, 92, 124, 0, 0, 0, 0, 15, 15, 0, 15, 15, + 15, 92, 92, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 14, 15, 18, 18, 18, + 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 92, 15, 0, 15, 15, 15, 15, + 15, 15, 0, 0, 0, 15, 15, 15, 0, 15, 15, 15, 15, 0, 0, 0, 15, 15, 0, + 15, 0, 15, 15, 0, 0, 0, 15, 15, 0, 0, 0, 15, 15, 15, 0, 0, 0, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 124, 124, 92, 124, + 124, 0, 0, 0, 124, 124, 124, 0, 124, 124, 124, 92, 0, 0, 15, 0, 0, + 0, 0, 0, 0, 124, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, + 9, 9, 9, 9, 9, 9, 9, 18, 18, 18, 14, 14, 14, 14, 14, 14, 4, 14, 0, + 0, 0, 0, 0, 92, 124, 124, 124, 92, 15, 15, 15, 15, 15, 15, 15, 15, + 0, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 15, 92, 92, 92, 124, + 124, 124, 124, 0, 92, 92, 92, 0, 92, 92, 92, 92, 0, 0, 0, 0, 0, 0, + 0, 92, 92, 0, 15, 15, 15, 0, 0, 0, 0, 0, 15, 15, 92, 92, 0, 0, 9, 9, + 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, + 18, 18, 14, 15, 92, 124, 124, 3, 15, 15, 15, 15, 15, 15, 15, 15, 0, + 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 0, 0, 92, 15, 124, 92, 124, + 124, 124, 124, 124, 0, 92, 124, 124, 0, 124, 124, 92, 92, 0, 0, 0, + 0, 0, 0, 0, 124, 124, 0, 0, 0, 0, 0, 0, 0, 15, 0, 15, 15, 92, 92, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 15, 15, 0, 0, 0, 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, 0, 0, 15, 116, - 116, 116, 86, 86, 86, 86, 0, 116, 116, 116, 0, 116, 116, 116, 86, 15, - 0, 0, 0, 0, 0, 0, 0, 0, 116, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 86, 86, - 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, 18, 18, 18, 18, 18, 0, 0, 0, - 14, 15, 15, 15, 15, 15, 15, 0, 0, 116, 116, 0, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 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, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 0, - 0, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 86, 0, 0, 0, 0, 116, 116, 116, - 86, 86, 86, 0, 86, 0, 116, 116, 116, 116, 116, 116, 116, 116, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 116, 116, 3, 0, 0, - 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, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 86, 15, 15, 86, 86, 86, 86, 86, 86, 86, 0, 0, 0, 0, - 4, 15, 15, 15, 15, 15, 15, 85, 86, 86, 86, 86, 86, 86, 86, 86, 3, 9, - 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 0, 0, 0, 0, 0, 15, 15, 0, 15, 0, 0, - 15, 15, 0, 15, 0, 0, 15, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 0, 15, 15, - 15, 15, 15, 15, 15, 0, 15, 15, 15, 0, 15, 0, 15, 0, 0, 15, 15, 0, 15, - 15, 15, 15, 86, 15, 15, 86, 86, 86, 86, 86, 86, 0, 86, 86, 15, 0, 0, - 15, 15, 15, 15, 15, 0, 85, 0, 86, 86, 86, 86, 86, 86, 0, 0, 9, 9, 9, - 9, 9, 9, 9, 9, 9, 9, 0, 0, 15, 15, 15, 15, 15, 14, 14, 14, 3, 3, 3, - 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 14, 3, 14, 14, 14, 86, 86, 14, - 14, 14, 14, 14, 14, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 14, 86, 14, 86, 14, 86, 5, 6, 5, 6, 116, 116, 15, - 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 0, 0, 0, 0, 0, 92, 92, 124, 124, 0, 15, 15, 15, 15, 15, 15, 15, 15, + 0, 15, 15, 15, 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, 15, 15, 92, 92, 15, 124, 124, 124, + 92, 92, 92, 92, 0, 124, 124, 124, 0, 124, 124, 124, 92, 15, 14, 0, + 0, 0, 0, 15, 15, 15, 124, 18, 18, 18, 18, 18, 18, 18, 15, 15, 15, 92, + 92, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 14, 15, 15, 15, 15, 15, 15, 0, 0, 124, 124, 0, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 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, 0, 0, 0, 0, 86, 86, 86, 86, - 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 116, 86, 86, 86, 86, 86, 3, - 86, 86, 15, 15, 15, 15, 15, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, - 86, 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, 0, 14, 14, 14, 14, 14, 14, 14, 14, 86, 14, 14, 14, - 14, 14, 14, 0, 14, 14, 3, 3, 3, 3, 3, 14, 14, 14, 14, 3, 3, 0, 0, 0, - 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 116, 116, 86, 86, - 86, 86, 116, 86, 86, 86, 86, 86, 86, 116, 86, 86, 116, 116, 86, 86, - 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 3, 3, 3, 3, 15, 15, 15, 15, - 15, 15, 116, 116, 86, 86, 15, 15, 15, 15, 86, 86, 86, 15, 116, 116, - 116, 15, 15, 116, 116, 116, 116, 116, 116, 116, 15, 15, 15, 86, 86, - 86, 86, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 116, - 116, 86, 86, 116, 116, 116, 116, 116, 116, 86, 15, 116, 9, 9, 9, 9, - 9, 9, 9, 9, 9, 9, 116, 116, 116, 86, 14, 14, 117, 117, 117, 117, 117, - 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, - 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, - 117, 117, 117, 117, 117, 0, 117, 0, 0, 0, 0, 0, 117, 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, 15, 15, 15, 15, 3, 85, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 0, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, - 0, 15, 0, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 0, 15, 15, 15, 15, 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, 0, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, - 15, 0, 15, 0, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 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, 0, - 15, 15, 15, 15, 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, 0, 0, 86, 86, 86, 3, 3, 3, 3, 3, 3, 3, 3, 3, - 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 18, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 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, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 8, 15, 15, 15, + 0, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 92, 0, 0, 0, 0, 124, + 124, 124, 92, 92, 92, 0, 92, 0, 124, 124, 124, 124, 124, 124, 124, + 124, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 124, 124, + 3, 0, 0, 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, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 92, 15, 15, 92, 92, 92, 92, 92, 92, 92, + 0, 0, 0, 0, 4, 15, 15, 15, 15, 15, 15, 91, 92, 92, 92, 92, 92, 92, + 92, 92, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 0, 0, 0, 0, 0, 15, 15, + 0, 15, 0, 0, 15, 15, 0, 15, 0, 0, 15, 0, 0, 0, 0, 0, 0, 15, 15, 15, + 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 0, 15, 0, 15, 0, + 0, 15, 15, 0, 15, 15, 15, 15, 92, 15, 15, 92, 92, 92, 92, 92, 92, 0, + 92, 92, 15, 0, 0, 15, 15, 15, 15, 15, 0, 91, 0, 92, 92, 92, 92, 92, + 92, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 15, 15, 15, 15, 15, 14, + 14, 14, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 14, 3, 14, 14, + 14, 92, 92, 14, 14, 14, 14, 14, 14, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 14, 92, 14, 92, 14, 92, 5, 6, 5, + 6, 124, 124, 15, 15, 15, 15, 15, 15, 15, 15, 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, 0, 0, 0, 0, + 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 124, 92, 92, + 92, 92, 92, 3, 92, 92, 15, 15, 15, 15, 15, 92, 92, 92, 92, 92, 92, + 92, 92, 92, 92, 92, 0, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 92, 92, 92, 92, 92, 92, 92, 0, 14, 14, 14, 14, 14, 14, 14, 14, + 92, 14, 14, 14, 14, 14, 14, 0, 14, 14, 3, 3, 3, 3, 3, 14, 14, 14, 14, + 3, 3, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 124, + 124, 92, 92, 92, 92, 124, 92, 92, 92, 92, 92, 92, 124, 92, 92, 124, + 124, 92, 92, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 3, 3, 3, 3, 15, + 15, 15, 15, 15, 15, 124, 124, 92, 92, 15, 15, 15, 15, 92, 92, 92, 15, + 124, 124, 124, 15, 15, 124, 124, 124, 124, 124, 124, 124, 15, 15, 15, + 92, 92, 92, 92, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 92, 124, 124, 92, 92, 124, 124, 124, 124, 124, 124, 92, 15, 124, 9, + 9, 9, 9, 9, 9, 9, 9, 9, 9, 124, 124, 124, 92, 14, 14, 125, 125, 125, + 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, + 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, + 125, 125, 125, 125, 125, 125, 125, 0, 125, 0, 0, 0, 0, 0, 125, 0, 0, + 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, + 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, + 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, + 126, 3, 91, 126, 126, 126, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, + 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 0, 15, 15, 15, + 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 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, 15, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 2, 15, 15, 15, 15, 15, 15, 15, 15, + 0, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 0, 15, + 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 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, 0, 15, 15, 15, 15, 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, 0, 0, 92, 92, 92, 3, 3, 3, 3, 3, 3, 3, 3, 3, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 127, 127, 127, + 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, + 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, + 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, 127, + 127, 127, 127, 104, 104, 104, 104, 104, 104, 0, 0, 110, 110, 110, 110, + 110, 110, 0, 0, 8, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 3, 3, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 2, + 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, 5, 6, 0, 0, 0, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 3, 3, 3, 128, 128, 128, 15, 15, 15, 15, + 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 92, 92, 92, 0, 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, 92, 92, 92, 3, 3, 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, 5, 6, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 3, 3, - 3, 118, 118, 118, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, - 86, 86, 86, 0, 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, 86, 86, 86, 3, 3, 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, 86, 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, - 0, 86, 86, 0, 0, 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, 86, 86, - 116, 86, 86, 86, 86, 86, 86, 86, 116, 116, 116, 116, 116, 116, 116, - 116, 86, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 3, 3, - 3, 85, 3, 3, 3, 4, 15, 86, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, - 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, - 0, 3, 3, 3, 3, 3, 3, 8, 3, 3, 3, 3, 86, 86, 86, 2, 0, 9, 9, 9, 9, 9, - 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 15, 15, 15, 85, 15, 15, 15, 15, 15, + 92, 92, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 0, 92, 92, 0, 0, 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, 92, 92, 124, 92, 92, 92, 92, 92, 92, + 92, 124, 124, 124, 124, 124, 124, 124, 124, 92, 124, 124, 92, 92, 92, + 92, 92, 92, 92, 92, 92, 92, 92, 3, 3, 3, 91, 3, 3, 3, 4, 15, 92, 0, + 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 8, 3, 3, + 3, 3, 92, 92, 92, 17, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, + 0, 0, 15, 15, 15, 91, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, - 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 15, 0, 0, 0, 0, 0, + 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, + 92, 92, 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, 92, 15, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 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, 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, 0, + 92, 92, 92, 124, 124, 124, 124, 92, 92, 124, 124, 124, 0, 0, 0, 0, + 124, 124, 92, 124, 124, 124, 124, 124, 124, 92, 92, 92, 0, 0, 0, 0, + 14, 0, 0, 0, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 0, 0, 0, 86, 86, 86, 116, 116, 116, 116, 86, - 86, 116, 116, 116, 0, 0, 0, 0, 116, 116, 86, 116, 116, 116, 116, 116, - 116, 86, 86, 86, 0, 0, 0, 0, 14, 0, 0, 0, 3, 3, 9, 9, 9, 9, 9, 9, 9, - 9, 9, 9, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, - 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 116, 116, 116, 116, 116, 116, - 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 15, 15, 15, - 15, 15, 15, 15, 116, 116, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, - 9, 9, 18, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, + 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 86, 116, 116, 116, - 0, 0, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 116, 86, 116, 86, 86, 86, 86, 86, 86, 86, - 0, 86, 116, 86, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 116, 116, - 116, 116, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 0, 0, 86, - 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, - 9, 9, 9, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 85, 3, 3, 3, 3, 3, - 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 86, 86, 86, - 86, 116, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 116, - 86, 86, 86, 86, 86, 116, 86, 116, 116, 116, 116, 116, 86, 116, 116, - 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, - 9, 3, 3, 3, 3, 3, 3, 3, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 86, - 86, 86, 86, 86, 86, 86, 86, 86, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 0, 0, 0, 86, 86, 116, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 116, 86, 86, 86, 86, 116, 116, 86, 86, 116, 86, 116, 116, 15, 15, - 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 86, 116, 86, 86, 116, 116, 116, 86, 116, 86, 86, 86, 116, 116, - 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 15, 15, 15, 15, 116, 116, 116, - 116, 116, 116, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 116, 116, - 86, 86, 0, 0, 0, 3, 3, 3, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, - 0, 15, 15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 85, 85, 85, 85, 85, 85, 3, 3, 3, 3, 3, - 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 86, 86, 86, 3, 86, 86, 86, 86, - 86, 86, 86, 86, 86, 86, 86, 86, 86, 116, 86, 86, 86, 86, 86, 86, 86, - 15, 15, 15, 15, 86, 15, 15, 15, 15, 116, 116, 86, 15, 15, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 92, 92, 124, 124, 92, 0, 0, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 124, 92, 124, 92, 92, + 92, 92, 92, 92, 92, 0, 92, 124, 92, 124, 124, 92, 92, 92, 92, 92, 92, + 92, 92, 124, 124, 124, 124, 124, 124, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 92, 0, 0, 92, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 9, + 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 91, + 3, 3, 3, 3, 3, 3, 0, 0, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 92, 92, 119, 0, 92, 92, 92, 92, 124, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 92, 124, 92, 92, 92, 92, 92, 124, 92, 124, + 124, 124, 124, 124, 92, 124, 124, 15, 15, 15, 15, 15, 15, 15, 0, 0, + 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 3, 3, 3, 3, 3, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 92, 92, 92, 92, 92, 92, 92, 92, 92, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 92, 92, 124, 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, 124, 92, 92, 92, 92, 124, 124, + 92, 92, 124, 92, 92, 92, 15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 92, 124, 92, 92, 124, 124, + 124, 92, 124, 92, 92, 92, 124, 124, 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, + 3, 15, 15, 15, 15, 124, 124, 124, 124, 124, 124, 124, 124, 92, 92, + 92, 92, 92, 92, 92, 92, 124, 124, 92, 92, 0, 0, 0, 3, 3, 3, 3, 3, 9, + 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 15, 15, 15, 9, 9, 9, 9, 9, 9, 9, + 9, 9, 9, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 91, 91, + 91, 91, 91, 91, 3, 3, 129, 130, 131, 132, 132, 133, 134, 135, 136, + 0, 0, 0, 0, 0, 0, 0, 137, 137, 137, 137, 137, 137, 137, 137, 137, 137, + 137, 137, 137, 137, 137, 137, 137, 137, 137, 137, 137, 137, 137, 137, + 137, 137, 137, 137, 137, 137, 137, 137, 137, 137, 137, 137, 137, 137, + 137, 137, 137, 137, 137, 0, 0, 137, 137, 137, 3, 3, 3, 3, 3, 3, 3, + 3, 0, 0, 0, 0, 0, 0, 0, 0, 92, 92, 92, 3, 92, 92, 92, 92, 92, 92, 92, + 92, 92, 92, 92, 92, 92, 124, 92, 92, 92, 92, 92, 92, 92, 15, 15, 15, + 15, 92, 15, 15, 15, 15, 124, 124, 92, 15, 15, 124, 92, 92, 0, 0, 0, + 0, 0, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 85, 85, 85, - 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, - 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, - 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, - 85, 85, 85, 85, 85, 85, 85, 85, 85, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 85, 119, 21, 21, 21, 120, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 91, 91, 91, 91, 91, + 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, + 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, + 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, + 91, 91, 91, 91, 91, 91, 91, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 91, 138, 21, 21, 21, 139, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 85, 85, 85, 85, 85, 86, 86, 86, 86, 86, 86, - 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 86, 86, 86, 86, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, - 24, 23, 24, 23, 24, 23, 24, 23, 24, 21, 21, 21, 21, 21, 121, 21, 21, - 122, 21, 123, 123, 123, 123, 123, 123, 123, 123, 124, 124, 124, 124, - 124, 124, 124, 124, 123, 123, 123, 123, 123, 123, 0, 0, 124, 124, 124, - 124, 124, 124, 0, 0, 123, 123, 123, 123, 123, 123, 123, 123, 124, 124, - 124, 124, 124, 124, 124, 124, 123, 123, 123, 123, 123, 123, 123, 123, - 124, 124, 124, 124, 124, 124, 124, 124, 123, 123, 123, 123, 123, 123, - 0, 0, 124, 124, 124, 124, 124, 124, 0, 0, 21, 123, 21, 123, 21, 123, - 21, 123, 0, 124, 0, 124, 0, 124, 0, 124, 123, 123, 123, 123, 123, 123, - 123, 123, 124, 124, 124, 124, 124, 124, 124, 124, 125, 125, 126, 126, - 126, 126, 127, 127, 128, 128, 129, 129, 130, 130, 0, 0, 123, 123, 123, - 123, 123, 123, 123, 123, 131, 131, 131, 131, 131, 131, 131, 131, 123, - 123, 123, 123, 123, 123, 123, 123, 131, 131, 131, 131, 131, 131, 131, - 131, 123, 123, 123, 123, 123, 123, 123, 123, 131, 131, 131, 131, 131, - 131, 131, 131, 123, 123, 21, 132, 21, 0, 21, 21, 124, 124, 133, 133, - 134, 11, 135, 11, 11, 11, 21, 132, 21, 0, 21, 21, 136, 136, 136, 136, - 134, 11, 11, 11, 123, 123, 21, 21, 0, 0, 21, 21, 124, 124, 137, 137, - 0, 11, 11, 11, 123, 123, 21, 21, 21, 106, 21, 21, 124, 124, 138, 138, - 109, 11, 11, 11, 0, 0, 21, 132, 21, 0, 21, 21, 139, 139, 140, 140, - 134, 11, 11, 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 17, 17, 17, 17, 17, - 8, 8, 8, 8, 8, 8, 3, 3, 16, 20, 5, 16, 16, 20, 5, 16, 3, 3, 3, 3, 3, - 3, 3, 3, 141, 142, 17, 17, 17, 17, 17, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, - 16, 20, 3, 3, 3, 3, 12, 12, 3, 3, 3, 7, 5, 6, 3, 3, 3, 3, 3, 3, 3, - 3, 3, 3, 3, 7, 3, 12, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 2, 17, 17, 17, - 17, 17, 0, 0, 0, 0, 0, 17, 17, 17, 17, 17, 17, 18, 85, 0, 0, 18, 18, - 18, 18, 18, 18, 7, 7, 7, 5, 6, 85, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 7, 7, 7, 5, 6, 0, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, - 85, 85, 0, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, - 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, - 86, 86, 111, 111, 111, 111, 86, 111, 111, 111, 86, 86, 86, 86, 86, - 86, 86, 86, 86, 86, 86, 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 14, 14, 100, 14, 14, 14, 14, 100, 14, 14, 21, 100, 100, 100, - 21, 21, 100, 100, 100, 21, 14, 100, 14, 14, 7, 100, 100, 100, 100, - 100, 14, 14, 14, 14, 14, 14, 100, 14, 143, 14, 100, 14, 144, 145, 100, - 100, 14, 21, 100, 100, 146, 100, 21, 15, 15, 15, 15, 21, 14, 14, 21, - 21, 100, 100, 7, 7, 7, 7, 7, 100, 21, 21, 21, 21, 14, 7, 14, 14, 147, - 14, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, - 148, 148, 149, 149, 149, 149, 149, 149, 149, 149, 149, 149, 149, 149, - 149, 149, 149, 149, 118, 118, 118, 23, 24, 118, 118, 118, 118, 18, - 0, 0, 0, 0, 0, 0, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 7, 7, 14, 14, - 14, 14, 7, 14, 14, 7, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 7, 14, + 21, 21, 21, 21, 91, 91, 91, 91, 91, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 0, 92, 92, 92, 92, 92, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, + 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 21, 21, 21, 21, 21, + 140, 21, 21, 141, 21, 142, 142, 142, 142, 142, 142, 142, 142, 143, + 143, 143, 143, 143, 143, 143, 143, 142, 142, 142, 142, 142, 142, 0, + 0, 143, 143, 143, 143, 143, 143, 0, 0, 142, 142, 142, 142, 142, 142, + 142, 142, 143, 143, 143, 143, 143, 143, 143, 143, 142, 142, 142, 142, + 142, 142, 142, 142, 143, 143, 143, 143, 143, 143, 143, 143, 142, 142, + 142, 142, 142, 142, 0, 0, 143, 143, 143, 143, 143, 143, 0, 0, 21, 142, + 21, 142, 21, 142, 21, 142, 0, 143, 0, 143, 0, 143, 0, 143, 142, 142, + 142, 142, 142, 142, 142, 142, 143, 143, 143, 143, 143, 143, 143, 143, + 144, 144, 145, 145, 145, 145, 146, 146, 147, 147, 148, 148, 149, 149, + 0, 0, 142, 142, 142, 142, 142, 142, 142, 142, 150, 150, 150, 150, 150, + 150, 150, 150, 142, 142, 142, 142, 142, 142, 142, 142, 150, 150, 150, + 150, 150, 150, 150, 150, 142, 142, 142, 142, 142, 142, 142, 142, 150, + 150, 150, 150, 150, 150, 150, 150, 142, 142, 21, 151, 21, 0, 21, 21, + 143, 143, 152, 152, 153, 11, 154, 11, 11, 11, 21, 151, 21, 0, 21, 21, + 155, 155, 155, 155, 153, 11, 11, 11, 142, 142, 21, 21, 0, 0, 21, 21, + 143, 143, 156, 156, 0, 11, 11, 11, 142, 142, 21, 21, 21, 113, 21, 21, + 143, 143, 157, 157, 117, 11, 11, 11, 0, 0, 21, 151, 21, 0, 21, 21, + 158, 158, 159, 159, 153, 11, 11, 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 17, 17, 17, 17, 17, 8, 8, 8, 8, 8, 8, 3, 3, 16, 20, 5, 16, 16, 20, + 5, 16, 3, 3, 3, 3, 3, 3, 3, 3, 160, 161, 17, 17, 17, 17, 17, 2, 3, + 3, 3, 3, 3, 3, 3, 3, 3, 16, 20, 3, 3, 3, 3, 12, 12, 3, 3, 3, 7, 5, + 6, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 7, 3, 12, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 3, 2, 17, 17, 17, 17, 17, 0, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 18, 91, 0, 0, 18, 18, 18, 18, 18, 18, 7, 7, 7, 5, 6, 91, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 7, 7, 7, 5, 6, 0, 91, 91, 91, 91, + 91, 91, 91, 91, 91, 91, 91, 91, 91, 0, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, + 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, + 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 92, 92, 92, 92, + 92, 92, 92, 92, 92, 92, 92, 92, 92, 119, 119, 119, 119, 92, 119, 119, + 119, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 107, 14, 14, 14, 14, 107, 14, + 14, 21, 107, 107, 107, 21, 21, 107, 107, 107, 21, 14, 107, 14, 14, + 7, 107, 107, 107, 107, 107, 14, 14, 14, 14, 14, 14, 107, 14, 162, 14, + 107, 14, 163, 164, 107, 107, 14, 21, 107, 107, 165, 107, 21, 15, 15, + 15, 15, 21, 14, 14, 21, 21, 107, 107, 7, 7, 7, 7, 7, 107, 21, 21, 21, + 21, 14, 7, 14, 14, 166, 14, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 167, 167, 167, 167, 167, 167, 167, 167, 167, + 167, 167, 167, 167, 167, 167, 167, 168, 168, 168, 168, 168, 168, 168, + 168, 168, 168, 168, 168, 168, 168, 168, 168, 128, 128, 128, 23, 24, + 128, 128, 128, 128, 18, 14, 14, 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, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 14, 14, 7, - 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, + 14, 14, 14, 7, 7, 14, 14, 7, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, - 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 14, 14, - 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 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, + 7, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 14, 14, 14, 5, 6, 5, 6, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 7, 7, 14, 14, 14, 14, 14, 14, 14, 5, 6, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, - 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 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, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 7, 7, 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, 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, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 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, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 14, 14, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 150, 150, 150, 150, 150, 150, 150, 150, - 150, 150, 150, 150, 150, 150, 150, 150, 150, 150, 150, 150, 150, 150, - 150, 150, 150, 150, 151, 151, 151, 151, 151, 151, 151, 151, 151, 151, - 151, 151, 151, 151, 151, 151, 151, 151, 151, 151, 151, 151, 151, 151, - 151, 151, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 18, 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, 14, 14, - 14, 14, 14, 14, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, + 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 170, 170, + 170, 170, 170, 170, 170, 170, 170, 170, 170, 170, 170, 170, 170, 170, + 170, 170, 170, 170, 170, 170, 170, 170, 170, 170, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 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, 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, 7, 7, 7, 7, 7, 7, 7, 7, 14, - 14, 14, 14, 14, 14, 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, 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, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 18, 18, 18, 18, + 14, 14, 7, 7, 7, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 14, 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, 5, 6, 5, 6, + 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 18, 18, 18, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 7, 7, 7, 7, 7, 5, 6, 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, 5, 6, - 5, 6, 5, 6, 5, 6, 5, 6, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, - 7, 7, 7, 7, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, - 6, 5, 6, 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, 5, 6, 5, 6, 7, 7, 7, 7, 7, 7, 7, 7, + 18, 18, 18, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 7, + 7, 7, 5, 6, 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, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 5, 6, 5, 6, 5, + 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 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, 5, 6, 7, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, - 7, 7, 14, 14, 7, 7, 7, 7, 7, 7, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 0, 0, 0, 0, 0, 0, 114, 114, 114, 114, 114, 114, 114, 114, - 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, - 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, - 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 114, 0, 115, 115, - 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, - 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, - 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, 115, - 115, 115, 115, 0, 23, 24, 152, 153, 154, 155, 156, 23, 24, 23, 24, - 23, 24, 157, 158, 159, 160, 21, 23, 24, 21, 23, 24, 21, 21, 21, 21, - 21, 85, 85, 161, 161, 23, 24, 23, 24, 21, 14, 14, 14, 14, 14, 14, 23, - 24, 23, 24, 86, 86, 86, 23, 24, 0, 0, 0, 0, 0, 3, 3, 3, 3, 18, 3, 3, - 162, 162, 162, 162, 162, 162, 162, 162, 162, 162, 162, 162, 162, 162, - 162, 162, 162, 162, 162, 162, 162, 162, 162, 162, 162, 162, 162, 162, - 162, 162, 162, 162, 162, 162, 162, 162, 162, 162, 0, 162, 0, 0, 0, - 0, 0, 162, 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, 0, 0, 0, 0, 0, 0, 0, 85, - 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 86, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, - 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, - 15, 15, 15, 0, 3, 3, 16, 20, 16, 20, 3, 3, 3, 16, 20, 3, 16, 20, 3, - 3, 3, 3, 3, 3, 3, 3, 3, 8, 3, 3, 8, 3, 16, 20, 3, 3, 16, 20, 5, 6, - 5, 6, 5, 6, 5, 6, 3, 3, 3, 3, 3, 85, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, - 8, 8, 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, 0, 14, 14, 14, + 7, 7, 5, 6, 5, 6, 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, 5, 6, 7, 7, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 14, 14, 7, 7, 7, 7, + 7, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 0, 0, 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, 0, - 0, 0, 0, 2, 3, 3, 3, 14, 85, 15, 118, 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, 118, 118, 118, 118, - 118, 118, 118, 118, 118, 86, 86, 86, 86, 116, 116, 8, 85, 85, 85, 85, - 85, 14, 14, 118, 118, 118, 85, 15, 3, 14, 14, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 0, 0, 86, 86, 11, 11, 85, 85, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 14, 14, 14, 14, 14, 0, 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, 14, 14, 14, 14, + 14, 14, 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, 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, 122, 122, + 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 0, + 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, + 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, + 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, + 123, 123, 123, 123, 123, 0, 23, 24, 171, 172, 173, 174, 175, 23, 24, + 23, 24, 23, 24, 176, 177, 178, 179, 21, 23, 24, 21, 23, 24, 21, 21, + 21, 21, 21, 91, 91, 180, 180, 23, 24, 23, 24, 21, 14, 14, 14, 14, 14, + 14, 23, 24, 23, 24, 92, 92, 92, 23, 24, 0, 0, 0, 0, 0, 3, 3, 3, 3, + 18, 3, 3, 181, 181, 181, 181, 181, 181, 181, 181, 181, 181, 181, 181, + 181, 181, 181, 181, 181, 181, 181, 181, 181, 181, 181, 181, 181, 181, + 181, 181, 181, 181, 181, 181, 181, 181, 181, 181, 181, 181, 0, 181, + 0, 0, 0, 0, 0, 181, 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, 0, 0, 0, 0, 0, + 0, 0, 91, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 92, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, + 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, + 15, 15, 15, 15, 15, 15, 15, 0, 3, 3, 16, 20, 16, 20, 3, 3, 3, 16, 20, + 3, 16, 20, 3, 3, 3, 3, 3, 3, 3, 3, 3, 8, 3, 3, 8, 3, 16, 20, 3, 3, + 16, 20, 5, 6, 5, 6, 5, 6, 5, 6, 3, 3, 3, 3, 3, 91, 3, 3, 3, 3, 3, 3, + 3, 3, 3, 3, 8, 8, 3, 3, 3, 3, 8, 3, 5, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 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, 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, 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, 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, 91, + 15, 128, 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, 128, 128, 128, 128, 128, 128, 128, 128, 128, 92, + 92, 92, 92, 124, 124, 8, 91, 91, 91, 91, 91, 14, 14, 128, 128, 128, + 91, 15, 3, 14, 14, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 92, 92, 11, 11, 91, + 91, 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, 3, 91, 91, 91, 15, + 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 3, 85, 85, 85, 15, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 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, 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, 0, 14, 14, - 18, 18, 18, 18, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 14, 14, 18, 18, 18, 18, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 14, 14, 14, 14, 0, 0, 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, 14, 14, 14, 14, 14, 14, 14, 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, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 18, 18, 18, 18, 18, 18, 18, - 18, 14, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 15, 15, 15, 0, 0, 0, 0, 0, 14, 14, 14, 14, 0, 0, 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, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 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, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 85, 15, 15, 15, 15, + 14, 14, 14, 14, 14, 14, 14, 14, 18, 18, 18, 18, 18, 18, 18, 18, 14, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 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, 91, 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, 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, + 15, 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, 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, 85, 3, 3, 3, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 9, 9, 9, 9, 9, - 9, 9, 9, 9, 9, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, - 24, 15, 86, 111, 111, 111, 3, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, - 3, 85, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, - 24, 23, 24, 23, 24, 23, 24, 23, 24, 0, 0, 0, 0, 0, 0, 0, 86, 15, 15, - 15, 15, 15, 15, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 86, - 86, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 11, 11, 11, 11, 11, 11, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 91, 3, 3, 3, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 9, 9, 9, 9, 9, 9, 9, + 9, 9, 9, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 15, + 92, 119, 119, 119, 3, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 3, 91, + 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, + 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 91, 91, 92, 92, 15, 15, + 15, 15, 15, 15, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 92, + 92, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, - 85, 85, 85, 85, 85, 85, 85, 85, 85, 11, 11, 23, 24, 23, 24, 23, 24, + 91, 91, 91, 91, 91, 91, 91, 91, 91, 11, 11, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 21, 21, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, - 23, 24, 23, 24, 23, 24, 85, 21, 21, 21, 21, 21, 21, 21, 21, 23, 24, - 23, 24, 163, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 85, 11, 11, 23, - 24, 164, 21, 0, 23, 24, 23, 24, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 165, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 85, 85, 21, 15, 15, 15, 15, - 15, 15, 15, 86, 15, 15, 15, 86, 15, 15, 15, 15, 86, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 116, 116, 86, 86, 116, 14, 14, 14, 14, 0, 0, 0, 0, 18, 18, - 18, 18, 18, 18, 14, 14, 4, 14, 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, 3, 3, 3, - 3, 0, 0, 0, 0, 0, 0, 0, 0, 116, 116, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 116, 116, 116, 116, 116, 116, 116, - 116, 116, 116, 116, 116, 116, 116, 116, 116, 86, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 86, - 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, - 15, 15, 15, 15, 15, 15, 3, 3, 3, 15, 0, 0, 0, 0, 15, 15, 15, 15, 15, - 15, 86, 86, 86, 86, 86, 86, 86, 86, 3, 3, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, - 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 116, 116, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 86, 116, 116, 86, 86, 86, 86, 116, 116, 86, - 116, 116, 116, 116, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 0, 85, 9, - 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 3, 3, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 86, 86, 86, 86, 86, 86, 116, 116, 86, 86, 116, 116, 86, - 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 86, 15, 15, 15, 15, 15, - 15, 15, 15, 86, 116, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 3, 3, - 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 85, 15, 15, 15, 15, 15, 15, 14, 14, 14, 15, 116, 0, 0, 0, 0, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 15, 86, - 86, 86, 15, 15, 86, 86, 15, 15, 15, 15, 15, 86, 86, 15, 86, 15, 0, + 23, 24, 23, 24, 23, 24, 91, 21, 21, 21, 21, 21, 21, 21, 21, 23, 24, + 23, 24, 182, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 91, 11, 11, 23, + 24, 183, 21, 15, 23, 24, 23, 24, 21, 21, 23, 24, 23, 24, 23, 24, 23, + 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 184, 185, 186, + 187, 184, 21, 188, 189, 190, 191, 23, 24, 23, 24, 23, 24, 0, 0, 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, 85, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 116, - 86, 86, 116, 116, 3, 3, 15, 85, 85, 116, 86, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 15, - 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, - 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 116, 116, 86, 116, 116, 86, 116, 116, - 3, 116, 86, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 15, - 15, 15, 15, 0, 0, 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, 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, + 0, 0, 0, 15, 91, 91, 21, 15, 15, 15, 15, 15, 15, 15, 92, 15, 15, 15, + 92, 15, 15, 15, 15, 92, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 124, 124, 92, 92, 124, + 14, 14, 14, 14, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 14, 14, 4, 14, + 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, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 124, + 124, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, + 124, 124, 92, 92, 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, 9, 9, 9, 9, 9, 9, 9, + 9, 9, 9, 0, 0, 0, 0, 0, 0, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 92, 92, 92, 92, 92, 92, 92, 15, 15, 15, 15, 15, 15, 3, 3, 3, 15, + 3, 15, 15, 92, 15, 15, 15, 15, 15, 15, 92, 92, 92, 92, 92, 92, 92, + 92, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 92, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 92, 124, 124, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 92, 124, 124, 92, 92, + 92, 92, 124, 124, 92, 124, 124, 124, 124, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 3, 3, 0, 91, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 3, 3, + 15, 15, 15, 15, 15, 92, 91, 15, 15, 15, 15, 15, 15, 15, 15, 15, 9, + 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 92, 92, 92, 92, 92, 92, 124, 124, 92, 92, 124, 124, + 92, 92, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 92, 15, 15, 15, 15, + 15, 15, 15, 15, 92, 124, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, + 3, 3, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 91, 15, 15, 15, 15, 15, 15, 14, 14, 14, 15, 124, 92, 124, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 92, 15, 92, 92, 92, 15, 15, 92, 92, 15, 15, 15, 15, 15, 92, 92, 15, + 92, 15, 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, 91, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 124, 92, 92, 124, 124, 3, 3, 15, 91, 91, 124, 92, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, + 0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, + 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 192, 21, 21, 21, + 21, 21, 21, 21, 11, 91, 91, 91, 91, 21, 21, 21, 21, 21, 21, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 193, 193, 193, 193, 193, 193, 193, 193, 193, 193, + 193, 193, 193, 193, 193, 193, 193, 193, 193, 193, 193, 193, 193, 193, + 193, 193, 193, 193, 193, 193, 193, 193, 193, 193, 193, 193, 193, 193, + 193, 193, 193, 193, 193, 193, 193, 193, 193, 193, 15, 15, 15, 124, + 124, 92, 124, 124, 92, 124, 124, 3, 124, 92, 0, 0, 9, 9, 9, 9, 9, 9, + 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 0, 0, 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, 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, 0, 0, 0, 0, 166, 166, 166, 166, 166, 166, 166, 166, 166, 166, - 166, 166, 166, 166, 166, 166, 166, 166, 166, 166, 166, 166, 166, 166, - 166, 166, 166, 166, 166, 166, 166, 166, 167, 167, 167, 167, 167, 167, - 167, 167, 167, 167, 167, 167, 167, 167, 167, 167, 167, 167, 167, 167, - 167, 167, 167, 167, 167, 167, 167, 167, 167, 167, 167, 167, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 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, 0, 0, 0, 0, 194, 194, 194, + 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, + 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, 194, + 194, 195, 195, 195, 195, 195, 195, 195, 195, 195, 195, 195, 195, 195, + 195, 195, 195, 195, 195, 195, 195, 195, 195, 195, 195, 195, 195, 195, + 195, 195, 195, 195, 195, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 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, 0, 0, 0, 0, 0, 0, 21, 21, 21, 21, 21, 21, 21, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 21, 21, 21, 21, 21, 0, 0, 0, 0, 0, 15, - 86, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 7, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 0, 15, 0, 15, - 15, 0, 15, 15, 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, 0, 0, 0, 0, 0, 0, 21, + 21, 21, 21, 21, 21, 21, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 21, 21, + 21, 21, 21, 0, 0, 0, 0, 0, 15, 92, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 7, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, + 15, 15, 15, 15, 0, 15, 0, 15, 15, 0, 15, 15, 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, 11, 11, 11, - 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 0, 0, 0, 0, 0, - 0, 0, 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, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, + 11, 11, 11, 11, 0, 0, 0, 0, 0, 0, 0, 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, 5, 6, 0, 0, 0, 0, 0, 0, 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, 0, 0, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 6, 5, 0, 0, 0, 0, 0, 0, 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, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 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, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 4, 14, 0, 0, 86, 86, 86, 86, 86, - 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 3, 3, 3, 3, 3, 3, 3, 5, - 6, 3, 0, 0, 0, 0, 0, 0, 86, 86, 86, 86, 86, 86, 86, 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, 3, 3, 5, 6, 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, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 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, 15, 15, 15, 15, 15, 15, 15, 15, 15, 4, + 14, 0, 0, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 3, 3, 3, 3, 3, 3, 3, 5, 6, 3, 0, 0, 0, 0, 0, 0, 92, 92, 92, 92, + 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 3, 8, 8, 12, 12, 5, + 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 3, 3, 5, 6, 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, 15, 15, 15, 15, 15, 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, 0, 0, 17, 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, 5, - 6, 3, 5, 6, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 85, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 0, 0, 17, 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, 5, 6, 3, 5, 6, 3, 3, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 91, 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, 85, 85, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 15, 15, 15, 15, 15, 15, 0, - 0, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 15, - 15, 15, 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, 17, 17, 17, 14, 14, 0, 0 + 15, 15, 91, 91, 0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, + 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 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, 17, 17, 17, 14, 14, 0, 0 #if TCL_UTF_MAX > 3 ,15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, @@ -1127,166 +1162,328 @@ static const unsigned char groupMap[] = { 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, - 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, - 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, - 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 118, 18, + 14, 14, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, + 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, + 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, + 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, 18, 18, 18, 18, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 18, 0, 0, 0, 0, 0, 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, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 18, 18, 14, 14, 14, 0, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 0, 0, 0, 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, 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, 14, 14, 14, 14, 14, 14, 14, 14, 86, 0, 0, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 0, 0, 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, 118, 15, 15, 15, 15, 15, 15, 15, 15, 118, 0, 0, 0, - 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, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 3, 15, 15, 15, 15, 0, 0, 0, - 0, 15, 15, 15, 15, 15, 15, 15, 15, 3, 118, 118, 118, 118, 118, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 168, 168, 168, 168, 168, 168, 168, 168, 168, - 168, 168, 168, 168, 168, 168, 168, 168, 168, 168, 168, 168, 168, 168, - 168, 168, 168, 168, 168, 168, 168, 168, 168, 168, 168, 168, 168, 168, - 168, 168, 168, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, - 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, - 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, 169, - 169, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 92, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 92, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 18, 18, 18, 18, + 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, 128, 15, 15, 15, 15, 15, 15, + 15, 15, 128, 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, 15, 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, 15, 15, 15, 15, 15, 15, 0, 0, 15, 0, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 92, 92, 92, 92, 92, 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, 0, + 3, 15, 15, 15, 15, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 3, 128, + 128, 128, 128, 128, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 196, 196, 196, 196, + 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, + 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, + 196, 196, 196, 196, 196, 196, 196, 196, 197, 197, 197, 197, 197, 197, + 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, + 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, + 197, 197, 197, 197, 197, 197, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 196, + 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, + 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, 196, + 196, 196, 196, 196, 196, 196, 196, 0, 0, 0, 0, 197, 197, 197, 197, + 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, + 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, 197, + 197, 197, 197, 197, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 0, + 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 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, 0, 0, 15, 15, 15, 15, 15, + 15, 0, 0, 15, 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, 15, 15, 15, 15, 15, 0, 15, 15, + 0, 0, 0, 15, 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, 0, 3, 18, 18, 18, 18, 18, + 18, 18, 18, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 14, 14, 18, 18, 18, 18, 18, 18, + 18, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, + 0, 0, 0, 0, 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, 0, 15, 15, 0, 0, 0, + 0, 0, 18, 18, 18, 18, 18, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 18, 18, 18, 18, 18, 18, + 0, 0, 0, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 0, 0, 15, 0, 0, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 18, 18, 15, 15, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 15, 92, 92, 92, 0, 92, 92, + 0, 0, 0, 0, 0, 92, 92, 92, 92, 15, 15, 15, 15, 0, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 0, 3, 18, 18, 18, 18, 18, 18, 18, 18, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 92, 92, 92, 0, 0, + 0, 0, 92, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, + 3, 3, 3, 3, 3, 3, 3, 3, 3, 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, - 18, 18, 18, 18, 18, 18, 0, 0, 0, 3, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 18, 18, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 0, 0, 0, 0, 0, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 15, - 15, 15, 86, 86, 86, 0, 86, 86, 0, 0, 0, 0, 0, 86, 86, 86, 86, 15, 15, - 15, 15, 0, 15, 15, 15, 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, 0, - 0, 0, 0, 86, 86, 86, 0, 0, 0, 0, 86, 18, 18, 18, 18, 18, 18, 18, 18, - 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 3, 3, 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, 18, 18, 3, 15, + 15, 15, 15, 15, 15, 18, 18, 18, 15, 15, 15, 15, 15, 15, 15, 15, 14, + 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, 92, 92, 0, 0, 0, 0, 18, + 18, 18, 18, 18, 3, 3, 3, 3, 3, 3, 3, 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, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 18, 18, - 18, 18, 18, 18, 18, 18, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, + 18, 18, 18, 18, 18, 18, 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, 3, 3, 3, 3, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, + 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, + 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, 97, + 97, 97, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 102, 102, 102, 102, + 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, + 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, + 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, 102, + 102, 102, 102, 102, 102, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, + 15, 15, 15, 15, 92, 92, 92, 92, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, + 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 116, 86, 116, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 18, 18, 18, 18, 18, 18, 0, 18, 18, 18, 18, 18, 18, 18, 15, 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, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 92, 92, 18, 18, 18, 18, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 124, 92, + 124, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 3, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 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, 92, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 124, 124, 124, + 92, 92, 92, 92, 124, 124, 92, 92, 3, 3, 17, 3, 3, 3, 3, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 17, 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, 0, + 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 92, + 92, 92, 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, 92, 92, 92, 92, 92, 124, 92, 92, 92, 92, 92, 92, 92, + 92, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 3, 3, 15, 124, 124, 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, 92, 3, 3, 15, 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, 124, 124, 124, 92, 92, 92, 92, 92, 92, 92, 92, 92, 124, 124, 15, + 15, 15, 15, 3, 3, 3, 3, 92, 92, 92, 92, 3, 0, 0, 9, 9, 9, 9, 9, 9, + 9, 9, 9, 9, 15, 3, 15, 3, 3, 3, 0, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 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, 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, 124, 124, 124, + 92, 92, 92, 124, 124, 92, 124, 92, 92, 3, 3, 3, 3, 3, 3, 92, 0, 15, + 15, 15, 15, 15, 15, 15, 0, 15, 0, 15, 15, 15, 15, 0, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 3, 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, 15, 15, - 15, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 3, - 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 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, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 116, 116, 116, 86, - 86, 86, 86, 116, 116, 86, 86, 3, 3, 17, 3, 3, 3, 3, 0, 0, 0, 0, 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, 0, 0, 0, - 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 86, 86, - 86, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 92, 124, 124, 124, 92, 92, 92, 92, 92, 92, + 92, 92, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, + 0, 92, 92, 124, 124, 0, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, + 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, + 15, 15, 15, 15, 15, 0, 92, 92, 15, 124, 124, 92, 124, 124, 124, 124, + 0, 0, 124, 124, 0, 0, 124, 124, 124, 0, 0, 15, 0, 0, 0, 0, 0, 0, 124, + 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 124, 124, 0, 0, 92, 92, 92, 92, + 92, 92, 92, 0, 0, 0, 92, 92, 92, 92, 92, 0, 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, 124, 124, 124, 92, 92, 92, 92, 92, 92, 92, 92, + 124, 124, 92, 92, 92, 124, 92, 15, 15, 15, 15, 3, 3, 3, 3, 3, 9, 9, + 9, 9, 9, 9, 9, 9, 9, 9, 0, 3, 0, 3, 92, 0, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 124, 124, 124, 92, 92, 92, + 92, 92, 92, 124, 92, 124, 124, 124, 124, 92, 92, 124, 92, 92, 15, 15, + 3, 15, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, + 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 124, 124, 124, 92, 92, 92, 92, 0, 0, 124, 124, 124, 124, 92, 92, + 124, 92, 92, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 3, 3, 3, 15, 15, 15, 15, 92, 92, 0, 0, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 124, 124, 124, 92, 92, 92, + 92, 92, 92, 92, 92, 124, 124, 92, 124, 92, 92, 3, 3, 3, 15, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, + 0, 3, 3, 3, 3, 3, 3, 3, 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, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 92, 124, 92, 124, 124, 92, 92, 92, 92, 92, 92, 124, 92, 0, 0, 0, + 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 124, 124, 92, 92, 92, 92, + 124, 92, 92, 92, 92, 92, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, + 18, 18, 3, 3, 3, 14, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 124, 124, 124, 92, 92, 92, 92, 92, 92, 92, 92, 92, 124, 92, 92, 3, + 0, 0, 0, 0, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, + 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, + 10, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, + 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 9, + 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 92, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 92, 92, 92, 92, 92, 92, 124, 15, 92, + 92, 92, 92, 3, 3, 3, 3, 3, 3, 3, 3, 92, 0, 0, 0, 0, 0, 0, 0, 0, 15, + 92, 92, 92, 92, 92, 92, 124, 124, 92, 92, 92, 15, 15, 15, 15, 15, 15, + 15, 15, 0, 0, 15, 15, 15, 15, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 92, 92, 124, 92, 92, 3, 3, 3, 15, 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, + 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 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, 86, 86, 86, 86, 86, 116, 86, 86, 86, 86, 86, 86, 86, 86, - 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 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, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 124, 92, 92, 92, + 92, 92, 92, 92, 0, 92, 92, 92, 92, 92, 92, 124, 92, 15, 3, 3, 3, 3, + 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 0, 0, 0, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 0, 0, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 92, 92, 92, 92, 92, 92, 0, 124, 92, 92, 92, 92, 92, 92, 92, 124, + 92, 92, 124, 92, 92, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, + 15, 15, 0, 15, 15, 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, 92, 92, 92, 92, 92, 92, 0, 0, 0, + 92, 0, 92, 92, 0, 92, 92, 92, 92, 92, 92, 92, 15, 92, 0, 0, 0, 0, 0, + 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 15, 15, 15, + 15, 15, 15, 0, 15, 15, 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, 124, 124, 124, 124, 124, 0, 92, 92, 0, 124, 124, 92, + 124, 92, 15, 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, 92, 92, 124, 124, 3, 3, 0, + 0, 0, 0, 0, 0, 0, 128, 128, 128, 128, 128, 128, 128, 128, 128, 128, + 128, 128, 128, 128, 128, 0, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 15, 15, 15, 15, 0, 0, 0, 0, 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, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 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, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, + 9, 9, 9, 9, 0, 0, 0, 0, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, + 0, 92, 92, 92, 92, 92, 3, 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, 92, 92, 92, 92, + 92, 92, 92, 3, 3, 3, 3, 3, 14, 14, 14, 14, 91, 91, 91, 91, 3, 14, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 18, 18, + 18, 18, 18, 18, 18, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 15, 15, 15, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 3, 3, 3, 3, 0, 0, 0, 0, 0, 15, 15, 15, 15, + 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 124, 124, 124, 124, 124, 124, + 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, + 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, + 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 92, 92, 92, 92, 91, 91, 91, + 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 0, 0, 0, 0, 0, 0, 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, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 116, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 86, 116, 116, 15, 15, - 15, 15, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, - 9, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, - 116, 86, 116, 116, 86, 86, 86, 86, 86, 86, 116, 86, 0, 0, 0, 0, 0, - 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 118, 118, 118, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, + 15, 0, 0, 0, 0, 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, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, - 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 116, 116, - 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, - 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, - 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, - 116, 116, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 86, 86, 86, - 86, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 15, 15, 0, - 0, 0, 0, 0, 0, 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, 0, 0, 14, 14, 14, 14, + 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 14, 92, 92, 3, 17, 17, 17, + 17, 0, 0, 0, 0, 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, 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, 116, 116, 86, 86, 86, 14, 14, 14, 116, - 116, 116, 116, 116, 116, 17, 17, 17, 17, 17, 17, 17, 17, 86, 86, 86, - 86, 86, 86, 86, 86, 14, 14, 86, 86, 86, 86, 86, 86, 86, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 124, 124, 92, 92, 92, 14, 14, 14, 124, + 124, 124, 124, 124, 124, 17, 17, 17, 17, 17, 17, 17, 17, 92, 92, 92, + 92, 92, 92, 92, 92, 14, 14, 92, 92, 92, 92, 92, 92, 92, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 86, 86, 86, 86, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 92, 92, 92, 92, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14, 86, 86, 86, - 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, 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, + 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, 14, 14, 92, 92, 92, 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, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 100, 100, 100, 100, 100, - 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, - 100, 100, 100, 100, 100, 100, 100, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, - 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 21, - 21, 21, 21, 21, 21, 21, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 100, 100, 100, 100, 100, 100, 100, - 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, - 100, 100, 100, 100, 100, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 100, 0, - 100, 100, 0, 0, 100, 0, 0, 100, 100, 0, 0, 100, 100, 100, 100, 0, 100, - 100, 100, 100, 100, 100, 100, 100, 21, 21, 21, 21, 0, 21, 0, 21, 21, - 21, 21, 21, 21, 21, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, - 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 21, 21, + 18, 18, 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, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, + 0, 0, 0, 0, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, + 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, + 107, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 107, 107, 107, 107, 107, 107, + 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, + 107, 107, 107, 107, 107, 107, 21, 21, 21, 21, 21, 21, 21, 0, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 107, + 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, + 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 100, 100, 0, 100, 100, 100, 100, 0, 0, - 100, 100, 100, 100, 100, 100, 100, 100, 0, 100, 100, 100, 100, 100, - 100, 100, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 100, 100, 0, 100, 100, - 100, 100, 0, 100, 100, 100, 100, 100, 0, 100, 0, 0, 0, 100, 100, 100, - 100, 100, 100, 100, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 100, 100, - 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, - 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 107, 0, 107, 107, 0, 0, 107, 0, 0, 107, 107, + 0, 0, 107, 107, 107, 107, 0, 107, 107, 107, 107, 107, 107, 107, 107, + 21, 21, 21, 21, 0, 21, 0, 21, 21, 21, 21, 21, 21, 21, 0, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 107, 107, 107, 107, 107, 107, 107, + 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, + 107, 107, 107, 107, 107, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 107, 107, + 0, 107, 107, 107, 107, 0, 0, 107, 107, 107, 107, 107, 107, 107, 107, + 0, 107, 107, 107, 107, 107, 107, 107, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, - 100, 100, 100, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 100, 100, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 100, - 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, - 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 21, 21, 21, + 21, 21, 107, 107, 0, 107, 107, 107, 107, 0, 107, 107, 107, 107, 107, + 0, 107, 0, 0, 0, 107, 107, 107, 107, 107, 107, 107, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 100, 100, 100, 100, 100, 100, 100, 100, 100, - 100, 100, 100, 100, 100, 100, 100, 21, 21, 21, 21, 21, 21, 0, 0, 100, - 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, - 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 7, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 107, 107, 107, 107, 107, 107, 107, 107, 107, + 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, + 107, 107, 107, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 107, 107, 107, + 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 107, 107, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 7, 21, 21, 21, 21, 21, 21, 100, 100, 100, 100, 100, - 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, - 100, 100, 100, 100, 100, 100, 7, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 7, - 21, 21, 21, 21, 21, 21, 100, 100, 100, 100, 100, 100, 100, 100, 100, - 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, - 100, 100, 7, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 7, 21, 21, 21, 21, 21, - 21, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, - 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 7, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 107, 107, 107, 107, 107, 107, 107, + 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, + 107, 107, 107, 107, 107, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 107, 107, + 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, + 21, 21, 21, 21, 21, 21, 0, 0, 107, 107, 107, 107, 107, 107, 107, 107, + 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, + 107, 107, 107, 7, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 7, 21, 21, 21, 21, + 21, 21, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, + 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 7, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 7, 21, 21, 21, 21, 21, 21, 100, 100, 100, - 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, - 100, 100, 100, 100, 100, 100, 100, 100, 7, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 7, 21, 21, 21, 21, 21, 21, 107, 107, + 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, + 107, 107, 107, 107, 107, 107, 107, 107, 107, 7, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 7, 21, 21, 21, 21, 21, 21, 100, 21, 0, 0, 9, 9, 9, 9, 9, 9, + 21, 21, 21, 7, 21, 21, 21, 21, 21, 21, 107, 107, 107, 107, 107, 107, + 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, + 107, 107, 107, 107, 107, 7, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 7, 21, + 21, 21, 21, 21, 21, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, + 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, + 107, 7, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 7, 21, 21, 21, 21, 21, 21, + 107, 21, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, - 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, + 9, 9, 9, 9, 9, 9, 9, 9, 9, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 14, 14, 14, 14, + 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, + 92, 14, 14, 14, 14, 14, 14, 14, 14, 92, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 92, 14, 14, 3, 3, 3, 3, 3, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 92, 92, 92, 92, 92, 0, 92, 92, 92, + 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 92, 92, 92, 92, 92, 92, 92, 0, 92, 92, 92, + 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 0, 0, 92, 92, + 92, 92, 92, 92, 92, 0, 92, 92, 0, 92, 92, 92, 92, 92, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, + 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 92, 92, 92, 92, 92, 92, 92, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 198, 198, 198, 198, 198, 198, 198, 198, + 198, 198, 198, 198, 198, 198, 198, 198, 198, 198, 198, 198, 198, 198, + 198, 198, 198, 198, 198, 198, 198, 198, 198, 198, 198, 198, 199, 199, + 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, + 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, + 199, 199, 199, 199, 92, 92, 92, 92, 92, 92, 92, 0, 0, 0, 0, 0, 9, 9, + 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 14, + 18, 18, 18, 4, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 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, 0, 15, 15, 0, 15, 0, 0, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, @@ -1302,38 +1499,41 @@ static const unsigned char groupMap[] = { 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, 0, 0, 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, 0, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 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, 14, 0, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 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, 14, 14, 14, 14, 14, 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, 14, 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, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 0, 0, 0, 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, 0, 0, 0, 0, 0, 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, 0, 14, 14, 14, 14, 14, + 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, + 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 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, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 11, 11, 11, + 11, 11, 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, 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, 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, + 0, 0, 0, 0, 0, 0, 0, 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, 0, 0, 0, 0, 0, 0, + 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, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, - 14, 14, 14, 0, 0, 0, 14, 14, 14, 14, 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, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 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, 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, 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 + 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, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14, 14, 14, 0, 0, 0, 14, 0, 14, + 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 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, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 0, 0, 0, 0, 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, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 #endif /* TCL_UTF_MAX > 3 */ }; @@ -1349,6 +1549,7 @@ static const unsigned char groupMap[] = { * 100 = subtract delta for title/upper * 101 = sub delta for upper, sub 1 for title * 110 = sub delta for upper, add delta for lower + * 111 = subtract delta for upper * * Bits 8-31 Case delta: delta for case conversions. This should be the * highest field so we can easily sign extend. @@ -1361,19 +1562,23 @@ static const int groups[] = { 53057, -24702, 54081, 53569, -41598, 54593, -33150, 54849, 55873, 55617, 56129, -14206, 609, 451, 674, 20354, -24767, -14271, -33215, 2763585, -41663, 2762817, -2768510, -49855, 17729, 18241, -2760318, - -2759550, -2760062, 53890, 52866, 52610, 51842, 52098, 53122, - -10823550, -10830718, 53634, 54146, -2750078, -2751614, 54658, - 54914, -2745982, 55938, 17794, 55682, 18306, 56194, 4, 6, -21370, - 9793, 9537, 16449, 16193, 9858, 9602, 8066, 16514, 16258, 2113, - 16002, 14722, 1, 12162, 13954, 2178, 22146, 20610, -1662, -15295, - 24706, -1727, 20545, 7, 3905, 3970, 12353, 12418, 8, 1859649, - 10, -9044862, -976254, 15234, -1949375, -1918, -1983, -18814, - -21886, -25470, -32638, -28542, -32126, -1981, -2174, -18879, - -2237, 1844610, -21951, -25535, -28607, -32703, -32191, 13, 14, - -1924287, -2145983, -2115007, 7233, 7298, 4170, 4234, 6749, 6813, - -2750143, -976319, -2746047, 2763650, 2762882, -2759615, -2751679, - -2760383, -2760127, -2768575, 1859714, -9044927, -10823615, -10830783, - 18, 17, 10305, 10370 + -2759550, -2760062, 53890, 52866, 52610, 51842, 52098, -10833534, + -10832510, 53122, -10823550, -10830718, 53634, 54146, -2750078, + -10829950, -2751614, 54658, 54914, -2745982, 55938, -10824062, + 17794, 55682, 18306, 56194, -10818686, -10817918, 4, 6, -21370, + 29761, 9793, 9537, 16449, 16193, 9858, 9602, 8066, 16514, 16258, + 2113, 16002, 14722, 1, 12162, 13954, 2178, 22146, 20610, -1662, + 29826, -15295, 24706, -1727, 20545, 7, 3905, 3970, 12353, 12418, + 8, 1859649, -769822, 9949249, 10, 1601154, 1600898, 1598594, 1598082, + 1598338, 1596546, 1582466, -9027966, -769983, -9044862, -976254, + 15234, -1949375, -1918, -1983, -18814, -21886, -25470, -32638, + -28542, -32126, -1981, -2174, -18879, -2237, 1844610, -21951, + -25535, -28607, -32703, -32191, 13, 14, -1924287, -2145983, -2115007, + 7233, 7298, 4170, 4234, 6749, 6813, -2750143, -976319, -2746047, + 2763650, 2762882, -2759615, -2751679, -2760383, -2760127, -2768575, + 1859714, -9044927, -10823615, -10830783, -10833599, -10832575, + -10830015, -10817983, -10824127, -10818751, 237633, 237698, 9949314, + 18, 17, 10305, 10370, 8769, 8834 }; #if TCL_UTF_MAX > 3 @@ -1435,4 +1640,8 @@ enum { * Unicode character tables. */ -#define GetUniCharInfo(ch) (groups[groupMap[pageMap[((ch) & 0xffff) >> OFFSET_BITS] | ((ch) & ((1 << OFFSET_BITS)-1))]]) +#if TCL_UTF_MAX > 3 +# define GetUniCharInfo(ch) (groups[groupMap[pageMap[((ch) & 0x1fffff) >> OFFSET_BITS] | ((ch) & ((1 << OFFSET_BITS)-1))]]) +#else +# define GetUniCharInfo(ch) (groups[groupMap[pageMap[((ch) & 0xffff) >> OFFSET_BITS] | ((ch) & ((1 << OFFSET_BITS)-1))]]) +#endif diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 15529c7..c8292a2 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -68,33 +68,14 @@ 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, 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3, -#if TCL_UTF_MAX > 3 4,4,4,4,4,4,4,4, -#else - 1,1,1,1,1,1,1,1, -#endif -#if TCL_UTF_MAX > 4 - 5,5,5,5, -#else - 1,1,1,1, -#endif -#if TCL_UTF_MAX > 5 - 6,6,6,6 -#else - 1,1,1,1 -#endif + 1,1,1,1,1,1,1,1 }; - -/* - * Functions used only in this module. - */ - -static int UtfCount(int ch); /* *--------------------------------------------------------------------------- * - * UtfCount -- + * TclUtfCount -- * * Find the number of bytes in the Utf character "ch". * @@ -107,30 +88,19 @@ static int UtfCount(int ch); *--------------------------------------------------------------------------- */ -INLINE static int -UtfCount( - int ch) /* The Tcl_UniChar whose size is returned. */ +int +TclUtfCount( + int ch) /* The Unicode character whose size is returned. */ { - if ((ch > 0) && (ch < UNICODE_SELF)) { + if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) { return 1; } if (ch <= 0x7FF) { return 2; } - if (ch <= 0xFFFF) { - return 3; - } -#if TCL_UTF_MAX > 3 - if (ch <= 0x1FFFFF) { + if (((unsigned)(ch - 0x10000) <= 0xFFFFF)) { return 4; } - if (ch <= 0x3FFFFFF) { - return 5; - } - if (ch <= 0x7FFFFFFF) { - return 6; - } -#endif return 3; } @@ -152,16 +122,16 @@ UtfCount( *--------------------------------------------------------------------------- */ -INLINE int +int Tcl_UniCharToUtf( int ch, /* The Tcl_UniChar to be stored in the * buffer. */ char *buf) /* Buffer in which the UTF-8 representation of * the Tcl_UniChar is stored. Buffer must be * large enough to hold the UTF-8 character - * (at most TCL_UTF_MAX bytes). */ + * (at most 4 bytes). */ { - if ((ch > 0) && (ch < UNICODE_SELF)) { + if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) { buf[0] = (char) ch; return 1; } @@ -172,43 +142,52 @@ Tcl_UniCharToUtf( return 2; } if (ch <= 0xFFFF) { - three: - buf[2] = (char) ((ch | 0x80) & 0xBF); - buf[1] = (char) (((ch >> 6) | 0x80) & 0xBF); - buf[0] = (char) ((ch >> 12) | 0xE0); - return 3; + if ((ch & 0xF800) == 0xD800) { + if (ch & 0x0400) { + /* Low surrogate */ + if (((buf[0] & 0xF8) == 0xF0) && ((buf[1] & 0xC0) == 0x80) + && ((buf[2] & 0xCF) == 0)) { + /* Previous Tcl_UniChar was a High surrogate, so combine */ + buf[3] = (char) ((ch & 0x3F) | 0x80); + buf[2] |= (char) (((ch >> 6) & 0x0F) | 0x80); + return 4; + } + /* Previous Tcl_UniChar was not a High surrogate, so just output */ + } else { + /* High surrogate */ + ch += 0x40; + /* Fill buffer with specific 3-byte (invalid) byte combination, + so following Low surrogate can recognize it and combine */ + buf[2] = (char) ((ch << 4) & 0x30); + buf[1] = (char) (((ch >> 2) & 0x3F) | 0x80); + buf[0] = (char) (((ch >> 8) & 0x07) | 0xF0); + return 0; + } + } + goto three; } - -#if TCL_UTF_MAX > 3 - if (ch <= 0x1FFFFF) { + if (ch <= 0x10FFFF) { buf[3] = (char) ((ch | 0x80) & 0xBF); buf[2] = (char) (((ch >> 6) | 0x80) & 0xBF); buf[1] = (char) (((ch >> 12) | 0x80) & 0xBF); buf[0] = (char) ((ch >> 18) | 0xF0); return 4; } - if (ch <= 0x3FFFFFF) { - buf[4] = (char) ((ch | 0x80) & 0xBF); - buf[3] = (char) (((ch >> 6) | 0x80) & 0xBF); - buf[2] = (char) (((ch >> 12) | 0x80) & 0xBF); - buf[1] = (char) (((ch >> 18) | 0x80) & 0xBF); - buf[0] = (char) ((ch >> 24) | 0xF8); - return 5; + } else if (ch == -1) { + if (((buf[0] & 0xF8) == 0xF0) && ((buf[1] & 0xC0) == 0x80) + && ((buf[2] & 0xCF) == 0)) { + ch = 0xD7C0 + ((buf[0] & 0x07) << 8) + ((buf[1] & 0x3F) << 2) + + ((buf[2] & 0x30) >> 4); + goto three; } - if (ch <= 0x7FFFFFFF) { - buf[5] = (char) ((ch | 0x80) & 0xBF); - buf[4] = (char) (((ch >> 6) | 0x80) & 0xBF); - buf[3] = (char) (((ch >> 12) | 0x80) & 0xBF); - buf[2] = (char) (((ch >> 18) | 0x80) & 0xBF); - buf[1] = (char) (((ch >> 24) | 0x80) & 0xBF); - buf[0] = (char) ((ch >> 30) | 0xFC); - return 6; - } -#endif } ch = 0xFFFD; - goto three; +three: + buf[2] = (char) ((ch | 0x80) & 0xBF); + buf[1] = (char) (((ch >> 6) | 0x80) & 0xBF); + buf[0] = (char) ((ch >> 12) | 0xE0); + return 3; } /* @@ -239,23 +218,31 @@ Tcl_UniCharToUtfDString( { const Tcl_UniChar *w, *wEnd; char *p, *string; - int oldLength; + int oldLength, len = 1; /* - * UTF-8 string length in bytes will be <= Unicode string length * - * TCL_UTF_MAX. + * UTF-8 string length in bytes will be <= Unicode string length * 4. */ oldLength = Tcl_DStringLength(dsPtr); - Tcl_DStringSetLength(dsPtr, (oldLength + uniLength + 1) * TCL_UTF_MAX); + Tcl_DStringSetLength(dsPtr, (oldLength + uniLength + 1) * 4); string = Tcl_DStringValue(dsPtr) + oldLength; p = string; wEnd = uniStr + uniLength; for (w = uniStr; w < wEnd; ) { - p += Tcl_UniCharToUtf(*w, p); + if (!len && ((*w & 0xFC00) != 0xDC00)) { + /* Special case for handling upper surrogates. */ + p += Tcl_UniCharToUtf(-1, p); + } + len = Tcl_UniCharToUtf(*w, p); + p += len; w++; } + if (!len) { + /* Special case for handling upper surrogates. */ + p += Tcl_UniCharToUtf(-1, p); + } Tcl_DStringSetLength(dsPtr, oldLength + (p - string)); return string; @@ -277,6 +264,15 @@ Tcl_UniCharToUtfDString( * Tcl_UtfCharComplete() before calling this routine to ensure that * enough bytes remain in the string. * + * If TCL_UTF_MAX == 4, special handling of Surrogate pairs is done: + * For any UTF-8 string containing a character outside of the BMP, the + * first call to this function will fill *chPtr with the high surrogate + * and generate a return value of 0. Calling Tcl_UtfToUniChar again + * will produce the low surrogate and a return value of 4. Because *chPtr + * is used to remember whether the high surrogate is already produced, it + * is recommended to initialize the variable it points to as 0 before + * the first call to Tcl_UtfToUniChar is done. + * * Results: * *chPtr is filled with the Tcl_UniChar, and the return value is the * number of bytes from the UTF-8 string that were consumed. @@ -287,6 +283,13 @@ Tcl_UniCharToUtfDString( *--------------------------------------------------------------------------- */ +static const unsigned short cp1252[32] = { + 0x20ac, 0x81, 0x201A, 0x0192, 0x201E, 0x2026, 0x2020, 0x2021, + 0x02C6, 0x2030, 0x0160, 0x2039, 0x0152, 0x8D, 0x017D, 0x8F, + 0x90, 0x2018, 0x2019, 0x201C, 0x201D, 0x2022, 0x2013, 0x2014, + 0x2DC, 0x2122, 0x0161, 0x203A, 0x0153, 0x9D, 0x017E, 0x0178 +}; + int Tcl_UtfToUniChar( register const char *src, /* The UTF-8 string. */ @@ -296,18 +299,24 @@ Tcl_UtfToUniChar( register int byte; /* - * Unroll 1 to 3 byte UTF-8 sequences, use loop to handle longer ones. + * Unroll 1 to 3 (or 4) byte UTF-8 sequences. */ byte = *((unsigned char *) src); if (byte < 0xC0) { /* * Handles properly formed UTF-8 characters between 0x01 and 0x7F. - * Also treats \0 and naked trail bytes 0x80 to 0xBF as valid + * Treats naked trail bytes 0x80 to 0x9F as valid characters from + * the cp1252 table. See: <https://en.wikipedia.org/wiki/UTF-8> + * Also treats \0 and other naked trail bytes 0xA0 to 0xBF as valid * characters representing themselves. */ - *chPtr = (Tcl_UniChar) byte; + if ((unsigned)(byte-0x80) < (unsigned) 0x20) { + *chPtr = (Tcl_UniChar) cp1252[byte-0x80]; + } else { + *chPtr = (Tcl_UniChar) byte; + } return 1; } else if (byte < 0xE0) { if ((src[1] & 0xC0) == 0x80) { @@ -316,16 +325,15 @@ Tcl_UtfToUniChar( */ *chPtr = (Tcl_UniChar) (((byte & 0x1F) << 6) | (src[1] & 0x3F)); - return 2; + if ((unsigned)(*chPtr - 1) >= (UNICODE_SELF - 1)) { + return 2; + } } /* * A two-byte-character lead-byte not followed by trail-byte * represents itself. */ - - *chPtr = (Tcl_UniChar) byte; - return 1; } else if (byte < 0xF0) { if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80)) { /* @@ -334,40 +342,52 @@ Tcl_UtfToUniChar( *chPtr = (Tcl_UniChar) (((byte & 0x0F) << 12) | ((src[1] & 0x3F) << 6) | (src[2] & 0x3F)); - return 3; + if (*chPtr > 0x7FF) { + return 3; + } } /* * A three-byte-character lead-byte not followed by two trail-bytes * represents itself. */ - - *chPtr = (Tcl_UniChar) byte; - return 1; } -#if TCL_UTF_MAX > 3 - { - int ch, total, trail; - - total = totalBytes[byte]; - trail = total - 1; - if (trail > 0) { - ch = byte & (0x3F >> trail); - do { - src++; - if ((*src & 0xC0) != 0x80) { - *chPtr = byte; - return 1; - } - ch <<= 6; - ch |= (*src & 0x3F); - trail--; - } while (trail > 0); - *chPtr = ch; - return total; + else if (byte < 0xF8) { + if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80) && ((src[3] & 0xC0) == 0x80)) { + /* + * Four-byte-character lead byte followed by three trail bytes. + */ +#if TCL_UTF_MAX <= 4 + Tcl_UniChar surrogate; + + byte = (((byte & 0x07) << 18) | ((src[1] & 0x3F) << 12) + | ((src[2] & 0x3F) << 6) | (src[3] & 0x3F)) - 0x10000; + surrogate = (Tcl_UniChar) (0xD800 + (byte >> 10)); + if (byte & 0x100000) { + /* out of range, < 0x10000 or > 0x10ffff */ + } else if (*chPtr != surrogate) { + /* produce high surrogate, but don't advance source pointer */ + *chPtr = surrogate; + return 0; + } else { + /* produce low surrogate, and advance source pointer */ + *chPtr = (Tcl_UniChar) (0xDC00 | (byte & 0x3FF)); + return 4; + } +#else + *chPtr = (Tcl_UniChar) (((byte & 0x07) << 18) | ((src[1] & 0x3F) << 12) + | ((src[2] & 0x3F) << 6) | (src[3] & 0x3F)); + if ((unsigned)(*chPtr - 0x10000) <= 0xFFFFF) { + return 4; + } +#endif } + + /* + * A four-byte-character lead-byte not followed by two trail-bytes + * represents itself. + */ } -#endif *chPtr = (Tcl_UniChar) byte; return 1; @@ -400,7 +420,7 @@ Tcl_UtfToUniCharDString( * appended to this previously initialized * DString. */ { - Tcl_UniChar *w, *wString; + Tcl_UniChar ch = 0, *w, *wString; const char *p, *end; int oldLength; @@ -422,8 +442,8 @@ Tcl_UtfToUniCharDString( w = wString; end = src + length; for (p = src; p < end; ) { - p += TclUtfToUniChar(p, w); - w++; + p += TclUtfToUniChar(p, &ch); + *w++ = ch; } *w = '\0'; Tcl_DStringSetLength(dsPtr, @@ -457,10 +477,7 @@ Tcl_UtfCharComplete( * a complete UTF-8 character. */ int length) /* Length of above string in bytes. */ { - int ch; - - ch = *((unsigned char *) src); - return length >= totalBytes[ch]; + return length >= totalBytes[(unsigned char)*src]; } /* @@ -487,9 +504,8 @@ Tcl_NumUtfChars( int length) /* The length of the string in bytes, or -1 * for strlen(string). */ { - Tcl_UniChar ch; - register Tcl_UniChar *chPtr = &ch; - register int i; + Tcl_UniChar ch = 0; + register int i = 0; /* * The separate implementations are faster. @@ -498,26 +514,27 @@ Tcl_NumUtfChars( * single-byte char case specially. */ - i = 0; if (length < 0) { while (*src != '\0') { - src += TclUtfToUniChar(src, chPtr); + src += TclUtfToUniChar(src, &ch); i++; } + if (i < 0) i = INT_MAX; /* Bug [2738427] */ } else { - register int n; + register const char *endPtr = src + length - 4; - while (length > 0) { - if (UCHAR(*src) < 0xC0) { - length--; - src++; - } else { - n = Tcl_UtfToUniChar(src, chPtr); - length -= n; - src += n; - } + while (src < endPtr) { + src += TclUtfToUniChar(src, &ch); + i++; + } + endPtr += 4; + while ((src < endPtr) && Tcl_UtfCharComplete(src, endPtr - src)) { + src += TclUtfToUniChar(src, &ch); i++; } + if (src < endPtr) { + i += endPtr - src; + } } return i; } @@ -527,13 +544,13 @@ Tcl_NumUtfChars( * * Tcl_UtfFindFirst -- * - * Returns a pointer to the first occurance of the given Tcl_UniChar in - * the NULL-terminated UTF-8 string. The NULL terminator is considered + * Returns a pointer to the first occurance of the given Unicode character + * in the NULL-terminated UTF-8 string. The NULL terminator is considered * part of the UTF-8 string. Equivalent to Plan 9 utfrune(). * * Results: - * As above. If the Tcl_UniChar does not exist in the given string, the - * return value is NULL. + * As above. If the Unicode character does not exist in the given string, + * the return value is NULL. * * Side effects: * None. @@ -544,14 +561,21 @@ Tcl_NumUtfChars( const char * Tcl_UtfFindFirst( const char *src, /* The UTF-8 string to be searched. */ - int ch) /* The Tcl_UniChar to search for. */ + int ch) /* The Unicode character to search for. */ { - int len; - Tcl_UniChar find; + int len, fullchar; + Tcl_UniChar find = 0; while (1) { len = TclUtfToUniChar(src, &find); - if (find == ch) { + fullchar = find; +#if TCL_UTF_MAX <= 4 + if (!len) { + len += TclUtfToUniChar(src, &find); + fullchar = (((fullchar & 0x3ff) << 10) | (find & 0x3ff)) + 0x10000; + } +#endif + if (fullchar == ch) { return src; } if (*src == '\0') { @@ -566,12 +590,12 @@ Tcl_UtfFindFirst( * * Tcl_UtfFindLast -- * - * Returns a pointer to the last occurance of the given Tcl_UniChar in - * the NULL-terminated UTF-8 string. The NULL terminator is considered + * Returns a pointer to the last occurance of the given Unicode character + * in the NULL-terminated UTF-8 string. The NULL terminator is considered * part of the UTF-8 string. Equivalent to Plan 9 utfrrune(). * * Results: - * As above. If the Tcl_UniChar does not exist in the given string, the + * As above. If the Unicode character does not exist in the given string, the * return value is NULL. * * Side effects: @@ -583,16 +607,23 @@ Tcl_UtfFindFirst( const char * Tcl_UtfFindLast( const char *src, /* The UTF-8 string to be searched. */ - int ch) /* The Tcl_UniChar to search for. */ + int ch) /* The Unicode character to search for. */ { - int len; - Tcl_UniChar find; + int len, fullchar; + Tcl_UniChar find = 0; const char *last; last = NULL; while (1) { len = TclUtfToUniChar(src, &find); - if (find == ch) { + fullchar = find; +#if TCL_UTF_MAX <= 4 + if (!len) { + len += TclUtfToUniChar(src, &find); + fullchar = (((fullchar & 0x3ff) << 10) | (find & 0x3ff)) + 0x10000; + } +#endif + if (fullchar == ch) { last = src; } if (*src == '\0') { @@ -626,9 +657,15 @@ const char * Tcl_UtfNext( const char *src) /* The current location in the string. */ { - Tcl_UniChar ch; + Tcl_UniChar ch = 0; + int len = TclUtfToUniChar(src, &ch); - return src + TclUtfToUniChar(src, &ch); +#if TCL_UTF_MAX <= 4 + if (len == 0) { + len = TclUtfToUniChar(src, &ch); + } +#endif + return src + len; } /* @@ -661,9 +698,8 @@ Tcl_UtfPrev( const char *look; int i, byte; - src--; - look = src; - for (i = 0; i < TCL_UTF_MAX; i++) { + look = --src; + for (i = 0; i < 4; i++) { if (look < start) { if (src < start) { src = start; @@ -687,7 +723,7 @@ Tcl_UtfPrev( * * Tcl_UniCharAtIndex -- * - * Returns the Unicode character represented at the specified character + * Returns the Tcl_UniChar represented at the specified character * (not byte) position in the UTF-8 string. * * Results: @@ -699,18 +735,33 @@ Tcl_UtfPrev( *--------------------------------------------------------------------------- */ -Tcl_UniChar +int Tcl_UniCharAtIndex( register const char *src, /* The UTF-8 string to dereference. */ register int index) /* The position of the desired character. */ { Tcl_UniChar ch = 0; + int fullchar = 0; +#if TCL_UTF_MAX <= 4 + int len = 1; +#endif - while (index >= 0) { - index--; + while (index-- >= 0) { +#if TCL_UTF_MAX <= 4 + src += (len = TclUtfToUniChar(src, &ch)); +#else src += TclUtfToUniChar(src, &ch); +#endif } - return ch; + fullchar = ch; +#if TCL_UTF_MAX <= 4 + if (!len) { + /* If last Tcl_UniChar was an upper surrogate, combine with lower surrogate */ + (void)TclUtfToUniChar(src, &ch); + fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; + } +#endif + return fullchar; } /* @@ -719,7 +770,9 @@ Tcl_UniCharAtIndex( * Tcl_UtfAtIndex -- * * Returns a pointer to the specified character (not byte) position in - * the UTF-8 string. + * the UTF-8 string. If TCL_UTF_MAX <= 4, characters > U+FFFF count as + * 2 positions, but then the pointer should never be placed between + * the two positions. * * Results: * As above. @@ -735,12 +788,19 @@ Tcl_UtfAtIndex( register const char *src, /* The UTF-8 string. */ register int index) /* The position of the desired character. */ { - Tcl_UniChar ch; + Tcl_UniChar ch = 0; + int len = 1; - while (index > 0) { - index--; + while (index-- > 0) { + len = TclUtfToUniChar(src, &ch); + src += len; + } +#if TCL_UTF_MAX <= 4 + if (!len) { + /* Index points at character following High Surrogate */ src += TclUtfToUniChar(src, &ch); } +#endif return src; } @@ -819,7 +879,8 @@ int Tcl_UtfToUpper( char *str) /* String to convert in place. */ { - Tcl_UniChar ch, upChar; + Tcl_UniChar ch = 0; + int upChar; char *src, *dst; int bytes; @@ -830,7 +891,16 @@ Tcl_UtfToUpper( src = dst = str; while (*src) { bytes = TclUtfToUniChar(src, &ch); - upChar = Tcl_UniCharToUpper(ch); + upChar = ch; +#if TCL_UTF_MAX <= 4 + if (!bytes) { + /* TclUtfToUniChar only returns 0 for chars > 0xffff ! */ + bytes = TclUtfToUniChar(src, &ch); + /* Combine surrogates */ + upChar = (((upChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; + } +#endif + upChar = Tcl_UniCharToUpper(upChar); /* * To keep badly formed Utf strings from getting inflated by the @@ -838,7 +908,7 @@ Tcl_UtfToUpper( * char to dst if its size is <= the original char. */ - if (bytes < UtfCount(upChar)) { + if ((bytes < TclUtfCount(upChar)) || ((upChar & 0xF800) == 0xD800)) { memcpy(dst, src, (size_t) bytes); dst += bytes; } else { @@ -872,7 +942,8 @@ int Tcl_UtfToLower( char *str) /* String to convert in place. */ { - Tcl_UniChar ch, lowChar; + Tcl_UniChar ch = 0; + int lowChar; char *src, *dst; int bytes; @@ -883,7 +954,16 @@ Tcl_UtfToLower( src = dst = str; while (*src) { bytes = TclUtfToUniChar(src, &ch); - lowChar = Tcl_UniCharToLower(ch); + lowChar = ch; +#if TCL_UTF_MAX <= 4 + if (!bytes) { + /* TclUtfToUniChar only returns 0 for chars > 0xffff ! */ + bytes = TclUtfToUniChar(src, &ch); + /* Combine surrogates */ + lowChar = (((lowChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; + } +#endif + lowChar = Tcl_UniCharToLower(lowChar); /* * To keep badly formed Utf strings from getting inflated by the @@ -891,7 +971,7 @@ Tcl_UtfToLower( * char to dst if its size is <= the original char. */ - if (bytes < UtfCount(lowChar)) { + if ((bytes < TclUtfCount(lowChar)) || ((lowChar & 0xF800) == 0xD800)) { memcpy(dst, src, (size_t) bytes); dst += bytes; } else { @@ -926,7 +1006,8 @@ int Tcl_UtfToTitle( char *str) /* String to convert in place. */ { - Tcl_UniChar ch, titleChar, lowChar; + Tcl_UniChar ch = 0; + int titleChar, lowChar; char *src, *dst; int bytes; @@ -939,9 +1020,18 @@ Tcl_UtfToTitle( if (*src) { bytes = TclUtfToUniChar(src, &ch); - titleChar = Tcl_UniCharToTitle(ch); + titleChar = ch; +#if TCL_UTF_MAX <= 4 + if (!bytes) { + /* TclUtfToUniChar only returns 0 for chars > 0xffff ! */ + bytes = TclUtfToUniChar(src, &ch); + /* Combine surrogates */ + titleChar = (((titleChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; + } +#endif + titleChar = Tcl_UniCharToTitle(titleChar); - if (bytes < UtfCount(titleChar)) { + if ((bytes < TclUtfCount(titleChar)) || ((titleChar & 0xF800) == 0xD800)) { memcpy(dst, src, (size_t) bytes); dst += bytes; } else { @@ -951,9 +1041,21 @@ Tcl_UtfToTitle( } while (*src) { bytes = TclUtfToUniChar(src, &ch); - lowChar = Tcl_UniCharToLower(ch); + lowChar = ch; +#if TCL_UTF_MAX <= 4 + if (!bytes) { + /* TclUtfToUniChar only returns 0 for chars > 0xffff ! */ + bytes = TclUtfToUniChar(src, &ch); + /* Combine surrogates */ + lowChar = (((lowChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; + } +#endif + /* Special exception for Georgian Asomtavruli chars, no titlecase. */ + if ((unsigned)(lowChar - 0x1C90) >= 0x30) { + lowChar = Tcl_UniCharToLower(lowChar); + } - if (bytes < UtfCount(lowChar)) { + if ((bytes < TclUtfCount(lowChar)) || ((lowChar & 0xF800) == 0xD800)) { memcpy(dst, src, (size_t) bytes); dst += bytes; } else { @@ -1035,11 +1137,11 @@ Tcl_UtfNcmp( const char *ct, /* UTF string cs is compared to. */ unsigned long numChars) /* Number of UTF chars to compare. */ { - Tcl_UniChar ch1, ch2; + Tcl_UniChar ch1 = 0, ch2 = 0; /* * Cannot use 'memcmp(cs, ct, n);' as byte representation of \u0000 (the - * pair of bytes 0xc0,0x80) is larger than byte representation of \u0001 + * pair of bytes 0xC0,0x80) is larger than byte representation of \u0001 * (the byte 0x01.) */ @@ -1053,6 +1155,16 @@ Tcl_UtfNcmp( cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); if (ch1 != ch2) { +#if TCL_UTF_MAX <= 4 + /* Surrogates always report higher than non-surrogates */ + if (((ch1 & 0xFC00) == 0xD800)) { + if ((ch2 & 0xFC00) != 0xD800) { + return ch1; + } + } else if ((ch2 & 0xFC00) == 0xD800) { + return -ch2; + } +#endif return (ch1 - ch2); } } @@ -1083,7 +1195,8 @@ Tcl_UtfNcasecmp( const char *ct, /* UTF string cs is compared to. */ unsigned long numChars) /* Number of UTF chars to compare. */ { - Tcl_UniChar ch1, ch2; + Tcl_UniChar ch1 = 0, ch2 = 0; + while (numChars-- > 0) { /* * n must be interpreted as chars, not bytes. @@ -1093,6 +1206,16 @@ Tcl_UtfNcasecmp( cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); if (ch1 != ch2) { +#if TCL_UTF_MAX <= 4 + /* Surrogates always report higher than non-surrogates */ + if (((ch1 & 0xFC00) == 0xD800)) { + if ((ch2 & 0xFC00) != 0xD800) { + return ch1; + } + } else if ((ch2 & 0xFC00) == 0xD800) { + return -ch2; + } +#endif ch1 = Tcl_UniCharToLower(ch1); ch2 = Tcl_UniCharToLower(ch2); if (ch1 != ch2) { @@ -1102,11 +1225,57 @@ Tcl_UtfNcasecmp( } return 0; } + +/* + *---------------------------------------------------------------------- + * + * Tcl_UtfCmp -- + * + * Compare UTF chars of string cs to string ct case sensitively. + * Replacement for strcmp in Tcl core, in places where UTF-8 should + * be handled. + * + * Results: + * Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclUtfCmp( + const char *cs, /* UTF string to compare to ct. */ + const char *ct) /* UTF string cs is compared to. */ +{ + Tcl_UniChar ch1 = 0, ch2 = 0; + + while (*cs && *ct) { + cs += TclUtfToUniChar(cs, &ch1); + ct += TclUtfToUniChar(ct, &ch2); + if (ch1 != ch2) { +#if TCL_UTF_MAX <= 4 + /* Surrogates always report higher than non-surrogates */ + if (((ch1 & 0xFC00) == 0xD800)) { + if ((ch2 & 0xFC00) != 0xD800) { + return ch1; + } + } else if ((ch2 & 0xFC00) == 0xD800) { + return -ch2; + } +#endif + return ch1 - ch2; + } + } + return UCHAR(*cs) - UCHAR(*ct); +} + /* *---------------------------------------------------------------------- * - * Tcl_UtfNcasecmp -- + * TclUtfCasecmp -- * * Compare UTF chars of string cs to string ct case insensitively. * Replacement for strcasecmp in Tcl core, in places where UTF-8 should @@ -1126,12 +1295,22 @@ TclUtfCasecmp( const char *cs, /* UTF string to compare to ct. */ const char *ct) /* UTF string cs is compared to. */ { - while (*cs && *ct) { - Tcl_UniChar ch1, ch2; + Tcl_UniChar ch1 = 0, ch2 = 0; + while (*cs && *ct) { cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); if (ch1 != ch2) { +#if TCL_UTF_MAX <= 4 + /* Surrogates always report higher than non-surrogates */ + if (((ch1 & 0xFC00) == 0xD800)) { + if ((ch2 & 0xFC00) != 0xD800) { + return ch1; + } + } else if ((ch2 & 0xFC00) == 0xD800) { + return -ch2; + } +#endif ch1 = Tcl_UniCharToLower(ch1); ch2 = Tcl_UniCharToLower(ch2); if (ch1 != ch2) { @@ -1159,16 +1338,18 @@ TclUtfCasecmp( *---------------------------------------------------------------------- */ -Tcl_UniChar +int Tcl_UniCharToUpper( int ch) /* Unicode character to convert. */ { - int info = GetUniCharInfo(ch); + if (!UNICODE_OUT_OF_RANGE(ch)) { + int info = GetUniCharInfo(ch); - if (GetCaseType(info) & 0x04) { - ch -= GetDelta(info); + if (GetCaseType(info) & 0x04) { + ch -= GetDelta(info); + } } - return (Tcl_UniChar) ch; + return ch & 0x1FFFFF; } /* @@ -1187,16 +1368,19 @@ Tcl_UniCharToUpper( *---------------------------------------------------------------------- */ -Tcl_UniChar +int Tcl_UniCharToLower( int ch) /* Unicode character to convert. */ { - int info = GetUniCharInfo(ch); + if (!UNICODE_OUT_OF_RANGE(ch)) { + int info = GetUniCharInfo(ch); + int mode = GetCaseType(info); - if (GetCaseType(info) & 0x02) { - ch += GetDelta(info); + if ((mode & 0x02) && (mode != 0x7)) { + ch += GetDelta(info); + } } - return (Tcl_UniChar) ch; + return ch & 0x1FFFFF; } /* @@ -1215,23 +1399,27 @@ Tcl_UniCharToLower( *---------------------------------------------------------------------- */ -Tcl_UniChar +int Tcl_UniCharToTitle( int ch) /* Unicode character to convert. */ { - int info = GetUniCharInfo(ch); - int mode = GetCaseType(info); + if (!UNICODE_OUT_OF_RANGE(ch)) { + int info = GetUniCharInfo(ch); + int mode = GetCaseType(info); - if (mode & 0x1) { - /* - * Subtract or add one depending on the original case. - */ + if (mode & 0x1) { + /* + * Subtract or add one depending on the original case. + */ - ch += ((mode & 0x4) ? -1 : 1); - } else if (mode == 0x4) { - ch -= GetDelta(info); + if (mode != 0x7) { + ch += ((mode & 0x4) ? -1 : 1); + } + } else if (mode == 0x4) { + ch -= GetDelta(info); + } } - return (Tcl_UniChar) ch; + return ch & 0x1FFFFF; } /* @@ -1365,6 +1553,9 @@ int Tcl_UniCharIsAlnum( int ch) /* Unicode character to test. */ { + if (UNICODE_OUT_OF_RANGE(ch)) { + return 0; + } return (((ALPHA_BITS | DIGIT_BITS) >> GetCategory(ch)) & 1); } @@ -1388,6 +1579,9 @@ int Tcl_UniCharIsAlpha( int ch) /* Unicode character to test. */ { + if (UNICODE_OUT_OF_RANGE(ch)) { + return 0; + } return ((ALPHA_BITS >> GetCategory(ch)) & 1); } @@ -1411,6 +1605,16 @@ int Tcl_UniCharIsControl( int ch) /* Unicode character to test. */ { + if (UNICODE_OUT_OF_RANGE(ch)) { + ch &= 0x1FFFFF; + if ((ch == 0xE0001) || ((ch >= 0xE0020) && (ch <= 0xE007f))) { + return 1; + } + if ((ch >= 0xF0000) && ((ch & 0xFFFF) <= 0xFFFD)) { + return 1; + } + return 0; + } return ((CONTROL_BITS >> GetCategory(ch)) & 1); } @@ -1434,6 +1638,9 @@ int Tcl_UniCharIsDigit( int ch) /* Unicode character to test. */ { + if (UNICODE_OUT_OF_RANGE(ch)) { + return 0; + } return (GetCategory(ch) == DECIMAL_DIGIT_NUMBER); } @@ -1457,6 +1664,10 @@ int Tcl_UniCharIsGraph( int ch) /* Unicode character to test. */ { + if (UNICODE_OUT_OF_RANGE(ch)) { + ch &= 0x1FFFFF; + return (ch >= 0xE0100) && (ch <= 0xE01EF); + } return ((GRAPH_BITS >> GetCategory(ch)) & 1); } @@ -1480,6 +1691,9 @@ int Tcl_UniCharIsLower( int ch) /* Unicode character to test. */ { + if (UNICODE_OUT_OF_RANGE(ch)) { + return 0; + } return (GetCategory(ch) == LOWERCASE_LETTER); } @@ -1503,6 +1717,10 @@ int Tcl_UniCharIsPrint( int ch) /* Unicode character to test. */ { + if (UNICODE_OUT_OF_RANGE(ch)) { + ch &= 0x1FFFFF; + return (ch >= 0xE0100) && (ch <= 0xE01EF); + } return (((GRAPH_BITS|SPACE_BITS) >> GetCategory(ch)) & 1); } @@ -1526,6 +1744,9 @@ int Tcl_UniCharIsPunct( int ch) /* Unicode character to test. */ { + if (UNICODE_OUT_OF_RANGE(ch)) { + return 0; + } return ((PUNCT_BITS >> GetCategory(ch)) & 1); } @@ -1549,16 +1770,20 @@ int Tcl_UniCharIsSpace( int ch) /* Unicode character to test. */ { + /* Ignore upper 11 bits. */ + ch &= 0x1FFFFF; + /* * If the character is within the first 127 characters, just use the * standard C function, otherwise consult the Unicode table. */ - if (((Tcl_UniChar) ch) < ((Tcl_UniChar) 0x80)) { + if (ch < 0x80) { return TclIsSpaceProc((char) ch); - } else if ((Tcl_UniChar) ch == 0x0085 || (Tcl_UniChar) ch == 0x180e - || (Tcl_UniChar) ch == 0x200b || (Tcl_UniChar) ch == 0x2060 - || (Tcl_UniChar) ch == 0x202f || (Tcl_UniChar) ch == 0xfeff) { + } else if (UNICODE_OUT_OF_RANGE(ch)) { + return 0; + } else if (ch == 0x0085 || ch == 0x180E || ch == 0x200B + || ch == 0x202F || ch == 0x2060 || ch == 0xFEFF) { return 1; } else { return ((SPACE_BITS >> GetCategory(ch)) & 1); @@ -1585,6 +1810,9 @@ int Tcl_UniCharIsUpper( int ch) /* Unicode character to test. */ { + if (UNICODE_OUT_OF_RANGE(ch)) { + return 0; + } return (GetCategory(ch) == UPPERCASE_LETTER); } @@ -1608,6 +1836,9 @@ int Tcl_UniCharIsWordChar( int ch) /* Unicode character to test. */ { + if (UNICODE_OUT_OF_RANGE(ch)) { + return 0; + } return ((WORD_BITS >> GetCategory(ch)) & 1); } @@ -1642,7 +1873,7 @@ Tcl_UniCharCaseMatch( * characters. */ int nocase) /* 0 for case sensitive, 1 for insensitive */ { - Tcl_UniChar ch1, p; + Tcl_UniChar ch1 = 0, p; while (1) { p = *uniPattern; diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 27e2474..48602c4 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -14,6 +14,7 @@ #include "tclInt.h" #include "tclParse.h" +#include "tclStringTrim.h" #include <math.h> /* @@ -81,7 +82,7 @@ static ProcessGlobalValue executableName = { * in other cases this means an overestimate of the * required size. * - * For more details, see the comments on the Tcl*Scan*Element and + * For more details, see the comments on the Tcl*Scan*Element and * Tcl*Convert*Element routines. */ @@ -106,23 +107,31 @@ static Tcl_ThreadDataKey precisionKey; static void ClearHash(Tcl_HashTable *tablePtr); static void FreeProcessGlobalValue(ClientData clientData); static void FreeThreadHash(ClientData clientData); +static int GetEndOffsetFromObj(Tcl_Obj *objPtr, int endValue, + int *indexPtr); static Tcl_HashTable * GetThreadHash(Tcl_ThreadDataKey *keyPtr); static int SetEndOffsetFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); -static void UpdateStringOfEndOffset(Tcl_Obj *objPtr); - +static int FindElement(Tcl_Interp *interp, const char *string, + int stringLength, const char *typeStr, + const char *typeCode, const char **elementPtr, + const char **nextPtr, int *sizePtr, + int *literalPtr); /* * The following is the Tcl object type definition for an object that * represents a list index in the form, "end-offset". It is used as a - * performance optimization in TclGetIntForIndex. The internal rep is an - * integer, so no memory management is required for it. + * performance optimization in TclGetIntForIndex. The internal rep is + * stored directly in the wideValue, so no memory management is required + * for it. This is a caching intrep, keeping the result of a parse + * around. This type is only created from a pre-existing string, so an + * updateStringProc will never be called and need not exist. */ -const Tcl_ObjType tclEndOffsetType = { +static const Tcl_ObjType endOffsetType = { "end-offset", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ - UpdateStringOfEndOffset, /* updateStringProc */ + NULL, /* updateStringProc */ SetEndOffsetFromAny }; @@ -175,7 +184,7 @@ const Tcl_ObjType tclEndOffsetType = { * * NOTE: This means that if and when backslash substitution rules ever change * for command parsing, the interpretation of strings as lists also changes. - * + * * Backslash substitution replaces an "escape sequence" of one or more * characters starting with * \u005c \ BACKSLASH @@ -188,7 +197,7 @@ const Tcl_ObjType tclEndOffsetType = { * * * If the first character of a formatted substring is * \u007b { OPEN BRACE - * then the end of the substring is the matching + * then the end of the substring is the matching * \u007d } CLOSE BRACE * character, where matching is determined by counting nesting levels, and * not including any brace characters that are contained within a backslash @@ -210,7 +219,7 @@ const Tcl_ObjType tclEndOffsetType = { * includes an unbalanced brace not in a backslash escape sequence, and any * value that ends with a backslash not itself in a backslash escape * sequence. - * + * * * If the first character of a formatted substring is * \u0022 " QUOTE * then the end of the substring is the next QUOTE character, not counting @@ -236,7 +245,7 @@ const Tcl_ObjType tclEndOffsetType = { * of either braces or quotes to delimit it. * * This collection of parsing rules is implemented in the routine - * TclFindElement(). + * FindElement(). * * In order to produce lists that can be parsed by these rules, we need the * ability to distinguish between characters that are part of a list element @@ -337,7 +346,7 @@ const Tcl_ObjType tclEndOffsetType = { * directives. This makes it easy to experiment with eliminating this * formatting mode simply with "#define COMPAT 0" above. I believe this is * worth considering. - * + * * Another consideration is the treatment of QUOTE characters in list * elements. TclConvertElement() must have the ability to produce the escape * sequence \" so that when a list element begins with a QUOTE we do not @@ -397,7 +406,7 @@ TclMaxListLength( * No list element before leading white space. */ - count += 1 - TclIsSpaceProc(*bytes); + count += 1 - TclIsSpaceProc(*bytes); /* * Count white space runs as potential element separators. @@ -433,7 +442,7 @@ TclMaxListLength( * No list element following trailing white space. */ - count -= TclIsSpaceProc(bytes[-1]); + count -= TclIsSpaceProc(bytes[-1]); done: if (endPtr) { @@ -501,12 +510,73 @@ TclFindElement( * indicate that the substring of *sizePtr * bytes starting at **elementPtr is/is not * the literal list element and therefore - * does not/does require a call to + * does not/does require a call to + * TclCopyAndCollapse() by the caller. */ +{ + return FindElement(interp, list, listLength, "list", "LIST", elementPtr, + nextPtr, sizePtr, literalPtr); +} + +int +TclFindDictElement( + Tcl_Interp *interp, /* Interpreter to use for error reporting. If + * NULL, then no error message is left after + * errors. */ + const char *dict, /* Points to the first byte of a string + * containing a Tcl dictionary with zero or + * more keys and values (possibly in + * braces). */ + int dictLength, /* Number of bytes in the dict's string. */ + const char **elementPtr, /* Where to put address of first significant + * character in the first element (i.e., key + * or value) of dict. */ + const char **nextPtr, /* Fill in with location of character just + * after all white space following end of + * element (next arg or end of list). */ + int *sizePtr, /* If non-zero, fill in with size of + * element. */ + int *literalPtr) /* If non-zero, fill in with non-zero/zero to + * indicate that the substring of *sizePtr + * bytes starting at **elementPtr is/is not + * the literal key or value and therefore + * does not/does require a call to + * TclCopyAndCollapse() by the caller. */ +{ + return FindElement(interp, dict, dictLength, "dict", "DICTIONARY", + elementPtr, nextPtr, sizePtr, literalPtr); +} + +static int +FindElement( + Tcl_Interp *interp, /* Interpreter to use for error reporting. If + * NULL, then no error message is left after + * errors. */ + const char *string, /* Points to the first byte of a string + * containing a Tcl list or dictionary with + * zero or more elements (possibly in + * braces). */ + int stringLength, /* Number of bytes in the string. */ + const char *typeStr, /* The name of the type of thing we are + * parsing, for error messages. */ + const char *typeCode, /* The type code for thing we are parsing, for + * error messages. */ + const char **elementPtr, /* Where to put address of first significant + * character in first element. */ + const char **nextPtr, /* Fill in with location of character just + * after all white space following end of + * argument (next arg or end of list/dict). */ + int *sizePtr, /* If non-zero, fill in with size of + * element. */ + int *literalPtr) /* If non-zero, fill in with non-zero/zero to + * indicate that the substring of *sizePtr + * bytes starting at **elementPtr is/is not + * the literal list/dict element and therefore + * does not/does require a call to * TclCopyAndCollapse() by the caller. */ { - const char *p = list; + const char *p = string; const char *elemStart; /* Points to first byte of first element. */ - const char *limit; /* Points just after list's last byte. */ + const char *limit; /* Points just after list/dict's last byte. */ int openBraces = 0; /* Brace nesting level during parse. */ int inQuotes = 0; int size = 0; /* lint. */ @@ -516,11 +586,11 @@ TclFindElement( /* * Skim off leading white space and check for an opening brace or quote. - * We treat embedded NULLs in the list as bytes belonging to a list - * element. + * We treat embedded NULLs in the list/dict as bytes belonging to a list + * element (or dictionary key or value). */ - limit = (list + listLength); + limit = (string + stringLength); while ((p < limit) && (TclIsSpaceProc(*p))) { p++; } @@ -581,9 +651,9 @@ TclFindElement( p2++; } Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "list element in braces followed by \"%.*s\" " - "instead of space", (int) (p2-p), p)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "JUNK", + "%s element in braces followed by \"%.*s\" " + "instead of space", typeStr, (int) (p2-p), p)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "JUNK", NULL); } return TCL_ERROR; @@ -650,9 +720,9 @@ TclFindElement( p2++; } Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "list element in quotes followed by \"%.*s\" " - "instead of space", (int) (p2-p), p)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "JUNK", + "%s element in quotes followed by \"%.*s\" " + "instead of space", typeStr, (int) (p2-p), p)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "JUNK", NULL); } return TCL_ERROR; @@ -663,23 +733,23 @@ TclFindElement( } /* - * End of list: terminate element. + * End of list/dict: terminate element. */ if (p == limit) { if (openBraces != 0) { if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "unmatched open brace in list", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "BRACE", + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unmatched open brace in %s", typeStr)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "BRACE", NULL); } return TCL_ERROR; } else if (inQuotes) { if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "unmatched open quote in list", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "QUOTE", + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unmatched open quote in %s", typeStr)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "QUOTE", NULL); } return TCL_ERROR; @@ -908,7 +978,7 @@ Tcl_ScanCountedElement( int *flagPtr) /* Where to store information to guide * Tcl_ConvertElement. */ { - int flags = CONVERT_ANY; + char flags = CONVERT_ANY; int numBytes = TclScanElement(src, length, &flags); *flagPtr = flags; @@ -949,7 +1019,7 @@ int TclScanElement( const char *src, /* String to convert to Tcl list element. */ int length, /* Number of bytes in src, or -1. */ - int *flagPtr) /* Where to store information to guide + char *flagPtr) /* Where to store information to guide * Tcl_ConvertElement. */ { const char *p = src; @@ -968,7 +1038,7 @@ TclScanElement( int preferBrace = 0; /* CONVERT_MASK mode. */ int braceCount = 0; /* Count of all braces '{' '}' seen. */ #endif /* COMPAT */ - + if ((p == NULL) || (length == 0) || ((*p == '\0') && (length == -1))) { /* * Empty string element must be brace quoted. @@ -1046,7 +1116,7 @@ TclScanElement( * Final backslash. Cannot format with brace quoting. */ - requireEscape = 1; + requireEscape = 1; break; } if (p[1] == '\n') { @@ -1318,7 +1388,7 @@ TclConvertElement( */ if ((src == NULL) || (length == 0) || (*src == '\0' && length == -1)) { - src = tclEmptyStringRep; + src = &tclEmptyString; length = 0; conversion = CONVERT_BRACE; } @@ -1440,7 +1510,7 @@ TclConvertElement( return p - dst; } - /* + /* * If we reach this point, there's an embedded NULL in the string * range being processed, which should not happen when the * encoding rules for Tcl strings are properly followed. If the @@ -1481,11 +1551,10 @@ Tcl_Merge( int argc, /* How many strings to merge. */ const char *const *argv) /* Array of string values. */ { -#define LOCAL_SIZE 20 - int localFlags[LOCAL_SIZE], *flagPtr = NULL; +#define LOCAL_SIZE 64 + char localFlags[LOCAL_SIZE], *flagPtr = NULL; int i, bytesNeeded = 0; char *result, *dst; - const int maxFlags = UINT_MAX / sizeof(int); /* * Handle empty list case first, so logic of the general case can be @@ -1504,22 +1573,8 @@ Tcl_Merge( if (argc <= LOCAL_SIZE) { flagPtr = localFlags; - } else if (argc > maxFlags) { - /* - * We cannot allocate a large enough flag array to format this list in - * one pass. We could imagine converting this routine to a multi-pass - * implementation, but for sizeof(int) == 4, the limit is a max of - * 2^30 list elements and since each element is at least one byte - * formatted, and requires one byte space between it and the next one, - * that a minimum space requirement of 2^31 bytes, which is already - * INT_MAX. If we tried to format a list of > maxFlags elements, we're - * just going to overflow the size limits on the formatted string - * anyway, so just issue that same panic early. - */ - - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } else { - flagPtr = ckalloc(argc * sizeof(int)); + flagPtr = ckalloc(argc); } for (i = 0; i < argc; i++) { flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 ); @@ -1553,6 +1608,7 @@ Tcl_Merge( return result; } +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 /* *---------------------------------------------------------------------- * @@ -1580,21 +1636,57 @@ Tcl_Backslash( * src, unless NULL. */ { char buf[TCL_UTF_MAX]; - Tcl_UniChar ch; + Tcl_UniChar ch = 0; Tcl_UtfBackslash(src, readPtr, buf); TclUtfToUniChar(buf, &ch); return (char) ch; } +#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- * - * TclTrimRight -- + * UtfWellFormedEnd -- + * Checks the end of utf string is malformed, if yes - wraps bytes + * to the given buffer (as well-formed NTS string). The buffer + * argument should be initialized by the caller and ready to use. * - * Takes two counted strings in the Tcl encoding which must both be null - * terminated. Conceptually trims from the right side of the first string - * all characters found in the second string. + * Results: + * The bytes with well-formed end of the string. + * + * Side effects: + * Buffer (DString) may be allocated, so must be released. + * + *---------------------------------------------------------------------- + */ + +static inline const char* +UtfWellFormedEnd( + Tcl_DString *buffer, /* Buffer used to hold well-formed string. */ + const char *bytes, /* Pointer to the beginning of the string. */ + int length) /* Length of the string. */ +{ + const char *l = bytes + length; + const char *p = Tcl_UtfPrev(l, bytes); + + if (Tcl_UtfCharComplete(p, l - p)) { + return bytes; + } + /* + * Malformed utf-8 end, be sure we've NTS to safe compare of end-character, + * avoid segfault by access violation out of range. + */ + Tcl_DStringAppend(buffer, bytes, length); + return Tcl_DStringValue(buffer); +} +/* + *---------------------------------------------------------------------- + * + * TclTrimRight -- + * Takes two counted strings in the Tcl encoding. Conceptually + * finds the sub string (offset) to trim from the right side of the + * first string all characters found in the second string. * * Results: * The number of bytes to be removed from the end of the string. @@ -1605,8 +1697,8 @@ Tcl_Backslash( *---------------------------------------------------------------------- */ -int -TclTrimRight( +static inline int +TrimRight( const char *bytes, /* String to be trimmed... */ int numBytes, /* ...and its length in bytes */ const char *trim, /* String of trim characters... */ @@ -1614,25 +1706,13 @@ TclTrimRight( { const char *p = bytes + numBytes; int pInc; - - if ((bytes[numBytes] != '\0') || (trim[numTrim] != '\0')) { - Tcl_Panic("TclTrimRight works only on null-terminated strings"); - } - - /* - * Empty strings -> nothing to do. - */ - - if ((numBytes == 0) || (numTrim == 0)) { - return 0; - } + Tcl_UniChar ch1 = 0, ch2 = 0; /* * Outer loop: iterate over string to be trimmed. */ do { - Tcl_UniChar ch1; const char *q = trim; int bytesLeft = numTrim; @@ -1644,7 +1724,6 @@ TclTrimRight( */ do { - Tcl_UniChar ch2; int qInc = TclUtfToUniChar(q, &ch2); if (ch1 == ch2) { @@ -1667,15 +1746,46 @@ TclTrimRight( return numBytes - (p - bytes); } + +int +TclTrimRight( + const char *bytes, /* String to be trimmed... */ + int numBytes, /* ...and its length in bytes */ + const char *trim, /* String of trim characters... */ + int numTrim) /* ...and its length in bytes */ +{ + int res; + Tcl_DString bytesBuf, trimBuf; + + /* Empty strings -> nothing to do */ + if ((numBytes == 0) || (numTrim == 0)) { + return 0; + } + + Tcl_DStringInit(&bytesBuf); + Tcl_DStringInit(&trimBuf); + bytes = UtfWellFormedEnd(&bytesBuf, bytes, numBytes); + trim = UtfWellFormedEnd(&trimBuf, trim, numTrim); + + res = TrimRight(bytes, numBytes, trim, numTrim); + if (res > numBytes) { + res = numBytes; + } + + Tcl_DStringFree(&bytesBuf); + Tcl_DStringFree(&trimBuf); + + return res; +} /* *---------------------------------------------------------------------- * * TclTrimLeft -- * - * Takes two counted strings in the Tcl encoding which must both be null - * terminated. Conceptually trims from the left side of the first string - * all characters found in the second string. + * Takes two counted strings in the Tcl encoding. Conceptually + * finds the sub string (offset) to trim from the left side of the + * first string all characters found in the second string. * * Results: * The number of bytes to be removed from the start of the string. @@ -1686,33 +1796,21 @@ TclTrimRight( *---------------------------------------------------------------------- */ -int -TclTrimLeft( +static inline int +TrimLeft( const char *bytes, /* String to be trimmed... */ int numBytes, /* ...and its length in bytes */ const char *trim, /* String of trim characters... */ int numTrim) /* ...and its length in bytes */ { const char *p = bytes; - - if ((bytes[numBytes] != '\0') || (trim[numTrim] != '\0')) { - Tcl_Panic("TclTrimLeft works only on null-terminated strings"); - } - - /* - * Empty strings -> nothing to do. - */ - - if ((numBytes == 0) || (numTrim == 0)) { - return 0; - } + Tcl_UniChar ch1 = 0, ch2 = 0; /* * Outer loop: iterate over string to be trimmed. */ do { - Tcl_UniChar ch1; int pInc = TclUtfToUniChar(p, &ch1); const char *q = trim; int bytesLeft = numTrim; @@ -1722,7 +1820,6 @@ TclTrimLeft( */ do { - Tcl_UniChar ch2; int qInc = TclUtfToUniChar(q, &ch2); if (ch1 == ch2) { @@ -1743,10 +1840,99 @@ TclTrimLeft( p += pInc; numBytes -= pInc; - } while (numBytes); + } while (numBytes > 0); return p - bytes; } + +int +TclTrimLeft( + const char *bytes, /* String to be trimmed... */ + int numBytes, /* ...and its length in bytes */ + const char *trim, /* String of trim characters... */ + int numTrim) /* ...and its length in bytes */ +{ + int res; + Tcl_DString bytesBuf, trimBuf; + + /* Empty strings -> nothing to do */ + if ((numBytes == 0) || (numTrim == 0)) { + return 0; + } + + Tcl_DStringInit(&bytesBuf); + Tcl_DStringInit(&trimBuf); + bytes = UtfWellFormedEnd(&bytesBuf, bytes, numBytes); + trim = UtfWellFormedEnd(&trimBuf, trim, numTrim); + + res = TrimLeft(bytes, numBytes, trim, numTrim); + if (res > numBytes) { + res = numBytes; + } + + Tcl_DStringFree(&bytesBuf); + Tcl_DStringFree(&trimBuf); + + return res; +} + +/* + *---------------------------------------------------------------------- + * + * TclTrim -- + * Finds the sub string (offset) to trim from both sides of the + * first string all characters found in the second string. + * + * Results: + * The number of bytes to be removed from the start of the string + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclTrim( + const char *bytes, /* String to be trimmed... */ + int numBytes, /* ...and its length in bytes */ + const char *trim, /* String of trim characters... */ + int numTrim, /* ...and its length in bytes */ + int *trimRight) /* Offset from the end of the string. */ +{ + int trimLeft; + Tcl_DString bytesBuf, trimBuf; + + *trimRight = 0; + /* Empty strings -> nothing to do */ + if ((numBytes == 0) || (numTrim == 0)) { + return 0; + } + + Tcl_DStringInit(&bytesBuf); + Tcl_DStringInit(&trimBuf); + bytes = UtfWellFormedEnd(&bytesBuf, bytes, numBytes); + trim = UtfWellFormedEnd(&trimBuf, trim, numTrim); + + trimLeft = TrimLeft(bytes, numBytes, trim, numTrim); + if (trimLeft > numBytes) { + trimLeft = numBytes; + } + numBytes -= trimLeft; + /* have to trim yet (first char was already verified within TrimLeft) */ + if (numBytes > 1) { + bytes += trimLeft; + *trimRight = TrimRight(bytes, numBytes, trim, numTrim); + if (*trimRight > numBytes) { + *trimRight = numBytes; + } + } + + Tcl_DStringFree(&bytesBuf); + Tcl_DStringFree(&trimBuf); + + return trimLeft; +} /* *---------------------------------------------------------------------- @@ -1768,8 +1954,7 @@ TclTrimLeft( */ /* The whitespace characters trimmed during [concat] operations */ -#define CONCAT_WS " \f\v\r\t\n" -#define CONCAT_WS_SIZE (int) (sizeof(CONCAT_WS "") - 1) +#define CONCAT_WS_SIZE (int) (sizeof(CONCAT_TRIM_SET "") - 1) char * Tcl_Concat( @@ -1815,28 +2000,20 @@ Tcl_Concat( result = ckalloc((unsigned) (bytesNeeded + argc)); for (p = result, i = 0; i < argc; i++) { - int trim, elemLength; + int triml, trimr, elemLength; const char *element; - + element = argv[i]; elemLength = strlen(argv[i]); - /* - * Trim away the leading whitespace. - */ - - trim = TclTrimLeft(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); - element += trim; - elemLength -= trim; - - /* - * Trim away the trailing whitespace. Do not permit trimming to expose - * a final backslash character. - */ + /* Trim away the leading/trailing whitespace. */ + triml = TclTrim(element, elemLength, CONCAT_TRIM_SET, + CONCAT_WS_SIZE, &trimr); + element += triml; + elemLength -= triml + trimr; - trim = TclTrimRight(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); - trim -= trim && (element[elemLength - trim - 1] == '\\'); - elemLength -= trim; + /* Do not permit trimming to expose a final backslash character. */ + elemLength += trimr && (element[elemLength - 1] == '\\'); /* * If we're left with empty element after trimming, do nothing. @@ -1901,7 +2078,7 @@ Tcl_ConcatObj( if (TclListObjIsCanonical(objPtr)) { continue; } - Tcl_GetStringFromObj(objPtr, &length); + TclGetStringFromObj(objPtr, &length); if (length > 0) { break; } @@ -1914,7 +2091,11 @@ Tcl_ConcatObj( continue; } if (resPtr) { - Tcl_ListObjAppendList(NULL, resPtr, objPtr); + if (TCL_OK != Tcl_ListObjAppendList(NULL, resPtr, objPtr)) { + /* Abandon ship! */ + Tcl_DecrRefCount(resPtr); + goto slow; + } } else { resPtr = TclListObjCopy(NULL, objPtr); } @@ -1925,6 +2106,7 @@ Tcl_ConcatObj( return resPtr; } + slow: /* * Something cannot be determined to be safe, so build the concatenation * the slow way, using the string representations. @@ -1947,30 +2129,22 @@ Tcl_ConcatObj( */ TclNewObj(resPtr); - Tcl_AttemptSetObjLength(resPtr, bytesNeeded + objc - 1); + (void) Tcl_AttemptSetObjLength(resPtr, bytesNeeded + objc - 1); Tcl_SetObjLength(resPtr, 0); for (i = 0; i < objc; i++) { - int trim; - - element = TclGetStringFromObj(objv[i], &elemLength); + int triml, trimr; - /* - * Trim away the leading whitespace. - */ - - trim = TclTrimLeft(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); - element += trim; - elemLength -= trim; + element = TclGetStringFromObj(objv[i], &elemLength); - /* - * Trim away the trailing whitespace. Do not permit trimming to expose - * a final backslash character. - */ + /* Trim away the leading/trailing whitespace. */ + triml = TclTrim(element, elemLength, CONCAT_TRIM_SET, + CONCAT_WS_SIZE, &trimr); + element += triml; + elemLength -= triml + trimr; - trim = TclTrimRight(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); - trim -= trim && (element[elemLength - trim - 1] == '\\'); - elemLength -= trim; + /* Do not permit trimming to expose a final backslash character. */ + elemLength += trimr && (element[elemLength - 1] == '\\'); /* * If we're left with empty element after trimming, do nothing. @@ -2048,7 +2222,7 @@ Tcl_StringCaseMatch( { int p, charLen; const char *pstart = pattern; - Tcl_UniChar ch1, ch2; + Tcl_UniChar ch1 = 0, ch2 = 0; while (1) { p = *pattern; @@ -2158,7 +2332,7 @@ Tcl_StringCaseMatch( */ if (p == '[') { - Tcl_UniChar startChar, endChar; + Tcl_UniChar startChar = 0, endChar = 0; pattern++; if (UCHAR(*str) < 0x80) { @@ -2471,7 +2645,8 @@ TclStringMatchObj( udata = Tcl_GetUnicodeFromObj(strObj, &length); uptn = Tcl_GetUnicodeFromObj(ptnObj, &plen); match = TclUniCharMatch(udata, length, uptn, plen, flags); - } else if (TclIsPureByteArray(strObj) && !flags) { + } else if (TclIsPureByteArray(strObj) && TclIsPureByteArray(ptnObj) + && !flags) { unsigned char *data, *ptn; data = Tcl_GetByteArrayFromObj(strObj, &length); @@ -2560,7 +2735,19 @@ Tcl_DStringAppend( memcpy(newString, dsPtr->string, (size_t) dsPtr->length); dsPtr->string = newString; } else { + int offset = -1; + + /* See [16896d49fd] */ + if (bytes >= dsPtr->string + && bytes <= dsPtr->string + dsPtr->length) { + offset = bytes - dsPtr->string; + } + dsPtr->string = ckrealloc(dsPtr->string, dsPtr->spaceAvl); + + if (offset >= 0) { + bytes = dsPtr->string + offset; + } } } @@ -2591,7 +2778,7 @@ TclDStringAppendObj( Tcl_Obj *objPtr) { int length; - char *bytes = Tcl_GetStringFromObj(objPtr, &length); + char *bytes = TclGetStringFromObj(objPtr, &length); return Tcl_DStringAppend(dsPtr, bytes, length); } @@ -2631,7 +2818,7 @@ Tcl_DStringAppendElement( { char *dst = dsPtr->string + dsPtr->length; int needSpace = TclNeedSpace(dsPtr->string, dst); - int flags = needSpace ? TCL_DONT_QUOTE_HASH : 0; + char flags = needSpace ? TCL_DONT_QUOTE_HASH : 0; int newSize = dsPtr->length + needSpace + TclScanElement(element, -1, &flags); @@ -2651,7 +2838,19 @@ Tcl_DStringAppendElement( memcpy(newString, dsPtr->string, (size_t) dsPtr->length); dsPtr->string = newString; } else { + int offset = -1; + + /* See [16896d49fd] */ + if (element >= dsPtr->string + && element <= dsPtr->string + dsPtr->length) { + offset = element - dsPtr->string; + } + dsPtr->string = ckrealloc(dsPtr->string, dsPtr->spaceAvl); + + if (offset >= 0) { + element = dsPtr->string + offset; + } } dst = dsPtr->string + dsPtr->length; } @@ -2796,7 +2995,6 @@ Tcl_DStringResult( Tcl_DString *dsPtr) /* Dynamic string that is to become the * result of interp. */ { - Tcl_ResetResult(interp); Tcl_SetObjResult(interp, TclDStringToObj(dsPtr)); } @@ -2826,6 +3024,14 @@ Tcl_DStringGetResult( Tcl_DString *dsPtr) /* Dynamic string that is to become the result * of interp. */ { +#ifdef TCL_NO_DEPRECATED + Tcl_Obj *obj = Tcl_GetObjResult(interp); + const char *bytes = TclGetString(obj); + + Tcl_DStringFree(dsPtr); + Tcl_DStringAppend(dsPtr, bytes, obj->length); + Tcl_ResetResult(interp); +#else Interp *iPtr = (Interp *) interp; if (dsPtr->string != dsPtr->staticSpace) { @@ -2834,7 +3040,7 @@ Tcl_DStringGetResult( /* * Do more efficient transfer when we know the result is a Tcl_Obj. When - * there's no st`ring result, we only have to deal with two cases: + * there's no string result, we only have to deal with two cases: * * 1. When the string rep is the empty string, when we don't copy but * instead use the staticSpace in the DString to hold an empty string. @@ -2849,17 +3055,17 @@ Tcl_DStringGetResult( if (!iPtr->result[0] && iPtr->objResultPtr && !Tcl_IsShared(iPtr->objResultPtr)) { - if (iPtr->objResultPtr->bytes == tclEmptyStringRep) { + if (iPtr->objResultPtr->bytes == &tclEmptyString) { dsPtr->string = dsPtr->staticSpace; dsPtr->string[0] = 0; dsPtr->length = 0; dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; } else { - dsPtr->string = Tcl_GetString(iPtr->objResultPtr); + dsPtr->string = TclGetString(iPtr->objResultPtr); dsPtr->length = iPtr->objResultPtr->length; dsPtr->spaceAvl = dsPtr->length + 1; TclFreeIntRep(iPtr->objResultPtr); - iPtr->objResultPtr->bytes = tclEmptyStringRep; + iPtr->objResultPtr->bytes = &tclEmptyString; iPtr->objResultPtr->length = 0; } return; @@ -2897,6 +3103,7 @@ Tcl_DStringGetResult( iPtr->result = iPtr->resultSpace; iPtr->resultSpace[0] = 0; +#endif /* !TCL_NO_DEPRECATED */ } /* @@ -2934,7 +3141,7 @@ TclDStringToObj( /* * Static buffer, so must copy. */ - + TclNewStringObj(result, dsPtr->string, dsPtr->length); } } else { @@ -3047,12 +3254,12 @@ Tcl_PrintDouble( int signum; char *digits; char *end; - int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int) sizeof(int)); + int *precisionPtr = Tcl_GetThreadData(&precisionKey, sizeof(int)); /* * Handle NaN. */ - + if (TclIsNaN(value)) { TclFormatNaN(value, dst); return; @@ -3061,12 +3268,12 @@ Tcl_PrintDouble( /* * Handle infinities. */ - + if (TclIsInfinite(value)) { /* * Remember to copy the terminating NUL too. */ - + if (value < 0) { memcpy(dst, "-Inf", 5); } else { @@ -3078,7 +3285,7 @@ Tcl_PrintDouble( /* * Ordinary (normal and denormal) values. */ - + if (*precisionPtr == 0) { digits = TclDoubleDigits(value, -1, TCL_DD_SHORTEST, &exponent, &signum, &end); @@ -3123,7 +3330,7 @@ Tcl_PrintDouble( */ digits = TclDoubleDigits(value, *precisionPtr, - TCL_DD_E_FORMAT /* | TCL_DD_SHORTEN_FLAG */, + TCL_DD_E_FORMAT /* | TCL_DD_SHORTEN_FLAG */, &exponent, &signum, &end); } if (signum) { @@ -3134,7 +3341,7 @@ Tcl_PrintDouble( /* * E format for numbers < 1e-3 or >= 1e17. */ - + *dst++ = *p++; c = *p; if (c != '\0') { @@ -3159,7 +3366,7 @@ Tcl_PrintDouble( /* * F format for others. */ - + if (exponent < 0) { *dst++ = '0'; } @@ -3209,6 +3416,7 @@ Tcl_PrintDouble( *---------------------------------------------------------------------- */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 /* ARGSUSED */ char * TclPrecTraceProc( @@ -3220,7 +3428,7 @@ TclPrecTraceProc( { Tcl_Obj *value; int prec; - int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int) sizeof(int)); + int *precisionPtr = Tcl_GetThreadData(&precisionKey, sizeof(int)); /* * If the variable is unset, then recreate the trace. @@ -3266,6 +3474,7 @@ TclPrecTraceProc( *precisionPtr = prec; return NULL; } +#endif /* !TCL_NO_DEPRECATED)*/ /* *---------------------------------------------------------------------- @@ -3383,9 +3592,9 @@ int TclFormatInt( char *buffer, /* Points to the storage into which the * formatted characters are written. */ - long n) /* The integer to format. */ + Tcl_WideInt n) /* The integer to format. */ { - long intVal; + Tcl_WideInt intVal; int i; int numFormatted, j; const char *digits = "0123456789"; @@ -3408,7 +3617,7 @@ TclFormatInt( intVal = -n; /* [Bug 3390638] Workaround for*/ if (n == -n || intVal == n) { /* broken compiler optimizers. */ - return sprintf(buffer, "%ld", n); + return sprintf(buffer, "%" TCL_LL_MODIFIER "d", n); } /* @@ -3478,7 +3687,7 @@ TclGetIntForIndex( int *indexPtr) /* Location filled in with an integer * representing an index. */ { - int length; + size_t length; char *opPtr; const char *bytes; @@ -3486,17 +3695,12 @@ TclGetIntForIndex( return TCL_OK; } - 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; + if (GetEndOffsetFromObj(objPtr, endValue, indexPtr) == TCL_OK) { return TCL_OK; } - bytes = TclGetStringFromObj(objPtr, &length); + bytes = TclGetString(objPtr); + length = objPtr->length; /* * Leading whitespace is acceptable in an index. @@ -3541,7 +3745,7 @@ TclGetIntForIndex( parseError: if (interp != NULL) { - bytes = Tcl_GetString(objPtr); + bytes = TclGetString(objPtr); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad index \"%s\": must be integer?[+-]integer? or" " end?[+-]integer?", bytes)); @@ -3558,41 +3762,38 @@ TclGetIntForIndex( /* *---------------------------------------------------------------------- * - * UpdateStringOfEndOffset -- + * GetEndOffsetFromObj -- * - * Update the string rep of a Tcl object holding an "end-offset" - * expression. + * Look for a string of the form "end[+-]offset" and convert it to an + * internal representation holding the offset. * * Results: - * None. + * Tcl return code. * * Side effects: - * Stores a valid string in the object's string rep. - * - * This function does NOT free any earlier string rep. If it is called on an - * object that already has a valid string rep, it will leak memory. + * May store a Tcl_ObjType. * *---------------------------------------------------------------------- */ -static void -UpdateStringOfEndOffset( - register Tcl_Obj *objPtr) +static int +GetEndOffsetFromObj( + Tcl_Obj *objPtr, /* Pointer to the object to parse */ + int endValue, /* The value to be stored at "indexPtr" if + * "objPtr" holds "end". */ + int *indexPtr) /* Location filled in with an integer + * representing an index. */ { - char buffer[TCL_INTEGER_SPACE + 5]; - register int len; - - memcpy(buffer, "end", 4); - len = sizeof("end") - 1; - if (objPtr->internalRep.longValue != 0) { - buffer[len++] = '-'; - len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue)); + if (SetEndOffsetFromAny(NULL, objPtr) != TCL_OK) { + return TCL_ERROR; } - objPtr->bytes = ckalloc((unsigned) len+1); - memcpy(objPtr->bytes, buffer, (unsigned) len+1); - objPtr->length = len; + + /* TODO: Handle overflow cases sensibly */ + *indexPtr = endValue + (int)objPtr->internalRep.wideValue; + return TCL_OK; } - + + /* *---------------------------------------------------------------------- * @@ -3616,7 +3817,7 @@ SetEndOffsetFromAny( Tcl_Interp *interp, /* Tcl interpreter or NULL */ Tcl_Obj *objPtr) /* Pointer to the object to parse */ { - int offset; /* Offset in the "end-offset" expression */ + Tcl_WideInt offset; /* Offset in the "end-offset" expression */ register const char *bytes; /* String rep of the object */ int length; /* Length of the object's string rep */ @@ -3624,7 +3825,7 @@ SetEndOffsetFromAny( * If it's already the right type, we're fine. */ - if (objPtr->typePtr == &tclEndOffsetType) { + if (objPtr->typePtr == &endOffsetType) { return TCL_OK; } @@ -3652,16 +3853,23 @@ SetEndOffsetFromAny( } else if ((length > 4) && ((bytes[3] == '-') || (bytes[3] == '+'))) { /* * This is our limited string expression evaluator. Pass everything - * after "end-" to Tcl_GetInt, then reverse for offset. + * after "end-" to TclParseNumber. */ if (TclIsSpaceProc(bytes[4])) { goto badIndexFormat; } - if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) { + if (TclParseNumber(NULL, objPtr, NULL, bytes+4, length-4, NULL, + TCL_PARSE_INTEGER_ONLY) != TCL_OK) { return TCL_ERROR; } + if (objPtr->typePtr != &tclIntType) { + goto badIndexFormat; + } + offset = objPtr->internalRep.wideValue; if (bytes[3] == '-') { + + /* TODO: Review overflow concerns here! */ offset = -offset; } } else { @@ -3684,8 +3892,8 @@ SetEndOffsetFromAny( */ TclFreeIntRep(objPtr); - objPtr->internalRep.longValue = offset; - objPtr->typePtr = &tclEndOffsetType; + objPtr->internalRep.wideValue = offset; + objPtr->typePtr = &endOffsetType; return TCL_OK; } @@ -3693,6 +3901,143 @@ SetEndOffsetFromAny( /* *---------------------------------------------------------------------- * + * TclIndexEncode -- + * + * Parse objPtr to determine if it is an index value. Two cases + * are possible. The value objPtr might be parsed as an absolute + * index value in the C signed int range. Note that this includes + * index values that are integers as presented and it includes index + * arithmetic expressions. The absolute index values that can be + * directly meaningful as an index into either a list or a string are + * those integer values >= TCL_INDEX_START (0) + * and < TCL_INDEX_AFTER (INT_MAX). + * The largest string supported in Tcl 8 has bytelength INT_MAX. + * This means the largest supported character length is also INT_MAX, + * and the index of the last character in a string of length INT_MAX + * is INT_MAX-1. + * + * Any absolute index value parsed outside that range is encoded + * using the before and after values passed in by the + * caller as the encoding to use for indices that are either + * less than or greater than the usable index range. TCL_INDEX_AFTER + * is available as a good choice for most callers to use for + * after. Likewise, the value TCL_INDEX_BEFORE is good for + * most callers to use for before. Other values are possible + * when the caller knows it is helpful in producing its own behavior + * for indices before and after the indexed item. + * + * A token can also be parsed as an end-relative index expression. + * All end-relative expressions that indicate an index larger + * than end (end+2, end--5) point beyond the end of the indexed + * collection, and can be encoded as after. The end-relative + * expressions that indicate an index less than or equal to end + * are encoded relative to the value TCL_INDEX_END (-2). The + * index "end" is encoded as -2, down to the index "end-0x7ffffffe" + * which is encoded as INT_MIN. Since the largest index into a + * string possible in Tcl 8 is 0x7ffffffe, the interpretation of + * "end-0x7ffffffe" for that largest string would be 0. Thus, + * if the tokens "end-0x7fffffff" or "end+-0x80000000" are parsed, + * they can be encoded with the before value. + * + * These details will require re-examination whenever string and + * list length limits are increased, but that will likely also + * mean a revised routine capable of returning Tcl_WideInt values. + * + * Returns: + * TCL_OK if parsing succeeded, and TCL_ERROR if it failed. + * + * Side effects: + * When TCL_OK is returned, the encoded index value is written + * to *indexPtr. + * + *---------------------------------------------------------------------- + */ + +int +TclIndexEncode( + Tcl_Interp *interp, /* For error reporting, may be NULL */ + Tcl_Obj *objPtr, /* Index value to parse */ + int before, /* Value to return for index before beginning */ + int after, /* Value to return for index after end */ + int *indexPtr) /* Where to write the encoded answer, not NULL */ +{ + int idx; + + if (TCL_OK == TclGetIntFromObj(NULL, objPtr, &idx)) { + /* We parsed a value in the range INT_MIN...INT_MAX */ + integerEncode: + if (idx < TCL_INDEX_START) { + /* All negative absolute indices are "before the beginning" */ + idx = before; + } else if (idx == INT_MAX) { + /* This index value is always "after the end" */ + idx = after; + } + /* usual case, the absolute index value encodes itself */ + } else if (TCL_OK == GetEndOffsetFromObj(objPtr, 0, &idx)) { + /* + * We parsed an end+offset index value. + * idx holds the offset value in the range INT_MIN...INT_MAX. + */ + if (idx > 0) { + /* + * All end+postive or end-negative expressions + * always indicate "after the end". + */ + idx = after; + } else if (idx < INT_MIN - TCL_INDEX_END) { + /* These indices always indicate "before the beginning */ + idx = before; + } else { + /* Encoded end-positive (or end+negative) are offset */ + idx += TCL_INDEX_END; + } + + /* TODO: Consider flag to suppress repeated end-offset parse. */ + } else if (TCL_OK == TclGetIntForIndexM(interp, objPtr, 0, &idx)) { + /* + * Only reach this case when the index value is a + * constant index arithmetic expression, and idx + * holds the result. Treat it the same as if it were + * parsed as an absolute integer value. + */ + goto integerEncode; + } else { + return TCL_ERROR; + } + *indexPtr = idx; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclIndexDecode -- + * + * Decodes a value previously encoded by TclIndexEncode. The argument + * endValue indicates what value of "end" should be used in the + * decoding. + * + * Results: + * The decoded index value. + * + *---------------------------------------------------------------------- + */ + +int +TclIndexDecode( + int encoded, /* Value to decode */ + int endValue) /* Meaning of "end" to use, > TCL_INDEX_END */ +{ + if (encoded <= TCL_INDEX_END) { + return (encoded - TCL_INDEX_END) + endValue; + } + return encoded; +} + +/* + *---------------------------------------------------------------------- + * * TclCheckBadOctal -- * * This function checks for a bad octal value and appends a meaningful @@ -3903,9 +4248,10 @@ TclSetProcessGlobalValue( } else { Tcl_CreateExitHandler(FreeProcessGlobalValue, pgvPtr); } - bytes = Tcl_GetStringFromObj(newValue, &pgvPtr->numBytes); + bytes = TclGetString(newValue); + pgvPtr->numBytes = newValue->length; pgvPtr->value = ckalloc(pgvPtr->numBytes + 1); - memcpy(pgvPtr->value, bytes, (unsigned) pgvPtr->numBytes + 1); + memcpy(pgvPtr->value, bytes, pgvPtr->numBytes + 1); if (pgvPtr->encoding) { Tcl_FreeEncoding(pgvPtr->encoding); } @@ -3920,7 +4266,7 @@ TclSetProcessGlobalValue( Tcl_IncrRefCount(newValue); cacheMap = GetThreadHash(&pgvPtr->key); ClearHash(cacheMap); - hPtr = Tcl_CreateHashEntry(cacheMap, INT2PTR(pgvPtr->epoch), &dummy); + hPtr = Tcl_CreateHashEntry(cacheMap, (void *)(size_t)(pgvPtr->epoch), &dummy); Tcl_SetHashValue(hPtr, newValue); Tcl_MutexUnlock(&pgvPtr->mutex); } @@ -3946,7 +4292,7 @@ TclGetProcessGlobalValue( Tcl_Obj *value = NULL; Tcl_HashTable *cacheMap; Tcl_HashEntry *hPtr; - int epoch = pgvPtr->epoch; + unsigned int epoch = pgvPtr->epoch; if (pgvPtr->encoding) { Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL); @@ -3961,8 +4307,7 @@ TclGetProcessGlobalValue( Tcl_DString native, newValue; Tcl_MutexLock(&pgvPtr->mutex); - pgvPtr->epoch++; - epoch = pgvPtr->epoch; + epoch = ++pgvPtr->epoch; Tcl_UtfToExternalDString(pgvPtr->encoding, pgvPtr->value, pgvPtr->numBytes, &native); Tcl_ExternalToUtfDString(current, Tcl_DStringValue(&native), @@ -3981,7 +4326,7 @@ TclGetProcessGlobalValue( } } cacheMap = GetThreadHash(&pgvPtr->key); - hPtr = Tcl_FindHashEntry(cacheMap, (char *) INT2PTR(epoch)); + hPtr = Tcl_FindHashEntry(cacheMap, (void *)(size_t)epoch); if (NULL == hPtr) { int dummy; @@ -4014,7 +4359,7 @@ TclGetProcessGlobalValue( value = Tcl_NewStringObj(pgvPtr->value, pgvPtr->numBytes); hPtr = Tcl_CreateHashEntry(cacheMap, - INT2PTR(pgvPtr->epoch), &dummy); + (void *)(size_t)(pgvPtr->epoch), &dummy); Tcl_MutexUnlock(&pgvPtr->mutex); Tcl_SetHashValue(hPtr, value); Tcl_IncrRefCount(value); @@ -4097,11 +4442,10 @@ TclGetObjNameOfExecutable(void) const char * Tcl_GetNameOfExecutable(void) { - int numBytes; - const char *bytes = - Tcl_GetStringFromObj(TclGetObjNameOfExecutable(), &numBytes); + Tcl_Obj *obj = TclGetObjNameOfExecutable(); + const char *bytes = TclGetString(obj); - if (numBytes == 0) { + if (obj->length == 0) { return NULL; } return bytes; @@ -4181,7 +4525,8 @@ TclReToGlob( const char *reStr, int reStrLen, Tcl_DString *dsPtr, - int *exactPtr) + int *exactPtr, + int *quantifiersFoundPtr) { int anchorLeft, anchorRight, lastIsStar, numStars; char *dsStr, *dsStrStart; @@ -4189,6 +4534,9 @@ TclReToGlob( strEnd = reStr + reStrLen; Tcl_DStringInit(dsPtr); + if (quantifiersFoundPtr != NULL) { + *quantifiersFoundPtr = 0; + } /* * "***=xxx" == "*xxx*", watch for glob-sensitive chars. @@ -4301,6 +4649,9 @@ TclReToGlob( } break; case '.': + if (quantifiersFoundPtr != NULL) { + *quantifiersFoundPtr = 1; + } anchorLeft = 0; /* prevent exact match */ if (p+1 < strEnd) { if (p[1] == '*') { diff --git a/generic/tclVar.c b/generic/tclVar.c index af1a563..4dc227d 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -60,14 +60,12 @@ VarHashCreateVar( Tcl_Obj *key, int *newPtr) { - Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&tablePtr->table, - key, newPtr); + Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&tablePtr->table, key, newPtr); - if (hPtr) { - return VarHashGetValue(hPtr); - } else { + if (!hPtr) { return NULL; } + return VarHashGetValue(hPtr); } #define VarHashFindVar(tablePtr, key) \ @@ -92,11 +90,10 @@ VarHashFirstVar( { Tcl_HashEntry *hPtr = VarHashFirstEntry(tablePtr, searchPtr); - if (hPtr) { - return VarHashGetValue(hPtr); - } else { + if (!hPtr) { return NULL; } + return VarHashGetValue(hPtr); } static inline Var * @@ -105,11 +102,10 @@ VarHashNextVar( { Tcl_HashEntry *hPtr = VarHashNextEntry(searchPtr); - if (hPtr) { - return VarHashGetValue(hPtr); - } else { + if (!hPtr) { return NULL; } + return VarHashGetValue(hPtr); } #define VarHashGetKey(varPtr) \ @@ -149,6 +145,7 @@ static const char *isArrayElement = */ typedef struct ArraySearch { + Tcl_Obj *name; /* Name of this search */ int id; /* Integer id used to distinguish among * multiple concurrent searches for the same * array. */ @@ -173,9 +170,20 @@ typedef struct ArraySearch { static void AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *patternPtr, int includeLinks); +static void ArrayPopulateSearch(Tcl_Interp *interp, + Tcl_Obj *arrayNameObj, Var *varPtr, + ArraySearch *searchPtr); +static void ArrayDoneSearch(Interp *iPtr, Var *varPtr, + ArraySearch *searchPtr); +static Tcl_NRPostProc ArrayForLoopCallback; +static int ArrayForNRCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); static void DeleteSearches(Interp *iPtr, Var *arrayVarPtr); static void DeleteArray(Interp *iPtr, Tcl_Obj *arrayNamePtr, Var *varPtr, int flags, int index); +static int LocateArray(Tcl_Interp *interp, Tcl_Obj *name, + Var **varPtrPtr, int *isArrayPtr); +static int NotArrayError(Tcl_Interp *interp, Tcl_Obj *name); static Tcl_Var ObjFindNamespaceVar(Tcl_Interp *interp, Tcl_Obj *namePtr, Tcl_Namespace *contextNsPtr, int flags); @@ -188,8 +196,6 @@ static ArraySearch * ParseSearchId(Tcl_Interp *interp, const Var *varPtr, static void UnsetVarStruct(Var *varPtr, Var *arrayPtr, Interp *iPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags, int index); -static int SetArraySearchObj(Tcl_Interp *interp, - Tcl_Obj *objPtr); /* * Functions defined in this file that may be exported in the future for use @@ -202,26 +208,17 @@ MODULE_SCOPE Var * TclLookupSimpleVar(Tcl_Interp *interp, static Tcl_DupInternalRepProc DupLocalVarName; static Tcl_FreeInternalRepProc FreeLocalVarName; -static Tcl_UpdateStringProc PanicOnUpdateVarName; static Tcl_FreeInternalRepProc FreeParsedVarName; static Tcl_DupInternalRepProc DupParsedVarName; -static Tcl_UpdateStringProc UpdateParsedVarName; - -static Tcl_UpdateStringProc PanicOnUpdateVarName; -static Tcl_SetFromAnyProc PanicOnSetVarName; /* * Types of Tcl_Objs used to cache variable lookups. * * localVarName - INTERNALREP DEFINITION: - * ptrAndLongRep.ptr: pointer to name obj in varFramePtr->localCache + * twoPtrValue.ptr1: pointer to name obj in varFramePtr->localCache * or NULL if it is this same obj - * ptrAndLongRep.value: index into locals table - * - * nsVarName - INTERNALREP DEFINITION: - * twoPtrValue.ptr1: pointer to the namespace containing the reference - * twoPtrValue.ptr2: pointer to the corresponding Var + * twoPtrValue.ptr2: index into locals table * * parsedVarName - INTERNALREP DEFINITION: * twoPtrValue.ptr1: pointer to the array name Tcl_Obj, or NULL if it is a @@ -232,49 +229,14 @@ static Tcl_SetFromAnyProc PanicOnSetVarName; static const Tcl_ObjType localVarNameType = { "localVarName", - FreeLocalVarName, DupLocalVarName, PanicOnUpdateVarName, PanicOnSetVarName + FreeLocalVarName, DupLocalVarName, NULL, NULL }; -/* - * Caching of namespace variables disabled: no simple way was found to avoid - * interfering with the resolver's idea of variable existence. A cached - * varName may keep a variable's name in the namespace's hash table, which is - * the resolver's criterion for existence (see test namespace-17.10). - */ - -#define ENABLE_NS_VARNAME_CACHING 0 - -#if ENABLE_NS_VARNAME_CACHING -static Tcl_FreeInternalRepProc FreeNsVarName; -static Tcl_DupInternalRepProc DupNsVarName; - -static const Tcl_ObjType tclNsVarNameType = { - "namespaceVarName", - FreeNsVarName, DupNsVarName, PanicOnUpdateVarName, PanicOnSetVarName -}; -#endif - static const Tcl_ObjType tclParsedVarNameType = { "parsedVarName", - FreeParsedVarName, DupParsedVarName, UpdateParsedVarName, PanicOnSetVarName + FreeParsedVarName, DupParsedVarName, NULL, NULL }; -/* - * Type of Tcl_Objs used to speed up array searches. - * - * INTERNALREP DEFINITION: - * twoPtrValue.ptr1: searchIdNumber (cast to pointer) - * twoPtrValue.ptr2: variableNameStartInString (cast to pointer) - * - * Note that the value stored in ptr2 is the offset into the string of the - * start of the variable name and not the address of the variable name itself, - * as this can be safely copied. - */ - -const Tcl_ObjType tclArraySearchType = { - "array search", - NULL, NULL, NULL, SetArraySearchObj -}; Var * TclVarHashCreateVar( @@ -292,6 +254,42 @@ TclVarHashCreateVar( return varPtr; } + +static int +LocateArray( + Tcl_Interp *interp, + Tcl_Obj *name, + Var **varPtrPtr, + int *isArrayPtr) +{ + Var *arrayPtr, *varPtr = TclObjLookupVarEx(interp, name, NULL, /*flags*/ 0, + /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); + + if (TclCheckArrayTraces(interp, varPtr, arrayPtr, name, -1) == TCL_ERROR) { + return TCL_ERROR; + } + if (varPtrPtr) { + *varPtrPtr = varPtr; + } + if (isArrayPtr) { + *isArrayPtr = varPtr && !TclIsVarUndefined(varPtr) + && TclIsVarArray(varPtr); + } + return TCL_OK; +} + +static int +NotArrayError( + Tcl_Interp *interp, + Tcl_Obj *name) +{ + const char *nameStr = Tcl_GetString(name); + + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("\"%s\" isn't an array", nameStr)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", nameStr, NULL); + return TCL_ERROR; +} /* *---------------------------------------------------------------------- @@ -324,7 +322,8 @@ CleanupVar( { if (TclIsVarUndefined(varPtr) && TclIsVarInHash(varPtr) && !TclIsVarTraced(varPtr) - && (VarHashRefCount(varPtr) == !TclIsVarDeadHash(varPtr))) { + && (VarHashRefCount(varPtr) == (unsigned) + !TclIsVarDeadHash(varPtr))) { if (VarHashRefCount(varPtr) == 0) { ckfree(varPtr); } else { @@ -333,7 +332,8 @@ CleanupVar( } if (arrayPtr != NULL && TclIsVarUndefined(arrayPtr) && TclIsVarInHash(arrayPtr) && !TclIsVarTraced(arrayPtr) && - (VarHashRefCount(arrayPtr) == !TclIsVarDeadHash(arrayPtr))) { + (VarHashRefCount(arrayPtr) == (unsigned) + !TclIsVarDeadHash(arrayPtr))) { if (VarHashRefCount(arrayPtr) == 0) { ckfree(arrayPtr); } else { @@ -545,41 +545,20 @@ TclObjLookupVarEx( * is set to NULL. */ { Interp *iPtr = (Interp *) interp; + CallFrame *varFramePtr = iPtr->varFramePtr; register Var *varPtr; /* Points to the variable's in-frame Var * structure. */ - const char *part1; - int index, len1, len2; - int parsed = 0; - Tcl_Obj *objPtr; - const Tcl_ObjType *typePtr = part1Ptr->typePtr; const char *errMsg = NULL; - CallFrame *varFramePtr = iPtr->varFramePtr; -#if ENABLE_NS_VARNAME_CACHING - Namespace *nsPtr; -#endif - const char *part2 = part2Ptr? TclGetString(part2Ptr):NULL; - char *newPart2 = NULL; + int index, parsed = 0; + const Tcl_ObjType *typePtr = part1Ptr->typePtr; *arrayPtrPtr = NULL; -#if ENABLE_NS_VARNAME_CACHING - if (varFramePtr) { - nsPtr = varFramePtr->nsPtr; - } else { - /* - * Some variables in the global ns have to be initialized before the - * root call frame is in place. - */ - - nsPtr = NULL; - } -#endif - if (typePtr == &localVarNameType) { int localIndex; localVarNameTypeHandling: - localIndex = (int) part1Ptr->internalRep.ptrAndLongRep.value; + localIndex = PTR2INT(part1Ptr->internalRep.twoPtrValue.ptr2); if (HasLocalVars(varFramePtr) && !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) && (localIndex < varFramePtr->numCompiledLocals)) { @@ -587,8 +566,8 @@ TclObjLookupVarEx( * Use the cached index if the names coincide. */ - Tcl_Obj *namePtr = part1Ptr->internalRep.ptrAndLongRep.ptr; - Tcl_Obj *checkNamePtr = localName(iPtr->varFramePtr, localIndex); + Tcl_Obj *namePtr = part1Ptr->internalRep.twoPtrValue.ptr1; + Tcl_Obj *checkNamePtr = localName(varFramePtr, localIndex); if ((!namePtr && (checkNamePtr == part1Ptr)) || (namePtr && (checkNamePtr == namePtr))) { @@ -597,44 +576,6 @@ TclObjLookupVarEx( } } goto doneParsing; -#if ENABLE_NS_VARNAME_CACHING - } else if (typePtr == &tclNsVarNameType) { - int useGlobal, useReference; - Namespace *cachedNsPtr = part1Ptr->internalRep.twoPtrValue.ptr1; - varPtr = part1Ptr->internalRep.twoPtrValue.ptr2; - - useGlobal = (cachedNsPtr == iPtr->globalNsPtr) && ( - (flags & TCL_GLOBAL_ONLY) || - (part1[0]==':' && part1[1]==':') || - (!HasLocalVars(varFramePtr) && (nsPtr==iPtr->globalNsPtr))); - - useReference = useGlobal || ((cachedNsPtr == nsPtr) && ( - (flags & TCL_NAMESPACE_ONLY) || - (!HasLocalVars(varFramePtr) && !(flags & TCL_GLOBAL_ONLY) && - /* - * Careful: an undefined ns variable could be hiding a valid - * global reference. - */ - !TclIsVarUndefined(varPtr)))); - - if (useReference && !TclIsVarDeadHash(varPtr)) { - /* - * 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 TclIsVarDeadHash(varPtr), 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; -#endif } /* @@ -657,13 +598,7 @@ TclObjLookupVarEx( } return NULL; } - part2 = newPart2 = part1Ptr->internalRep.twoPtrValue.ptr2; - if (newPart2) { - part2Ptr = Tcl_NewStringObj(newPart2, -1); - if (createPart2) { - Tcl_IncrRefCount(part2Ptr); - } - } + part2Ptr = part1Ptr->internalRep.twoPtrValue.ptr2; part1Ptr = part1Ptr->internalRep.twoPtrValue.ptr1; typePtr = part1Ptr->typePtr; if (typePtr == &localVarNameType) { @@ -672,18 +607,21 @@ TclObjLookupVarEx( } parsed = 1; } - part1 = TclGetStringFromObj(part1Ptr, &len1); - if (!parsed && (*(part1 + len1 - 1) == ')')) { + if (!parsed) { /* * part1Ptr is possibly an unparsed array element. */ - register int i; + int len; + const char *part1 = TclGetStringFromObj(part1Ptr, &len); + + if ((len > 1) && (part1[len - 1] == ')')) { + const char *part2 = strchr(part1, '('); + + if (part2) { + Tcl_Obj *arrayPtr; - len2 = -1; - for (i = 0; i < len1; i++) { - if (*(part1 + i) == '(') { if (part2Ptr != NULL) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg, @@ -694,49 +632,19 @@ TclObjLookupVarEx( return NULL; } - /* - * 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(len2 + 1); - memcpy(newPart2, part2, (unsigned) len2); - *(newPart2+len2) = '\0'; - part2 = newPart2; - part2Ptr = Tcl_NewStringObj(newPart2, -1); - if (createPart2) { - Tcl_IncrRefCount(part2Ptr); - } - - /* - * Free the internal rep of the original part1Ptr, now renamed - * objPtr, and set it to tclParsedVarNameType. - */ + arrayPtr = Tcl_NewStringObj(part1, (part2 - part1)); + part2Ptr = Tcl_NewStringObj(part2 + 1, + len - (part2 - part1) - 2); - objPtr = part1Ptr; - TclFreeIntRep(objPtr); - objPtr->typePtr = &tclParsedVarNameType; + TclFreeIntRep(part1Ptr); - /* - * 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. - */ + Tcl_IncrRefCount(arrayPtr); + part1Ptr->internalRep.twoPtrValue.ptr1 = arrayPtr; + Tcl_IncrRefCount(part2Ptr); + part1Ptr->internalRep.twoPtrValue.ptr2 = part2Ptr; + part1Ptr->typePtr = &tclParsedVarNameType; - TclNewStringObj(part1Ptr, part1, len1); - Tcl_IncrRefCount(part1Ptr); - - objPtr->internalRep.twoPtrValue.ptr1 = part1Ptr; - objPtr->internalRep.twoPtrValue.ptr2 = (void *) part2; - - typePtr = part1Ptr->typePtr; - part1 = TclGetString(part1Ptr); - break; + part1Ptr = arrayPtr; } } } @@ -747,8 +655,6 @@ TclObjLookupVarEx( * the cached types if possible. */ - TclFreeIntRep(part1Ptr); - varPtr = TclLookupSimpleVar(interp, part1Ptr, flags, createPart1, &errMsg, &index); if (varPtr == NULL) { @@ -757,9 +663,6 @@ TclObjLookupVarEx( Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", TclGetString(part1Ptr), NULL); } - if (newPart2) { - Tcl_DecrRefCount(part2Ptr); - } return NULL; } @@ -767,35 +670,26 @@ TclObjLookupVarEx( * Cache the newly found variable if possible. */ + TclFreeIntRep(part1Ptr); if (index >= 0) { /* * An indexed local variable. */ + Tcl_Obj *cachedNamePtr = localName(varFramePtr, index); + part1Ptr->typePtr = &localVarNameType; - if (part1Ptr != localName(iPtr->varFramePtr, index)) { - part1Ptr->internalRep.ptrAndLongRep.ptr = - localName(iPtr->varFramePtr, index); - Tcl_IncrRefCount((Tcl_Obj *) - part1Ptr->internalRep.ptrAndLongRep.ptr); + if (part1Ptr != cachedNamePtr) { + part1Ptr->internalRep.twoPtrValue.ptr1 = cachedNamePtr; + Tcl_IncrRefCount(cachedNamePtr); + if (cachedNamePtr->typePtr != &localVarNameType + || cachedNamePtr->internalRep.twoPtrValue.ptr1 != NULL) { + TclFreeIntRep(cachedNamePtr); + } } else { - part1Ptr->internalRep.ptrAndLongRep.ptr = NULL; + part1Ptr->internalRep.twoPtrValue.ptr1 = NULL; } - part1Ptr->internalRep.ptrAndLongRep.value = (long) index; -#if ENABLE_NS_VARNAME_CACHING - } else if (index > -3) { - /* - * A cacheable namespace or global variable. - */ - - Namespace *nsPtr; - - nsPtr = ((index == -1) ? iPtr->globalNsPtr : varFramePtr->nsPtr); - varPtr->refCount++; - part1Ptr->typePtr = &tclNsVarNameType; - part1Ptr->internalRep.twoPtrValue.ptr1 = nsPtr; - part1Ptr->internalRep.twoPtrValue.ptr2 = varPtr; -#endif + part1Ptr->internalRep.twoPtrValue.ptr2 = INT2PTR(index); } else { /* * At least mark part1Ptr as already parsed. @@ -807,18 +701,6 @@ TclObjLookupVarEx( } donePart1: -#if 0 /* ENABLE_NS_VARNAME_CACHING perhaps? */ - if (varPtr == NULL) { - if (flags & TCL_LEAVE_ERR_MSG) { - part1 = TclGetString(part1Ptr); - TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg, - "cached variable reference is NULL.", -1); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", - TclGetString(part1Ptr), NULL); - } - return NULL; - } -#endif while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } @@ -831,29 +713,11 @@ TclObjLookupVarEx( *arrayPtrPtr = varPtr; varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, flags, msg, createPart1, createPart2, varPtr, -1); - if (newPart2) { - Tcl_DecrRefCount(part2Ptr); - } } return varPtr; } /* - * This flag bit should not interfere with TCL_GLOBAL_ONLY, - * TCL_NAMESPACE_ONLY, or TCL_LEAVE_ERR_MSG; it signals that the variable - * lookup is performed for upvar (or similar) purposes, with slightly - * different rules: - * - Bug #696893 - variable is either proc-local or in the current - * namespace; never follow the second (global) resolution path - * - Bug #631741 - do not use special namespace or interp resolvers - * - * It should also not collide with the (deprecated) TCL_PARSE_PART1 flag - * (Bug #835020) - */ - -#define AVOID_RESOLVERS 0x40000 - -/* *---------------------------------------------------------------------- * * TclLookupSimpleVar -- @@ -902,8 +766,8 @@ TclLookupSimpleVar( Tcl_Obj *varNamePtr, /* This is a simple variable name that could * represent a scalar or an array. */ int flags, /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, - * AVOID_RESOLVERS and TCL_LEAVE_ERR_MSG bits - * matter. */ + * TCL_AVOID_RESOLVERS 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. */ @@ -943,7 +807,7 @@ TclLookupSimpleVar( */ if ((cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) - && !(flags & AVOID_RESOLVERS)) { + && !(flags & TCL_AVOID_RESOLVERS)) { resPtr = iPtr->resolverPtr; if (cxtNsPtr->varResProc) { result = cxtNsPtr->varResProc(interp, varName, @@ -996,7 +860,7 @@ TclLookupSimpleVar( *indexPtr = -1; flags = (flags | TCL_GLOBAL_ONLY) & ~TCL_NAMESPACE_ONLY; } else { - if (flags & AVOID_RESOLVERS) { + if (flags & TCL_AVOID_RESOLVERS) { flags = (flags | TCL_NAMESPACE_ONLY); } if (flags & TCL_NAMESPACE_ONLY) { @@ -1011,42 +875,45 @@ TclLookupSimpleVar( varPtr = (Var *) ObjFindNamespaceVar(interp, varNamePtr, (Tcl_Namespace *) cxtNsPtr, - (flags | AVOID_RESOLVERS) & ~TCL_LEAVE_ERR_MSG); + (flags | TCL_AVOID_RESOLVERS) & ~TCL_LEAVE_ERR_MSG); if (varPtr == NULL) { Tcl_Obj *tailPtr; - if (create) { /* Var wasn't found so create it. */ - TclGetNamespaceForQualName(interp, varName, cxtNsPtr, - flags, &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail); - if (varNsPtr == NULL) { - *errMsgPtr = badNamespace; - return NULL; - } else if (tail == NULL) { - *errMsgPtr = missingName; - return NULL; - } - if (tail != varName) { - tailPtr = Tcl_NewStringObj(tail, -1); - } else { - tailPtr = varNamePtr; - } - varPtr = VarHashCreateVar(&varNsPtr->varTable, tailPtr, - &isNew); - if (lookGlobal) { - /* - * The variable was created starting from the global - * namespace: a global reference is returned even if it - * wasn't explicitly requested. - */ - - *indexPtr = -1; - } else { - *indexPtr = -2; - } - } else { /* Var wasn't found and not to create it. */ + if (!create) { /* Var wasn't found and not to create it. */ *errMsgPtr = noSuchVar; return NULL; } + + /* + * Var wasn't found so create it. + */ + + TclGetNamespaceForQualName(interp, varName, cxtNsPtr, flags, + &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail); + if (varNsPtr == NULL) { + *errMsgPtr = badNamespace; + return NULL; + } else if (tail == NULL) { + *errMsgPtr = missingName; + return NULL; + } + if (tail != varName) { + tailPtr = Tcl_NewStringObj(tail, -1); + } else { + tailPtr = varNamePtr; + } + varPtr = VarHashCreateVar(&varNsPtr->varTable, tailPtr, &isNew); + if (lookGlobal) { + /* + * The variable was created starting from the global + * namespace: a global reference is returned even if it wasn't + * explicitly requested. + */ + + *indexPtr = -1; + } else { + *indexPtr = -2; + } } } else { /* Local var: look in frame varFramePtr. */ int localLen, localCt = varFramePtr->numCompiledLocals; @@ -1247,6 +1114,7 @@ TclLookupArrayElement( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_GetVar const char * Tcl_GetVar( @@ -1267,6 +1135,7 @@ Tcl_GetVar( } return TclGetString(resultPtr); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -1425,7 +1294,7 @@ Tcl_ObjGetVar2( return NULL; } - return TclPtrGetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, + return TclPtrGetVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, flags, -1); } @@ -1455,6 +1324,52 @@ Tcl_Obj * TclPtrGetVar( Tcl_Interp *interp, /* Command interpreter in which variable is to * be looked up. */ + Tcl_Var varPtr, /* The variable to be read.*/ + Tcl_Var arrayPtr, /* NULL for scalar variables, pointer to the + * containing array otherwise. */ + Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or + * the name of a variable. */ + Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element + * in the array part1. */ + const int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, and + * TCL_LEAVE_ERR_MSG bits. */ +{ + if (varPtr == NULL) { + Tcl_Panic("varPtr must not be NULL"); + } + if (part1Ptr == NULL) { + Tcl_Panic("part1Ptr must not be NULL"); + } + return TclPtrGetVarIdx(interp, (Var *) varPtr, (Var *) arrayPtr, + part1Ptr, part2Ptr, flags, -1); +} + +/* + *---------------------------------------------------------------------- + * + * TclPtrGetVarIdx -- + * + * 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 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 reflect + * the returned reference; if you want to keep a reference to the object + * you must increment its ref count yourself. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclPtrGetVarIdx( + Tcl_Interp *interp, /* Command interpreter in which variable is to + * be looked up. */ register Var *varPtr, /* The variable to be read.*/ Var *arrayPtr, /* NULL for scalar variables, pointer to the * containing array otherwise. */ @@ -1590,6 +1505,7 @@ Tcl_SetObjCmd( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_SetVar const char * Tcl_SetVar( @@ -1602,18 +1518,15 @@ Tcl_SetVar( * TCL_APPEND_VALUE, TCL_LIST_ELEMENT, * TCL_LEAVE_ERR_MSG. */ { - Tcl_Obj *varValuePtr, *varNamePtr = Tcl_NewStringObj(varName, -1); - - Tcl_IncrRefCount(varNamePtr); - varValuePtr = Tcl_ObjSetVar2(interp, varNamePtr, NULL, + Tcl_Obj *varValuePtr = Tcl_SetVar2Ex(interp, varName, NULL, Tcl_NewStringObj(newValue, -1), flags); - Tcl_DecrRefCount(varNamePtr); if (varValuePtr == NULL) { return NULL; } return TclGetString(varValuePtr); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -1794,7 +1707,7 @@ Tcl_ObjSetVar2( return NULL; } - return TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, + return TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, newValuePtr, flags, -1); } @@ -1827,6 +1740,60 @@ Tcl_Obj * TclPtrSetVar( Tcl_Interp *interp, /* Command interpreter in which variable is to * be looked up. */ + Tcl_Var varPtr, /* Reference to the variable to set. */ + Tcl_Var arrayPtr, /* Reference to the array containing the + * variable, or NULL if the variable is a + * scalar. */ + Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or + * the name of a variable. */ + Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element + * in the array part1. */ + Tcl_Obj *newValuePtr, /* New value for variable. */ + const int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, and + * TCL_LEAVE_ERR_MSG bits. */ +{ + if (varPtr == NULL) { + Tcl_Panic("varPtr must not be NULL"); + } + if (part1Ptr == NULL) { + Tcl_Panic("part1Ptr must not be NULL"); + } + if (newValuePtr == NULL) { + Tcl_Panic("newValuePtr must not be NULL"); + } + return TclPtrSetVarIdx(interp, (Var *) varPtr, (Var *) arrayPtr, + part1Ptr, part2Ptr, newValuePtr, flags, -1); +} + +/* + *---------------------------------------------------------------------- + * + * TclPtrSetVarIdx -- + * + * 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 + * 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. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclPtrSetVarIdx( + Tcl_Interp *interp, /* Command interpreter in which variable is to + * be looked up. */ register Var *varPtr, /* Reference to the variable to set. */ Var *arrayPtr, /* Reference to the array containing the * variable, or NULL if the variable is a @@ -1912,17 +1879,6 @@ TclPtrSetVar( varPtr->value.objPtr = NULL; } if (flags & (TCL_APPEND_VALUE|TCL_LIST_ELEMENT)) { -#if 0 /* ENABLE_NS_VARNAME_CACHING perhaps? */ - /* - * Can't happen now! - */ - - if (TclIsVarUndefined(varPtr) && (oldValuePtr != NULL)) { - TclDecrRefCount(oldValuePtr); /* Discard old value. */ - varPtr->value.objPtr = NULL; - oldValuePtr = NULL; - } -#endif if (flags & TCL_LIST_ELEMENT) { /* Append list element. */ if (oldValuePtr == NULL) { TclNewObj(oldValuePtr); @@ -1958,6 +1914,9 @@ TclPtrSetVar( Tcl_IncrRefCount(oldValuePtr); /* Since var is ref */ } Tcl_AppendObjToObj(oldValuePtr, newValuePtr); + if (newValuePtr->refCount == 0) { + Tcl_DecrRefCount(newValuePtr); + } } } } else if (newValuePtr != oldValuePtr) { @@ -2077,7 +2036,7 @@ TclIncrObjVar2( "\n (reading value of variable to increment)"); return NULL; } - return TclPtrIncrObjVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, + return TclPtrIncrObjVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, incrPtr, flags, -1); } @@ -2110,6 +2069,62 @@ Tcl_Obj * TclPtrIncrObjVar( Tcl_Interp *interp, /* Command interpreter in which variable is to * be found. */ + Tcl_Var varPtr, /* Reference to the variable to set. */ + Tcl_Var arrayPtr, /* Reference to the array containing the + * variable, or NULL if the variable is a + * scalar. */ + Tcl_Obj *part1Ptr, /* Points to an object holding the name of an + * array (if part2 is non-NULL) or the name of + * a variable. */ + Tcl_Obj *part2Ptr, /* If non-null, points to an object holding + * the name of an element in the array + * part1Ptr. */ + Tcl_Obj *incrPtr, /* Increment value. */ +/* TODO: Which of these flag values really make sense? */ + 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. */ +{ + if (varPtr == NULL) { + Tcl_Panic("varPtr must not be NULL"); + } + if (part1Ptr == NULL) { + Tcl_Panic("part1Ptr must not be NULL"); + } + return TclPtrIncrObjVarIdx(interp, (Var *) varPtr, (Var *) arrayPtr, + part1Ptr, part2Ptr, incrPtr, flags, -1); +} + +/* + *---------------------------------------------------------------------- + * + * TclPtrIncrObjVarIdx -- + * + * Given the pointers to a variable and possible containing array, + * increment the Tcl object value of the variable by a Tcl_Obj increment. + * + * Results: + * Returns a pointer to the Tcl_Obj holding the new value of the + * 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. 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 * +TclPtrIncrObjVarIdx( + Tcl_Interp *interp, /* Command interpreter in which variable is to + * be found. */ Var *varPtr, /* Reference to the variable to set. */ Var *arrayPtr, /* Reference to the array containing the * variable, or NULL if the variable is a @@ -2135,8 +2150,8 @@ TclPtrIncrObjVar( if (TclIsVarInHash(varPtr)) { VarHashRefCount(varPtr)++; } - varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, - flags, index); + varValuePtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, part1Ptr, + part2Ptr, flags, index); if (TclIsVarInHash(varPtr)) { VarHashRefCount(varPtr)--; } @@ -2146,10 +2161,10 @@ TclPtrIncrObjVar( if (Tcl_IsShared(varValuePtr)) { /* Copy on write */ varValuePtr = Tcl_DuplicateObj(varValuePtr); - + if (TCL_OK == TclIncrObj(interp, varValuePtr, incrPtr)) { - return TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, - varValuePtr, flags, index); + return TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr, + part2Ptr, varValuePtr, flags, index); } else { Tcl_DecrRefCount(varValuePtr); return NULL; @@ -2157,7 +2172,6 @@ TclPtrIncrObjVar( } else { /* Unshared - can Incr in place */ if (TCL_OK == TclIncrObj(interp, varValuePtr, incrPtr)) { - /* * This seems dumb to write the incremeted value into the var * after we just adjusted the value in place, but the spec for @@ -2165,8 +2179,8 @@ TclPtrIncrObjVar( * is the way to make that happen. */ - return TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, - varValuePtr, flags, index); + return TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr, + part2Ptr, varValuePtr, flags, index); } else { return NULL; } @@ -2193,6 +2207,7 @@ TclPtrIncrObjVar( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_UnsetVar int Tcl_UnsetVar( @@ -2221,6 +2236,7 @@ Tcl_UnsetVar( Tcl_DecrRefCount(varNamePtr); return result; } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -2313,8 +2329,8 @@ TclObjUnsetVar2( return TCL_ERROR; } - return TclPtrUnsetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, flags, - -1); + return TclPtrUnsetVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, + flags, -1); } /* @@ -2343,6 +2359,53 @@ int TclPtrUnsetVar( Tcl_Interp *interp, /* Command interpreter in which varName is to * be looked up. */ + Tcl_Var varPtr, /* The variable to be unset. */ + Tcl_Var arrayPtr, /* NULL for scalar variables, pointer to the + * containing array otherwise. */ + Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or + * the name of a variable. */ + Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element + * in the array part1. */ + const int flags) /* OR-ed combination of any of + * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, + * TCL_LEAVE_ERR_MSG. */ +{ + if (varPtr == NULL) { + Tcl_Panic("varPtr must not be NULL"); + } + if (part1Ptr == NULL) { + Tcl_Panic("part1Ptr must not be NULL"); + } + return TclPtrUnsetVarIdx(interp, (Var *) varPtr, (Var *) arrayPtr, + part1Ptr, part2Ptr, flags, -1); +} + +/* + *---------------------------------------------------------------------- + * + * TclPtrUnsetVarIdx -- + * + * Delete a variable, given the pointers to the variable's (and possibly + * containing array's) VAR structure. + * + * Results: + * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR if + * the variable can't be unset. In the event of an error, if the + * TCL_LEAVE_ERR_MSG flag is set then an error message is left in the + * interp's result. + * + * Side effects: + * If varPtr and arrayPtr indicate a local or global variable in interp, + * it is deleted. If varPtr is an array reference and part2Ptr is NULL, + * then the whole array is deleted. + * + *---------------------------------------------------------------------- + */ + +int +TclPtrUnsetVarIdx( + Tcl_Interp *interp, /* Command interpreter in which varName is to + * be looked up. */ register Var *varPtr, /* The variable to be unset. */ Var *arrayPtr, /* NULL for scalar variables, pointer to the * containing array otherwise. */ @@ -2385,18 +2448,6 @@ TclPtrUnsetVar( } } -#if ENABLE_NS_VARNAME_CACHING - /* - * Try to avoid keeping the Var struct allocated due to a tclNsVarNameType - * keeping a reference. This removes some additional exteriorisations of - * [Bug 736729], but may be a good thing independently of the bug. - */ - - if (part1Ptr->typePtr == &tclNsVarNameType) { - TclFreeIntRep(part1Ptr); - } -#endif - /* * Finally, if the variable is truly not in use then free up its Var * structure and remove it from its hash table, if any. The ref count of @@ -2514,8 +2565,8 @@ UnsetVarStruct( tracePtr = NULL; if (TclIsVarTraced(&dummyVar)) { tPtr = Tcl_FindHashEntry(&iPtr->varTraces, &dummyVar); - tracePtr = Tcl_GetHashValue(tPtr); if (tPtr) { + tracePtr = Tcl_GetHashValue(tPtr); Tcl_DeleteHashEntry(tPtr); } } @@ -2702,11 +2753,11 @@ Tcl_AppendObjCmd( /* * 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 or emptyObjPtr, and we will not + * of TclPtrSetVarIdx will be NULL or emptyObjPtr, and we will not * access the variable again. */ - varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, objv[1], + varValuePtr = TclPtrSetVarIdx(interp, varPtr, arrayPtr, objv[1], NULL, objv[i], TCL_APPEND_VALUE|TCL_LEAVE_ERR_MSG, -1); if ((varValuePtr == NULL) || (varValuePtr == ((Interp *) interp)->emptyObjPtr)) { @@ -2786,7 +2837,7 @@ Tcl_LappendObjCmd( createdNewObj = 0; /* - * Protect the variable pointers around the TclPtrGetVar call + * Protect the variable pointers around the TclPtrGetVarIdx call * to insure that they remain valid even if the variable was undefined * and unused. */ @@ -2802,7 +2853,7 @@ Tcl_LappendObjCmd( if (arrayPtr && TclIsVarInHash(arrayPtr)) { VarHashRefCount(arrayPtr)++; } - varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, objv[1], NULL, + varValuePtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, objv[1], NULL, TCL_LEAVE_ERR_MSG, -1); if (TclIsVarInHash(varPtr)) { VarHashRefCount(varPtr)--; @@ -2843,7 +2894,7 @@ Tcl_LappendObjCmd( * and we didn't create the variable. */ - newValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, objv[1], NULL, + newValuePtr = TclPtrSetVarIdx(interp, varPtr, arrayPtr, objv[1], NULL, varValuePtr, TCL_LEAVE_ERR_MSG, -1); if (newValuePtr == NULL) { return TCL_ERROR; @@ -2862,173 +2913,308 @@ Tcl_LappendObjCmd( /* *---------------------------------------------------------------------- * - * TclArraySet -- + * ArrayForObjCmd, ArrayForNRCmd, ArrayForLoopCallback, ArrayObjNext -- * - * Set the elements of an array. If there are no elements to set, create - * an empty array. This routine is used by the Tcl_ArrayObjCmd and by the - * TclSetupEnv routine. + * These functions implement the "array for" Tcl command. + * array for {k v} a {} + * The array for command iterates over the array, setting the the + * specified loop variables, and executing the body each iteration. * - * Results: - * A standard Tcl result object. + * ArrayForObjCmd() is the standard wrapper around ArrayForNRCmd(). * - * Side effects: - * A variable will be created if one does not already exist. - * Callers must Incr arrayNameObj if they pland to Decr it. + * ArrayForNRCmd() sets up the ArraySearch structure, sets arrayNamePtr + * inside the structure and calls VarHashFirstEntry to start the hash + * iteration. + * + * ArrayForNRCmd() does not execute the body or set the loop variables, + * it only initializes the iterator. + * + * ArrayForLoopCallback() iterates over the entire array, executing the + * body each time. * *---------------------------------------------------------------------- */ -int -TclArraySet( +static int +ArrayObjNext( + Tcl_Interp *interp, + Tcl_Obj *arrayNameObj, /* array */ + Var *varPtr, /* array */ + ArraySearch *searchPtr, + Tcl_Obj **keyPtrPtr, /* Pointer to a variable to have the key + * written into, or NULL. */ + Tcl_Obj **valuePtrPtr) /* Pointer to a variable to have the + * value written into, or NULL.*/ +{ + Tcl_Obj *keyObj; + Tcl_Obj *valueObj = NULL; + int gotValue; + int donerc; + + donerc = TCL_BREAK; + + if ((varPtr->flags & VAR_SEARCH_ACTIVE) != VAR_SEARCH_ACTIVE) { + donerc = TCL_ERROR; + return donerc; + } + + gotValue = 0; + while (1) { + Tcl_HashEntry *hPtr = searchPtr->nextEntry; + + if (hPtr != NULL) { + searchPtr->nextEntry = NULL; + } else { + hPtr = Tcl_NextHashEntry(&searchPtr->search); + if (hPtr == NULL) { + gotValue = 0; + break; + } + } + varPtr = VarHashGetValue(hPtr); + if (!TclIsVarUndefined(varPtr)) { + gotValue = 1; + break; + } + } + + if (!gotValue) { + return donerc; + } + + donerc = TCL_CONTINUE; + + keyObj = VarHashGetKey(varPtr); + *keyPtrPtr = keyObj; + valueObj = Tcl_ObjGetVar2(interp, arrayNameObj, keyObj, + TCL_LEAVE_ERR_MSG); + *valuePtrPtr = valueObj; + + return donerc; +} + +static int +ArrayForObjCmd( + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Obj *arrayNameObj, /* The array name. */ - Tcl_Obj *arrayElemObj) /* The array elements list or dict. If this is - * NULL, create an empty array. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - Var *varPtr, *arrayPtr; - int result, i; + return Tcl_NRCallObjProc(interp, ArrayForNRCmd, dummy, objc, objv); +} - varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, - /*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "set", /*createPart1*/ 1, - /*createPart2*/ 1, &arrayPtr); - if (varPtr == NULL) { +static int +ArrayForNRCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Tcl_Obj *varListObj, *arrayNameObj, *scriptObj; + ArraySearch *searchPtr = NULL; + Var *varPtr; + int isArray, numVars; + + /* + * array for {k v} a body + */ + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "{key value} arrayName script"); return TCL_ERROR; } - if (arrayPtr) { - CleanupVar(varPtr, arrayPtr); - TclObjVarErrMsg(interp, arrayNameObj, NULL, "set", needArray, -1); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", - TclGetString(arrayNameObj), NULL); + + /* + * Parse arguments. + */ + + if (Tcl_ListObjLength(interp, objv[1], &numVars) != TCL_OK) { + return TCL_ERROR; + } + + if (numVars != 2) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "must have two variable names", -1)); + Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "array", "for", NULL); + return TCL_ERROR; + } + + arrayNameObj = objv[2]; + + if (TCL_ERROR == LocateArray(interp, arrayNameObj, &varPtr, &isArray)) { return TCL_ERROR; } - if (arrayElemObj == NULL) { - goto ensureArray; + if (!isArray) { + return NotArrayError(interp, arrayNameObj); } /* - * Install the contents of the dictionary or list into the array. + * Make a new array search, put it on the stack. */ - if (arrayElemObj->typePtr == &tclDictType) { - Tcl_Obj *keyPtr, *valuePtr; - Tcl_DictSearch search; - int done; + searchPtr = ckalloc(sizeof(ArraySearch)); + ArrayPopulateSearch(interp, arrayNameObj, varPtr, searchPtr); - if (Tcl_DictObjSize(interp, arrayElemObj, &done) != TCL_OK) { - return TCL_ERROR; - } - if (done == 0) { - /* - * Empty, so we'll just force the array to be properly existing - * instead. - */ + /* + * Make sure that these objects (which we need throughout the body of the + * loop) don't vanish. + */ - goto ensureArray; - } + varListObj = TclListObjCopy(NULL, objv[1]); + scriptObj = objv[3]; + Tcl_IncrRefCount(scriptObj); - /* - * Don't need to look at result of Tcl_DictObjFirst as we've just - * successfully used a dictionary operation on the same object. - */ + /* + * Run the script. + */ - for (Tcl_DictObjFirst(interp, arrayElemObj, &search, - &keyPtr, &valuePtr, &done) ; !done ; - Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done)) { - /* - * At this point, it would be nice if the key was directly usable - * by the array. This isn't the case though. - */ + TclNRAddCallback(interp, ArrayForLoopCallback, searchPtr, varListObj, + arrayNameObj, scriptObj); + return TCL_OK; +} - Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj, - keyPtr, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1); +static int +ArrayForLoopCallback( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + ArraySearch *searchPtr = data[0]; + Tcl_Obj *varListObj = data[1]; + Tcl_Obj *arrayNameObj = data[2]; + Tcl_Obj *scriptObj = data[3]; + Tcl_Obj **varv; + Tcl_Obj *keyObj, *valueObj; + Var *varPtr; + Var *arrayPtr; + int done, varc; - if ((elemVarPtr == NULL) || - (TclPtrSetVar(interp, elemVarPtr, varPtr, arrayNameObj, - keyPtr, valuePtr, TCL_LEAVE_ERR_MSG, -1) == NULL)) { - Tcl_DictObjDone(&search); - return TCL_ERROR; - } - } - return TCL_OK; - } else { - /* - * Not a dictionary, so assume (and convert to, for backward- - * -compatability reasons) a list. - */ + /* + * Process the result from the previous execution of the script body. + */ - int elemLen; - Tcl_Obj **elemPtrs, *copyListObj; + done = TCL_ERROR; - result = TclListObjGetElements(interp, arrayElemObj, - &elemLen, &elemPtrs); - if (result != TCL_OK) { - return result; - } - if (elemLen & 1) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "list must have an even number of elements", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "FORMAT", NULL); - return TCL_ERROR; - } - if (elemLen == 0) { - goto ensureArray; + if (result == TCL_CONTINUE) { + result = TCL_OK; + } else if (result != TCL_OK) { + if (result == TCL_BREAK) { + Tcl_ResetResult(interp); + result = TCL_OK; + } else if (result == TCL_ERROR) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"array for\" body line %d)", + Tcl_GetErrorLine(interp))); } + goto arrayfordone; + } - /* - * 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. - */ + /* + * Get the next mapping from the array. + */ - copyListObj = TclListObjCopy(NULL, arrayElemObj); - for (i=0 ; i<elemLen ; i+=2) { - Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj, - elemPtrs[i], TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1); + keyObj = NULL; + valueObj = NULL; + varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, /*flags*/ 0, + /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); + if (varPtr == NULL) { + done = TCL_ERROR; + } else { + done = ArrayObjNext(interp, arrayNameObj, varPtr, searchPtr, &keyObj, + &valueObj); + } - if ((elemVarPtr == NULL) || - (TclPtrSetVar(interp, elemVarPtr, varPtr, arrayNameObj, - elemPtrs[i],elemPtrs[i+1],TCL_LEAVE_ERR_MSG,-1) == NULL)){ - result = TCL_ERROR; - break; - } + result = TCL_OK; + if (done != TCL_CONTINUE) { + Tcl_ResetResult(interp); + if (done == TCL_ERROR) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "array changed during iteration", -1)); + Tcl_SetErrorCode(interp, "TCL", "READ", "array", "for", NULL); + varPtr->flags |= TCL_LEAVE_ERR_MSG; + result = done; + } + goto arrayfordone; + } + + Tcl_ListObjGetElements(NULL, varListObj, &varc, &varv); + if (Tcl_ObjSetVar2(interp, varv[0], NULL, keyObj, + TCL_LEAVE_ERR_MSG) == NULL) { + result = TCL_ERROR; + goto arrayfordone; + } + if (valueObj != NULL) { + if (Tcl_ObjSetVar2(interp, varv[1], NULL, valueObj, + TCL_LEAVE_ERR_MSG) == NULL) { + result = TCL_ERROR; + goto arrayfordone; } - Tcl_DecrRefCount(copyListObj); - return result; } /* - * The list is empty make sure we have an array, or create one if - * necessary. + * Run the script. */ - ensureArray: - if (varPtr != NULL) { - if (TclIsVarArray(varPtr)) { - /* - * Already an array, done. - */ + TclNRAddCallback(interp, ArrayForLoopCallback, searchPtr, varListObj, + arrayNameObj, scriptObj); + return TclNREvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3); - return TCL_OK; - } - if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) { - /* - * Either an array element, or a scalar: lose! - */ + /* + * For unwinding everything once the iterating is done. + */ - TclObjVarErrMsg(interp, arrayNameObj, NULL, "array set", - needArray, -1); - Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); - return TCL_ERROR; - } + arrayfordone: + if (done != TCL_ERROR) { + /* + * If the search was terminated by an array change, the + * VAR_SEARCH_ACTIVE flag will no longer be set. + */ + + ArrayDoneSearch(iPtr, varPtr, searchPtr); + Tcl_DecrRefCount(searchPtr->name); + ckfree(searchPtr); } - TclSetVarArray(varPtr); - varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable)); - TclInitVarHashTable(varPtr->value.tablePtr, TclGetVarNsPtr(varPtr)); - return TCL_OK; + + TclDecrRefCount(varListObj); + TclDecrRefCount(scriptObj); + return result; } /* + * ArrayPopulateSearch + */ + +static void +ArrayPopulateSearch( + Tcl_Interp *interp, + Tcl_Obj *arrayNameObj, + Var *varPtr, + ArraySearch *searchPtr) +{ + Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hPtr; + int isNew; + + hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew); + if (isNew) { + searchPtr->id = 1; + varPtr->flags |= VAR_SEARCH_ACTIVE; + searchPtr->nextPtr = NULL; + } else { + searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1; + searchPtr->nextPtr = Tcl_GetHashValue(hPtr); + } + searchPtr->varPtr = varPtr; + searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr, + &searchPtr->search); + Tcl_SetHashValue(hPtr, searchPtr); + searchPtr->name = Tcl_ObjPrintf("s-%d-%s", searchPtr->id, + TclGetString(arrayNameObj)); + Tcl_IncrRefCount(searchPtr->name); +} +/* *---------------------------------------------------------------------- * * ArrayStartSearchCmd -- @@ -3047,6 +3233,7 @@ TclArraySet( */ /* ARGSUSED */ + static int ArrayStartSearchCmd( ClientData clientData, @@ -3054,77 +3241,75 @@ ArrayStartSearchCmd( int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; - Var *varPtr, *arrayPtr; - Tcl_HashEntry *hPtr; - Tcl_Obj *varNameObj; - int isNew; + Var *varPtr; + int isArray; ArraySearch *searchPtr; - const char *varName; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName"); return TCL_ERROR; } - varNameObj = objv[1]; - - /* - * Locate the array variable. - */ - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - varName = TclGetString(varNameObj); - - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ + if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr, &isArray)) { + return TCL_ERROR; + } - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } + if (!isArray) { + return NotArrayError(interp, objv[1]); } /* - * 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. + * Make a new array search with a free name. */ - if ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" isn't an array", varName)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", varName, NULL); - return TCL_ERROR; - } + searchPtr = ckalloc(sizeof(ArraySearch)); + ArrayPopulateSearch(interp, objv[1], varPtr, searchPtr); + Tcl_SetObjResult(interp, searchPtr->name); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ArrayDoneSearch -- + * + * Removes the search from the hash of active searches. + * + *---------------------------------------------------------------------- + */ +static void +ArrayDoneSearch( + Interp *iPtr, + Var *varPtr, + ArraySearch *searchPtr) +{ + Tcl_HashEntry *hPtr; + ArraySearch *prevPtr; /* - * Make a new array search with a free name. + * Unhook the search from the list of searches associated with the + * variable. */ - searchPtr = ckalloc(sizeof(ArraySearch)); - hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew); - if (isNew) { - searchPtr->id = 1; - varPtr->flags |= VAR_SEARCH_ACTIVE; - searchPtr->nextPtr = NULL; + hPtr = Tcl_FindHashEntry(&iPtr->varSearches, varPtr); + if (hPtr == NULL) { + return; + } + if (searchPtr == Tcl_GetHashValue(hPtr)) { + if (searchPtr->nextPtr) { + Tcl_SetHashValue(hPtr, searchPtr->nextPtr); + } else { + varPtr->flags &= ~VAR_SEARCH_ACTIVE; + Tcl_DeleteHashEntry(hPtr); + } } else { - searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1; - searchPtr->nextPtr = Tcl_GetHashValue(hPtr); + for (prevPtr=Tcl_GetHashValue(hPtr) ;; prevPtr=prevPtr->nextPtr) { + if (prevPtr->nextPtr == searchPtr) { + prevPtr->nextPtr = searchPtr->nextPtr; + break; + } + } } - searchPtr->varPtr = varPtr; - searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr, - &searchPtr->search); - Tcl_SetHashValue(hPtr, searchPtr); - Tcl_SetObjResult(interp, - Tcl_ObjPrintf("s-%d-%s", searchPtr->id, varName)); - return TCL_OK; } /* @@ -3153,9 +3338,9 @@ ArrayAnyMoreCmd( Tcl_Obj *const objv[]) { Interp *iPtr = (Interp *) interp; - Var *varPtr, *arrayPtr; + Var *varPtr; Tcl_Obj *varNameObj, *searchObj; - int gotValue; + int gotValue, isArray; ArraySearch *searchPtr; if (objc != 3) { @@ -3165,40 +3350,12 @@ ArrayAnyMoreCmd( varNameObj = objv[1]; searchObj = objv[2]; - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } + if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) { + return TCL_ERROR; } - /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. - */ - - if ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" isn't an array", TclGetString(varNameObj))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", - TclGetString(varNameObj), NULL); - return TCL_ERROR; + if (!isArray) { + return NotArrayError(interp, varNameObj); } /* @@ -3259,10 +3416,10 @@ ArrayNextElementCmd( int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; - Var *varPtr, *arrayPtr; + Var *varPtr; Tcl_Obj *varNameObj, *searchObj; ArraySearch *searchPtr; + int isArray; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId"); @@ -3271,40 +3428,12 @@ ArrayNextElementCmd( varNameObj = objv[1]; searchObj = objv[2]; - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } + if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) { + return TCL_ERROR; } - /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. - */ - - if ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" isn't an array", TclGetString(varNameObj))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", - TclGetString(varNameObj), NULL); - return TCL_ERROR; + if (!isArray) { + return NotArrayError(interp, varNameObj); } /* @@ -3369,10 +3498,10 @@ ArrayDoneSearchCmd( Tcl_Obj *const objv[]) { Interp *iPtr = (Interp *) interp; - Var *varPtr, *arrayPtr; - Tcl_HashEntry *hPtr; + Var *varPtr; Tcl_Obj *varNameObj, *searchObj; - ArraySearch *searchPtr, *prevPtr; + ArraySearch *searchPtr; + int isArray; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId"); @@ -3381,40 +3510,12 @@ ArrayDoneSearchCmd( varNameObj = objv[1]; searchObj = objv[2]; - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } + if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) { + return TCL_ERROR; } - /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. - */ - - if ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" isn't an array", TclGetString(varNameObj))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", - TclGetString(varNameObj), NULL); - return TCL_ERROR; + if (!isArray) { + return NotArrayError(interp, varNameObj); } /* @@ -3426,27 +3527,8 @@ ArrayDoneSearchCmd( return TCL_ERROR; } - /* - * Unhook the search from the list of searches associated with the - * variable. - */ - - hPtr = Tcl_FindHashEntry(&iPtr->varSearches, varPtr); - if (searchPtr == Tcl_GetHashValue(hPtr)) { - if (searchPtr->nextPtr) { - Tcl_SetHashValue(hPtr, searchPtr->nextPtr); - } else { - varPtr->flags &= ~VAR_SEARCH_ACTIVE; - Tcl_DeleteHashEntry(hPtr); - } - } else { - for (prevPtr=Tcl_GetHashValue(hPtr) ;; prevPtr=prevPtr->nextPtr) { - if (prevPtr->nextPtr == searchPtr) { - prevPtr->nextPtr = searchPtr->nextPtr; - break; - } - } - } + ArrayDoneSearch(iPtr, varPtr, searchPtr); + Tcl_DecrRefCount(searchPtr->name); ckfree(searchPtr); return TCL_OK; } @@ -3476,45 +3558,19 @@ ArrayExistsCmd( int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; - Var *varPtr, *arrayPtr; - Tcl_Obj *arrayNameObj; - int notArray; + Interp *iPtr = (Interp *)interp; + int isArray; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName"); return TCL_ERROR; } - arrayNameObj = objv[1]; - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, arrayNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } + if (TCL_ERROR == LocateArray(interp, objv[1], NULL, &isArray)) { + return TCL_ERROR; } - /* - * Check whether we've actually got an array variable. - */ - - notArray = ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)); - Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[!notArray]); + Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[isArray]); return TCL_OK; } @@ -3543,13 +3599,12 @@ ArrayGetCmd( int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; - Var *varPtr, *arrayPtr, *varPtr2; + Var *varPtr, *varPtr2; Tcl_Obj *varNameObj, *nameObj, *valueObj, *nameLstObj, *tmpResObj; Tcl_Obj **nameObjPtr, *patternObj; Tcl_HashSearch search; const char *pattern; - int i, count, result; + int i, count, result, isArray; switch (objc) { case 2: @@ -3565,35 +3620,12 @@ ArrayGetCmd( return TCL_ERROR; } - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } + if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) { + return TCL_ERROR; } - /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. If not an array, it's an empty result. - */ - - if ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)) { + /* If not an array, it's an empty result. */ + if (!isArray) { return TCL_OK; } @@ -3731,39 +3763,20 @@ ArrayNamesCmd( "-exact", "-glob", "-regexp", NULL }; enum options { OPT_EXACT, OPT_GLOB, OPT_REGEXP }; - Interp *iPtr = (Interp *) interp; - Var *varPtr, *arrayPtr, *varPtr2; - Tcl_Obj *varNameObj, *nameObj, *resultObj, *patternObj; + Var *varPtr, *varPtr2; + Tcl_Obj *nameObj, *resultObj, *patternObj; Tcl_HashSearch search; const char *pattern = NULL; - int mode = OPT_GLOB; + int isArray, mode = OPT_GLOB; if ((objc < 2) || (objc > 4)) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName ?mode? ?pattern?"); return TCL_ERROR; } - varNameObj = objv[1]; patternObj = (objc > 2 ? objv[objc-1] : NULL); - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } + if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr, &isArray)) { + return TCL_ERROR; } /* @@ -3775,14 +3788,9 @@ ArrayNamesCmd( return TCL_ERROR; } - /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. If not an array, the result is empty. - */ + /* If not an array, the result is empty. */ - if ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)) { + if (!isArray) { return TCL_OK; } @@ -3850,6 +3858,53 @@ ArrayNamesCmd( /* *---------------------------------------------------------------------- * + * TclFindArrayPtrElements -- + * + * Fill out a hash table (which *must* use Tcl_Obj* keys) with an entry + * for each existing element of the given array. The provided hash table + * is assumed to be initially empty. + * + * Result: + * none + * + * Side effects: + * The keys of the array gain an extra reference. The supplied hash table + * has elements added to it. + * + *---------------------------------------------------------------------- + */ + +void +TclFindArrayPtrElements( + Var *arrayPtr, + Tcl_HashTable *tablePtr) +{ + Var *varPtr; + Tcl_HashSearch search; + + if ((arrayPtr == NULL) || !TclIsVarArray(arrayPtr) + || TclIsVarUndefined(arrayPtr)) { + return; + } + + for (varPtr=VarHashFirstVar(arrayPtr->value.tablePtr, &search); + varPtr!=NULL ; varPtr=VarHashNextVar(&search)) { + Tcl_HashEntry *hPtr; + Tcl_Obj *nameObj; + int dummy; + + if (TclIsVarUndefined(varPtr)) { + continue; + } + nameObj = VarHashGetKey(varPtr); + hPtr = Tcl_CreateHashEntry(tablePtr, (char *) nameObj, &dummy); + Tcl_SetHashValue(hPtr, nameObj); + } +} + +/* + *---------------------------------------------------------------------- + * * ArraySetCmd -- * * This object-based function is invoked to process the "array set" Tcl @@ -3872,36 +3927,157 @@ ArraySetCmd( int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; + Tcl_Obj *arrayNameObj; + Tcl_Obj *arrayElemObj; Var *varPtr, *arrayPtr; + int result, i; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName list"); return TCL_ERROR; } + if (TCL_ERROR == LocateArray(interp, objv[1], NULL, NULL)) { + return TCL_ERROR; + } + + arrayNameObj = objv[1]; + varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, + /*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "set", /*createPart1*/ 1, + /*createPart2*/ 1, &arrayPtr); + if (varPtr == NULL) { + return TCL_ERROR; + } + if (arrayPtr) { + CleanupVar(varPtr, arrayPtr); + TclObjVarErrMsg(interp, arrayNameObj, NULL, "set", needArray, -1); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", + TclGetString(arrayNameObj), NULL); + return TCL_ERROR; + } + /* - * Locate the array variable. + * Install the contents of the dictionary or list into the array. */ - varPtr = TclObjLookupVarEx(interp, objv[1], NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); + arrayElemObj = objv[2]; + if (arrayElemObj->typePtr == &tclDictType && arrayElemObj->bytes == NULL) { + Tcl_Obj *keyPtr, *valuePtr; + Tcl_DictSearch search; + int done; + + if (Tcl_DictObjSize(interp, arrayElemObj, &done) != TCL_OK) { + return TCL_ERROR; + } + if (done == 0) { + /* + * Empty, so we'll just force the array to be properly existing + * instead. + */ + + goto ensureArray; + } + + /* + * Don't need to look at result of Tcl_DictObjFirst as we've just + * successfully used a dictionary operation on the same object. + */ + + for (Tcl_DictObjFirst(interp, arrayElemObj, &search, + &keyPtr, &valuePtr, &done) ; !done ; + Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done)) { + /* + * At this point, it would be nice if the key was directly usable + * by the array. This isn't the case though. + */ + + Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj, + keyPtr, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1); + + if ((elemVarPtr == NULL) || + (TclPtrSetVarIdx(interp, elemVarPtr, varPtr, arrayNameObj, + keyPtr, valuePtr, TCL_LEAVE_ERR_MSG, -1) == NULL)) { + Tcl_DictObjDone(&search); + return TCL_ERROR; + } + } + return TCL_OK; + } else { + /* + * Not a dictionary, so assume (and convert to, for backward- + * -compatibility reasons) a list. + */ + + int elemLen; + Tcl_Obj **elemPtrs, *copyListObj; + + result = TclListObjGetElements(interp, arrayElemObj, + &elemLen, &elemPtrs); + if (result != TCL_OK) { + return result; + } + if (elemLen & 1) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "list must have an even number of elements", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "FORMAT", NULL); + return TCL_ERROR; + } + if (elemLen == 0) { + goto ensureArray; + } + + /* + * We needn't worry about traces invalidating arrayPtr: should that be + * the case, TclPtrSetVarIdx will return NULL so that we break out of + * the loop and return an error. + */ + + copyListObj = TclListObjCopy(NULL, arrayElemObj); + for (i=0 ; i<elemLen ; i+=2) { + Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj, + elemPtrs[i], TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1); + + if ((elemVarPtr == NULL) || + (TclPtrSetVarIdx(interp, elemVarPtr, varPtr, arrayNameObj, + elemPtrs[i], elemPtrs[i+1], TCL_LEAVE_ERR_MSG, + -1) == NULL)) { + result = TCL_ERROR; + break; + } + } + Tcl_DecrRefCount(copyListObj); + return result; + } /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. + * The list is empty make sure we have an array, or create one if + * necessary. */ - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, objv[1], NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { + ensureArray: + if (varPtr != NULL) { + if (TclIsVarArray(varPtr)) { + /* + * Already an array, done. + */ + + return TCL_OK; + } + if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) { + /* + * Either an array element, or a scalar: lose! + */ + + TclObjVarErrMsg(interp, arrayNameObj, NULL, "array set", + needArray, -1); + Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); return TCL_ERROR; } } - - return TclArraySet(interp, objv[1], objv[2]); + TclSetVarArray(varPtr); + varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable)); + TclInitVarHashTable(varPtr->value.tablePtr, TclGetVarNsPtr(varPtr)); + return TCL_OK; } /* @@ -3929,47 +4105,23 @@ ArraySizeCmd( int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; - Var *varPtr, *arrayPtr; - Tcl_Obj *varNameObj; + Var *varPtr; Tcl_HashSearch search; Var *varPtr2; - int size = 0; + int isArray, size = 0; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName"); return TCL_ERROR; } - varNameObj = objv[1]; - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } + if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr, &isArray)) { + 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. We can only iterate over the array if it exists... - */ + /* We can only iterate over the array if it exists... */ - if (varPtr && TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { + if (isArray) { /* * Must iterate in order to get chance to check for present but * "undefined" entries. @@ -4013,10 +4165,10 @@ ArrayStatsCmd( int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; - Var *varPtr, *arrayPtr; + Var *varPtr; Tcl_Obj *varNameObj; char *stats; + int isArray; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName"); @@ -4024,40 +4176,12 @@ ArrayStatsCmd( } varNameObj = objv[1]; - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } + if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) { + return TCL_ERROR; } - /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. - */ - - if ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" isn't an array", TclGetString(varNameObj))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", - TclGetString(varNameObj), NULL); - return TCL_ERROR; + if (!isArray) { + return NotArrayError(interp, varNameObj); } stats = Tcl_HashStats((Tcl_HashTable *) varPtr->value.tablePtr); @@ -4096,12 +4220,12 @@ ArrayUnsetCmd( int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; - Var *varPtr, *arrayPtr, *varPtr2, *protectedVarPtr; + Var *varPtr, *varPtr2, *protectedVarPtr; Tcl_Obj *varNameObj, *patternObj, *nameObj; Tcl_HashSearch search; const char *pattern; const int unsetFlags = 0; /* Should this be TCL_LEAVE_ERR_MSG? */ + int isArray; switch (objc) { case 2: @@ -4117,35 +4241,11 @@ ArrayUnsetCmd( return TCL_ERROR; } - /* - * Locate the array variable - */ - - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } + if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) { + return TCL_ERROR; } - /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. - */ - - if ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)) { + if (!isArray) { return TCL_OK; } @@ -4167,8 +4267,8 @@ ArrayUnsetCmd( if (!varPtr2 || TclIsVarUndefined(varPtr2)) { return TCL_OK; } - return TclPtrUnsetVar(interp, varPtr2, varPtr, varNameObj, patternObj, - unsetFlags, -1); + return TclPtrUnsetVarIdx(interp, varPtr2, varPtr, varNameObj, + patternObj, unsetFlags, -1); } /* @@ -4216,7 +4316,7 @@ ArrayUnsetCmd( nameObj = VarHashGetKey(varPtr2); if (Tcl_StringMatch(TclGetString(nameObj), pattern) - && TclPtrUnsetVar(interp, varPtr2, varPtr, varNameObj, + && TclPtrUnsetVarIdx(interp, varPtr2, varPtr, varNameObj, nameObj, unsetFlags, -1) != TCL_OK) { /* * If we incremented a refcount, we must decrement it here as we @@ -4258,6 +4358,7 @@ TclInitArrayCmd( {"anymore", ArrayAnyMoreCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"donesearch", ArrayDoneSearchCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"exists", ArrayExistsCmd, TclCompileArrayExistsCmd, NULL, NULL, 0}, + {"for", ArrayForObjCmd, TclCompileBasic3ArgCmd, ArrayForNRCmd, NULL, 0}, {"get", ArrayGetCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {"names", ArrayNamesCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, {"nextelement", ArrayNextElementCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, @@ -4282,7 +4383,7 @@ TclInitArrayCmd( * * Results: * A standard Tcl completion code. If an error occurs then an error - * message is left in iPtr->result. + * message is left in interp. * * Side effects: * The variable given by myName is linked to the variable in framePtr @@ -4355,15 +4456,15 @@ ObjMakeUpvar( || !HasLocalVars(varFramePtr) || (strstr(TclGetString(myNamePtr), "::") != NULL))) { Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf( - "bad variable name \"%s\": upvar won't create " - "namespace variable that refers to procedure variable", + "bad variable name \"%s\": can't create namespace " + "variable that refers to procedure variable", TclGetString(myNamePtr))); Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", NULL); return TCL_ERROR; } } - return TclPtrObjMakeUpvar(interp, otherPtr, myNamePtr, myFlags, index); + return TclPtrObjMakeUpvarIdx(interp, otherPtr, myNamePtr, myFlags, index); } /* @@ -4376,7 +4477,7 @@ ObjMakeUpvar( * * Results: * A standard Tcl completion code. If an error occurs then an error - * message is left in iPtr->result. + * message is left in interp. * * Side effects: * The variable given by myName is linked to the variable in framePtr @@ -4405,19 +4506,34 @@ TclPtrMakeUpvar( myNamePtr = Tcl_NewStringObj(myName, -1); Tcl_IncrRefCount(myNamePtr); } - result = TclPtrObjMakeUpvar(interp, otherPtr, myNamePtr, myFlags, index); + result = TclPtrObjMakeUpvarIdx(interp, otherPtr, myNamePtr, myFlags, + index); if (myNamePtr) { Tcl_DecrRefCount(myNamePtr); } return result; } -/* Callers must Incr myNamePtr if they plan to Decr it. */ - int TclPtrObjMakeUpvar( Tcl_Interp *interp, /* Interpreter containing variables. Used for * error messages, too. */ + Tcl_Var otherPtr, /* Pointer to the variable being linked-to. */ + Tcl_Obj *myNamePtr, /* Name of variable which will refer to + * otherP1/otherP2. Must be a scalar. */ + int myFlags) /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: + * indicates scope of myName. */ +{ + return TclPtrObjMakeUpvarIdx(interp, (Var *) otherPtr, myNamePtr, myFlags, + -1); +} + +/* Callers must Incr myNamePtr if they plan to Decr it. */ + +int +TclPtrObjMakeUpvarIdx( + Tcl_Interp *interp, /* Interpreter containing variables. Used for + * error messages, too. */ Var *otherPtr, /* Pointer to the variable being linked-to. */ Tcl_Obj *myNamePtr, /* Name of variable which will refer to * otherP1/otherP2. Must be a scalar. */ @@ -4456,9 +4572,8 @@ TclPtrObjMakeUpvar( */ Tcl_SetObjResult((Tcl_Interp *) iPtr, Tcl_ObjPrintf( - "bad variable name \"%s\": upvar won't create a" - " scalar variable that looks like an array element", - myName)); + "bad variable name \"%s\": can't create a scalar " + "variable that looks like an array element", myName)); Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", NULL); return TCL_ERROR; @@ -4467,15 +4582,15 @@ TclPtrObjMakeUpvar( /* * Lookup and eventually create the new variable. Set the flag bit - * AVOID_RESOLVERS to indicate the special resolution rules for upvar - * purposes: + * TCL_AVOID_RESOLVERS to indicate the special resolution rules for + * upvar purposes: * - Bug #696893 - variable is either proc-local or in the current * namespace; never follow the second (global) resolution path. * - Bug #631741 - do not use special namespace or interp resolvers. */ varPtr = TclLookupSimpleVar(interp, myNamePtr, - myFlags|AVOID_RESOLVERS, /* create */ 1, &errMsg, &index); + myFlags|TCL_AVOID_RESOLVERS, /* create */ 1, &errMsg, &index); if (varPtr == NULL) { TclObjVarErrMsg(interp, myNamePtr, NULL, "create", errMsg, -1); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", @@ -4553,6 +4668,7 @@ TclPtrObjMakeUpvar( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_UpVar int Tcl_UpVar( @@ -4586,6 +4702,7 @@ Tcl_UpVar( Tcl_DecrRefCount(localNamePtr); return result; } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -4697,7 +4814,7 @@ Tcl_GetVariableFullName( } else if (iPtr->varFramePtr->procPtr) { int index = varPtr - iPtr->varFramePtr->compiledLocals; - if (index < iPtr->varFramePtr->numCompiledLocals) { + if (index >= 0 && index < iPtr->varFramePtr->numCompiledLocals) { namePtr = localName(iPtr->varFramePtr, index); Tcl_AppendObjToObj(objPtr, namePtr); } @@ -4883,8 +5000,9 @@ Tcl_VariableObjCmd( */ if (i+1 < objc) { /* A value was specified. */ - varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, varNamePtr, - NULL, objv[i+1], TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG,-1); + varValuePtr = TclPtrSetVarIdx(interp, varPtr, arrayPtr, + varNamePtr, NULL, objv[i+1], + (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), -1); if (varValuePtr == NULL) { return TCL_ERROR; } @@ -5009,7 +5127,8 @@ Tcl_UpvarObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad level \"%s\"", TclGetString(levelObj))); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "LEVEL", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", + TclGetString(levelObj), NULL); return TCL_ERROR; } @@ -5039,75 +5158,6 @@ Tcl_UpvarObjCmd( /* *---------------------------------------------------------------------- * - * SetArraySearchObj -- - * - * This function converts the given tcl object into one that has the - * "array search" internal type. - * - * Results: - * TCL_OK if the conversion succeeded, and TCL_ERROR if it failed (when - * an error message will be placed in the interpreter's result.) - * - * Side effects: - * Updates the internal type and representation of the object to make - * this an array-search object. See the tclArraySearchType declaration - * above for details of the internal representation. - * - *---------------------------------------------------------------------- - */ - -static int -SetArraySearchObj( - Tcl_Interp *interp, - Tcl_Obj *objPtr) -{ - const char *string; - char *end; /* Can't be const due to strtoul defn. */ - int id; - size_t offset; - - /* - * Get the string representation. Make it up-to-date if necessary. - */ - - string = TclGetString(objPtr); - - /* - * Parse the id into the three parts separated by dashes. - */ - - if ((string[0] != 's') || (string[1] != '-')) { - goto syntax; - } - id = strtoul(string+2, &end, 10); - if ((end == (string+2)) || (*end != '-')) { - goto syntax; - } - - /* - * Can't perform value check in this context, so place reference to place - * in string to use for the check in the object instead. - */ - - end++; - offset = end - string; - - TclFreeIntRep(objPtr); - objPtr->typePtr = &tclArraySearchType; - objPtr->internalRep.twoPtrValue.ptr1 = INT2PTR(id); - objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(offset); - return TCL_OK; - - syntax: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "illegal search identifier \"%s\"", string)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, NULL); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * * ParseSearchId -- * * This function translates from a tcl object to a pointer to an active @@ -5118,10 +5168,6 @@ SetArraySearchObj( * or NULL if there isn't one. If NULL is returned, the interp's result * contains an error message. * - * Side effects: - * The tcl object might have its internal type and representation - * modified. - * *---------------------------------------------------------------------- */ @@ -5137,65 +5183,43 @@ ParseSearchId( * name. */ { Interp *iPtr = (Interp *) interp; - register const char *string; - register size_t offset; - int id; ArraySearch *searchPtr; - const char *varName = TclGetString(varNamePtr); - - /* - * Parse the id. - */ - - if ((handleObj->typePtr != &tclArraySearchType) - && (SetArraySearchObj(interp, handleObj) != TCL_OK)) { - return NULL; - } - - /* - * Extract the information out of the Tcl_Obj. - */ - - id = PTR2INT(handleObj->internalRep.twoPtrValue.ptr1); - string = TclGetString(handleObj); - offset = PTR2INT(handleObj->internalRep.twoPtrValue.ptr2); - - /* - * This test cannot be placed inside the Tcl_Obj machinery, since it is - * dependent on the variable context. - */ - - if (strcmp(string+offset, varName) != 0) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "search identifier \"%s\" isn't for variable \"%s\"", - string, varName)); - goto badLookup; - } - - /* - * Search through the list of active searches on the interpreter to see if - * the desired one exists. - * - * Note that we cannot store the searchPtr directly in the Tcl_Obj as that - * would run into trouble when DeleteSearches() was called so we must scan - * this list every time. - */ + const char *handle = TclGetString(handleObj); + char *end; if (varPtr->flags & VAR_SEARCH_ACTIVE) { Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&iPtr->varSearches, varPtr); + /* First look for same (Tcl_Obj *) */ for (searchPtr = Tcl_GetHashValue(hPtr); searchPtr != NULL; searchPtr = searchPtr->nextPtr) { - if (searchPtr->id == id) { + if (searchPtr->name == handleObj) { + return searchPtr; + } + } + /* Fallback: do string compares. */ + for (searchPtr = Tcl_GetHashValue(hPtr); searchPtr != NULL; + searchPtr = searchPtr->nextPtr) { + if (strcmp(TclGetString(searchPtr->name), handle) == 0) { return searchPtr; } } } - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't find search \"%s\"", string)); - badLookup: - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, NULL); + if ((handle[0] != 's') || (handle[1] != '-') + || (strtoul(handle + 2, &end, 10), end == (handle + 2)) + || (*end != '-')) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "illegal search identifier \"%s\"", handle)); + } else if (strcmp(end + 1, TclGetString(varNamePtr)) != 0) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "search identifier \"%s\" isn't for variable \"%s\"", + handle, TclGetString(varNamePtr))); + } else { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't find search \"%s\"", handle)); + } + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", handle, NULL); return NULL; } @@ -5230,6 +5254,7 @@ DeleteSearches( for (searchPtr = Tcl_GetHashValue(sPtr); searchPtr != NULL; searchPtr = nextPtr) { nextPtr = searchPtr->nextPtr; + Tcl_DecrRefCount(searchPtr->name); ckfree(searchPtr); } arrayVarPtr->flags &= ~VAR_SEARCH_ACTIVE; @@ -5282,13 +5307,16 @@ TclDeleteNamespaceVars( VarHashRefCount(varPtr)++; /* Make sure we get to remove from * hash. */ Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr); - UnsetVarStruct(varPtr, NULL, iPtr, /* part1 */ objPtr, NULL, flags, - -1); - Tcl_DecrRefCount(objPtr); /* Free no longer needed obj */ + UnsetVarStruct(varPtr, NULL, iPtr, /* part1 */ objPtr, + NULL, flags, -1); /* - * Remove the variable from the table and force it undefined in case - * an unset trace brought it back from the dead. + * We just unset the variable. However, an unset trace might + * have re-set it, or might have re-established traces on it. + * This namespace and its vartable are going away unconditionally, + * so we cannot let such things linger. That would be a leak. + * + * First we destroy all traces. ... */ if (TclIsVarTraced(varPtr)) { @@ -5312,6 +5340,17 @@ TclDeleteNamespaceVars( } } } + + /* + * ...and then, if the variable still holds a value, we unset it + * again. This time with no traces left, we're sure it goes away. + */ + + if (!TclIsVarUndefined(varPtr)) { + UnsetVarStruct(varPtr, NULL, iPtr, /* part1 */ objPtr, + NULL, flags, -1); + } + Tcl_DecrRefCount(objPtr); /* free no longer needed obj */ VarHashRefCount(varPtr)--; VarHashDeleteEntry(varPtr); } @@ -5452,9 +5491,6 @@ DeleteArray( Tcl_Obj *objPtr; VarTrace *tracePtr; - if (varPtr->flags & VAR_SEARCH_ACTIVE) { - DeleteSearches(iPtr, varPtr); - } for (elPtr = VarHashFirstVar(varPtr->value.tablePtr, &search); elPtr != NULL; elPtr = VarHashNextVar(&search)) { if (TclIsVarScalar(elPtr) && (elPtr->value.objPtr != NULL)) { @@ -5589,41 +5625,19 @@ TclObjVarErrMsg( */ /* - * Panic functions that should never be called in normal operation. - */ - -static void -PanicOnUpdateVarName( - Tcl_Obj *objPtr) -{ - Tcl_Panic("%s of type %s should not be called", "updateStringProc", - objPtr->typePtr->name); -} - -static int -PanicOnSetVarName( - Tcl_Interp *interp, - Tcl_Obj *objPtr) -{ - Tcl_Panic("%s of type %s should not be called", "setFromAnyProc", - objPtr->typePtr->name); - return TCL_ERROR; -} - -/* * localVarName - * * INTERNALREP DEFINITION: - * ptrAndLongRep.ptr: pointer to name obj in varFramePtr->localCache + * twoPtrValue.ptr1: pointer to name obj in varFramePtr->localCache * or NULL if it is this same obj - * ptrAndLongRep.value: index into locals table + * twoPtrValue.ptr2: index into locals table */ static void FreeLocalVarName( Tcl_Obj *objPtr) { - Tcl_Obj *namePtr = objPtr->internalRep.ptrAndLongRep.ptr; + Tcl_Obj *namePtr = objPtr->internalRep.twoPtrValue.ptr1; if (namePtr) { Tcl_DecrRefCount(namePtr); @@ -5636,60 +5650,19 @@ DupLocalVarName( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { - Tcl_Obj *namePtr = srcPtr->internalRep.ptrAndLongRep.ptr; + Tcl_Obj *namePtr = srcPtr->internalRep.twoPtrValue.ptr1; if (!namePtr) { namePtr = srcPtr; } - dupPtr->internalRep.ptrAndLongRep.ptr = namePtr; + dupPtr->internalRep.twoPtrValue.ptr1 = namePtr; Tcl_IncrRefCount(namePtr); - dupPtr->internalRep.ptrAndLongRep.value = - srcPtr->internalRep.ptrAndLongRep.value; + dupPtr->internalRep.twoPtrValue.ptr2 = + srcPtr->internalRep.twoPtrValue.ptr2; dupPtr->typePtr = &localVarNameType; } -#if ENABLE_NS_VARNAME_CACHING -/* - * nsVarName - - * - * INTERNALREP DEFINITION: - * twoPtrValue.ptr1: pointer to the namespace containing the reference. - * twoPtrValue.ptr2: pointer to the corresponding Var - */ - -static void -FreeNsVarName( - Tcl_Obj *objPtr) -{ - register Var *varPtr = objPtr->internalRep.twoPtrValue.ptr2; - - if (TclIsVarInHash(varPtr)) { - varPtr->refCount--; - if (TclIsVarUndefined(varPtr) && (varPtr->refCount == 0)) { - CleanupVar(varPtr, NULL); - } - } - objPtr->typePtr = NULL; -} - -static void -DupNsVarName( - Tcl_Obj *srcPtr, - Tcl_Obj *dupPtr) -{ - Namespace *nsPtr = srcPtr->internalRep.twoPtrValue.ptr1; - register Var *varPtr = srcPtr->internalRep.twoPtrValue.ptr2; - - dupPtr->internalRep.twoPtrValue.ptr1 = nsPtr; - dupPtr->internalRep.twoPtrValue.ptr2 = varPtr; - if (TclIsVarInHash(varPtr)) { - varPtr->refCount++; - } - dupPtr->typePtr = &tclNsVarNameType; -} -#endif - /* * parsedVarName - * @@ -5704,11 +5677,11 @@ FreeParsedVarName( Tcl_Obj *objPtr) { register Tcl_Obj *arrayPtr = objPtr->internalRep.twoPtrValue.ptr1; - register char *elem = objPtr->internalRep.twoPtrValue.ptr2; + register Tcl_Obj *elem = objPtr->internalRep.twoPtrValue.ptr2; if (arrayPtr != NULL) { TclDecrRefCount(arrayPtr); - ckfree(elem); + TclDecrRefCount(elem); } objPtr->typePtr = NULL; } @@ -5719,58 +5692,17 @@ DupParsedVarName( Tcl_Obj *dupPtr) { register Tcl_Obj *arrayPtr = srcPtr->internalRep.twoPtrValue.ptr1; - register char *elem = srcPtr->internalRep.twoPtrValue.ptr2; - char *elemCopy; - unsigned elemLen; + register Tcl_Obj *elem = srcPtr->internalRep.twoPtrValue.ptr2; if (arrayPtr != NULL) { Tcl_IncrRefCount(arrayPtr); - elemLen = strlen(elem); - elemCopy = ckalloc(elemLen + 1); - memcpy(elemCopy, elem, elemLen); - *(elemCopy + elemLen) = '\0'; - elem = elemCopy; + Tcl_IncrRefCount(elem); } dupPtr->internalRep.twoPtrValue.ptr1 = arrayPtr; dupPtr->internalRep.twoPtrValue.ptr2 = elem; dupPtr->typePtr = &tclParsedVarNameType; } - -static void -UpdateParsedVarName( - Tcl_Obj *objPtr) -{ - Tcl_Obj *arrayPtr = objPtr->internalRep.twoPtrValue.ptr1; - char *part2 = objPtr->internalRep.twoPtrValue.ptr2; - const char *part1; - char *p; - int len1, len2, totalLen; - - if (arrayPtr == NULL) { - /* - * This is a parsed scalar name: what is it doing here? - */ - - Tcl_Panic("scalar parsedVarName without a string rep"); - } - - part1 = TclGetStringFromObj(arrayPtr, &len1); - len2 = strlen(part2); - - totalLen = len1 + len2 + 2; - p = ckalloc(totalLen + 1); - objPtr->bytes = p; - objPtr->length = totalLen; - - memcpy(p, part1, (unsigned) len1); - p += len1; - *p++ = '('; - memcpy(p, part2, (unsigned) len2); - p += len2; - *p++ = ')'; - *p = '\0'; -} /* *---------------------------------------------------------------------- @@ -5806,11 +5738,12 @@ Tcl_FindNamespaceVar( * Otherwise, points to namespace in which to * resolve name. If NULL, look up name in the * current namespace. */ - int flags) /* An OR'd combination of: AVOID_RESOLVERS, - * TCL_GLOBAL_ONLY (look up name only in - * global namespace), TCL_NAMESPACE_ONLY (look - * up only in contextNsPtr, or the current - * namespace if contextNsPtr is NULL), and + int flags) /* An OR'd combination of: + * TCL_AVOID_RESOLVERS, TCL_GLOBAL_ONLY (look + * up name only in global namespace), + * TCL_NAMESPACE_ONLY (look up only in + * contextNsPtr, or the current namespace if + * contextNsPtr is NULL), and * TCL_LEAVE_ERR_MSG. If both TCL_GLOBAL_ONLY * and TCL_NAMESPACE_ONLY are given, * TCL_GLOBAL_ONLY is ignored. */ @@ -5836,11 +5769,12 @@ ObjFindNamespaceVar( * Otherwise, points to namespace in which to * resolve name. If NULL, look up name in the * current namespace. */ - int flags) /* An OR'd combination of: AVOID_RESOLVERS, - * TCL_GLOBAL_ONLY (look up name only in - * global namespace), TCL_NAMESPACE_ONLY (look - * up only in contextNsPtr, or the current - * namespace if contextNsPtr is NULL), and + int flags) /* An OR'd combination of: + * TCL_AVOID_RESOLVERS, TCL_GLOBAL_ONLY (look + * up name only in global namespace), + * TCL_NAMESPACE_ONLY (look up only in + * contextNsPtr, or the current namespace if + * contextNsPtr is NULL), and * TCL_LEAVE_ERR_MSG. If both TCL_GLOBAL_ONLY * and TCL_NAMESPACE_ONLY are given, * TCL_GLOBAL_ONLY is ignored. */ @@ -5870,7 +5804,7 @@ ObjFindNamespaceVar( cxtNsPtr = (Namespace *) TclGetCurrentNamespace(interp); } - if (!(flags & AVOID_RESOLVERS) && + if (!(flags & TCL_AVOID_RESOLVERS) && (cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL)) { resPtr = iPtr->resolverPtr; @@ -6096,7 +6030,7 @@ TclInfoVarsCmd( */ if ((nsPtr != globalNsPtr) && !specificNsInPattern) { - varPtr = VarHashFirstVar(&globalNsPtr->varTable,&search); + varPtr = VarHashFirstVar(&globalNsPtr->varTable, &search); while (varPtr) { if (!TclIsVarUndefined(varPtr) || TclIsVarNamespaceVar(varPtr)) { @@ -6389,25 +6323,50 @@ AppendLocals( } if (iPtr->varFramePtr->isProcCallFrame & FRAME_IS_METHOD) { - CallContext *contextPtr = iPtr->varFramePtr->clientData; - Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; + Method *mPtr = (Method *) + Tcl_ObjectContextMethod(iPtr->varFramePtr->clientData); + PrivateVariableMapping *privatePtr; if (mPtr->declaringObjectPtr) { - FOREACH(objNamePtr, mPtr->declaringObjectPtr->variables) { + Object *oPtr = mPtr->declaringObjectPtr; + + FOREACH(objNamePtr, oPtr->variables) { Tcl_CreateHashEntry(&addedTable, objNamePtr, &added); if (added && (!pattern || Tcl_StringMatch(TclGetString(objNamePtr), pattern))) { Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); } } + FOREACH_STRUCT(privatePtr, oPtr->privateVariables) { + Tcl_CreateHashEntry(&addedTable, privatePtr->variableObj, + &added); + if (added && (!pattern || + Tcl_StringMatch(TclGetString(privatePtr->variableObj), + pattern))) { + Tcl_ListObjAppendElement(interp, listPtr, + privatePtr->variableObj); + } + } } else { - FOREACH(objNamePtr, mPtr->declaringClassPtr->variables) { + Class *clsPtr = mPtr->declaringClassPtr; + + FOREACH(objNamePtr, clsPtr->variables) { Tcl_CreateHashEntry(&addedTable, objNamePtr, &added); if (added && (!pattern || Tcl_StringMatch(TclGetString(objNamePtr), pattern))) { Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); } } + FOREACH_STRUCT(privatePtr, clsPtr->privateVariables) { + Tcl_CreateHashEntry(&addedTable, privatePtr->variableObj, + &added); + if (added && (!pattern || + Tcl_StringMatch(TclGetString(privatePtr->variableObj), + pattern))) { + Tcl_ListObjAppendElement(interp, listPtr, + privatePtr->variableObj); + } + } } } Tcl_DeleteHashTable(&addedTable); @@ -6479,12 +6438,11 @@ CompareVarKeys( /* * If the object pointers are the same then they match. + * OPT: this comparison was moved to the caller + * + * if (objPtr1 == objPtr2) return 1; */ - if (objPtr1 == objPtr2) { - return 1; - } - /* * Don't use Tcl_GetStringFromObj as it would prevent l1 and l2 being in a * register. diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 4907b45..644ac8b 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -26,7 +26,7 @@ * interface, even if that is mostly true). */ -#define TCL_ZLIB_VERSION "2.0" +#define TCL_ZLIB_VERSION "2.0.1" /* * Magic flags used with wbits fields to indicate that we're handling the gzip @@ -177,6 +177,8 @@ static Tcl_ObjCmdProc ZlibStreamPutCmd; static void ConvertError(Tcl_Interp *interp, int code, uLong adler); static Tcl_Obj * ConvertErrorToList(int code, uLong adler); +static inline int Deflate(z_streamp strm, void *bufferPtr, + int bufferSize, int flush, int *writtenPtr); static void ExtractHeader(gz_header *headerPtr, Tcl_Obj *dictObj); static int GenerateHeader(Tcl_Interp *interp, Tcl_Obj *dictObj, GzipHeader *headerPtr, int *extraSizePtr); @@ -438,7 +440,7 @@ GenerateHeader( if (GetValue(interp, dictObj, "comment", &value) != TCL_OK) { goto error; } else if (value != NULL) { - valueStr = Tcl_GetStringFromObj(value, &len); + valueStr = TclGetStringFromObj(value, &len); Tcl_UtfToExternal(NULL, latin1enc, valueStr, len, 0, NULL, headerPtr->nativeCommentBuf, MAX_COMMENT_LEN-1, NULL, &len, NULL); @@ -459,7 +461,7 @@ GenerateHeader( if (GetValue(interp, dictObj, "filename", &value) != TCL_OK) { goto error; } else if (value != NULL) { - valueStr = Tcl_GetStringFromObj(value, &len); + valueStr = TclGetStringFromObj(value, &len); Tcl_UtfToExternal(NULL, latin1enc, valueStr, len, 0, NULL, headerPtr->nativeFilenameBuf, MAXPATHLEN-1, NULL, &len, NULL); headerPtr->nativeFilenameBuf[len] = '\0'; @@ -578,6 +580,10 @@ ExtractHeader( } } +/* + * Disentangle the worst of how the zlib API is used. + */ + static int SetInflateDictionary( z_streamp strm, @@ -605,6 +611,38 @@ SetDeflateDictionary( } return Z_OK; } + +static inline int +Deflate( + z_streamp strm, + void *bufferPtr, + int bufferSize, + int flush, + int *writtenPtr) +{ + int e; + + strm->next_out = (Bytef *) bufferPtr; + strm->avail_out = (unsigned) bufferSize; + e = deflate(strm, flush); + if (writtenPtr != NULL) { + *writtenPtr = bufferSize - strm->avail_out; + } + return e; +} + +static inline void +AppendByteArray( + Tcl_Obj *listObj, + void *buffer, + int size) +{ + if (size > 0) { + Tcl_Obj *baObj = Tcl_NewByteArrayObj((unsigned char *) buffer, size); + + Tcl_ListObjAppendElement(NULL, listObj, baObj); + } +} /* *---------------------------------------------------------------------- @@ -643,7 +681,6 @@ Tcl_ZlibStreamInit( int e; ZlibStreamHandle *zshPtr = NULL; Tcl_DString cmdname; - Tcl_CmdInfo cmdinfo; GzipHeader *gzHeaderPtr = NULL; switch (mode) { @@ -763,14 +800,14 @@ Tcl_ZlibStreamInit( */ if (interp != NULL) { - if (Tcl_Eval(interp, "::incr ::tcl::zlib::cmdcounter") != TCL_OK) { + if (Tcl_EvalEx(interp, "::incr ::tcl::zlib::cmdcounter", -1, 0) != TCL_OK) { goto error; } Tcl_DStringInit(&cmdname); TclDStringAppendLiteral(&cmdname, "::tcl::zlib::streamcmd_"); TclDStringAppendObj(&cmdname, Tcl_GetObjResult(interp)); - if (Tcl_GetCommandInfo(interp, Tcl_DStringValue(&cmdname), - &cmdinfo) == 1) { + if (Tcl_FindCommand(interp, Tcl_DStringValue(&cmdname), + NULL, 0) != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "BUG: Stream command name already exists", -1)); Tcl_SetErrorCode(interp, "TCL", "BUG", "EXISTING_CMD", NULL); @@ -1140,6 +1177,8 @@ Tcl_ZlibStreamSetCompressionDictionary( *---------------------------------------------------------------------- */ +#define BUFFER_SIZE_LIMIT 0xFFFF + int Tcl_ZlibStreamPut( Tcl_ZlibStream zshandle, /* As obtained from Tcl_ZlibStreamInit */ @@ -1149,8 +1188,7 @@ Tcl_ZlibStreamPut( { ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle; char *dataTmp = NULL; - int e, size, outSize; - Tcl_Obj *obj; + int e, size, outSize, toStore; if (zshPtr->streamEnd) { if (zshPtr->interp) { @@ -1165,79 +1203,78 @@ Tcl_ZlibStreamPut( zshPtr->stream.next_in = Tcl_GetByteArrayFromObj(data, &size); zshPtr->stream.avail_in = size; + /* + * Must not do a zero-length compress unless finalizing. [Bug 25842c161] + */ + + if (size == 0 && flush != Z_FINISH) { + return TCL_OK; + } + if (HaveDictToSet(zshPtr)) { e = SetDeflateDictionary(&zshPtr->stream, zshPtr->compDictObj); if (e != Z_OK) { - if (zshPtr->interp) { - ConvertError(zshPtr->interp, e, zshPtr->stream.adler); - } + ConvertError(zshPtr->interp, e, zshPtr->stream.adler); return TCL_ERROR; } DictWasSet(zshPtr); } /* - * Deflatebound doesn't seem to take various header sizes into - * account, so we add 100 extra bytes. + * deflateBound() doesn't seem to take various header sizes into + * account, so we add 100 extra bytes. However, we can also loop + * around again so we also set an upper bound on the output buffer + * size. */ - outSize = deflateBound(&zshPtr->stream, zshPtr->stream.avail_in)+100; - zshPtr->stream.avail_out = outSize; - dataTmp = ckalloc(zshPtr->stream.avail_out); - zshPtr->stream.next_out = (Bytef *) dataTmp; - - e = deflate(&zshPtr->stream, flush); - if ((e==Z_OK || e==Z_BUF_ERROR) && (zshPtr->stream.avail_out == 0)) { - if (outSize - zshPtr->stream.avail_out > 0) { - /* - * Output buffer too small. - */ + outSize = deflateBound(&zshPtr->stream, size) + 100; + if (outSize > BUFFER_SIZE_LIMIT) { + outSize = BUFFER_SIZE_LIMIT; + } + dataTmp = ckalloc(outSize); - obj = Tcl_NewByteArrayObj((unsigned char *) dataTmp, - outSize - zshPtr->stream.avail_out); + while (1) { + e = Deflate(&zshPtr->stream, dataTmp, outSize, flush, &toStore); - /* - * Now append the compressed data to the outData list. - */ - - Tcl_ListObjAppendElement(NULL, zshPtr->outData, obj); - } - if (outSize < 0xFFFF) { - outSize = 0xFFFF; /* There may be *lots* of data left to - * output... */ - ckfree(dataTmp); - dataTmp = ckalloc(outSize); - } - zshPtr->stream.avail_out = outSize; - zshPtr->stream.next_out = (Bytef *) dataTmp; + /* + * Test if we've filled the buffer up and have to ask deflate() to + * give us some more. Note that the condition for needing to + * repeat a buffer transfer when the result is Z_OK is whether + * there is no more space in the buffer we provided; the zlib + * library does not necessarily return a different code in that + * case. [Bug b26e38a3e4] [Tk Bug 10f2e7872b] + */ - e = deflate(&zshPtr->stream, flush); - } - if (e != Z_OK && !(flush==Z_FINISH && e==Z_STREAM_END)) { - if (zshPtr->interp) { + if ((e != Z_BUF_ERROR) && (e != Z_OK || toStore < outSize)) { + if ((e == Z_OK) || (flush == Z_FINISH && e == Z_STREAM_END)) { + break; + } ConvertError(zshPtr->interp, e, zshPtr->stream.adler); + return TCL_ERROR; } - return TCL_ERROR; - } - - /* - * And append the final data block. - */ - - if (outSize - zshPtr->stream.avail_out > 0) { - obj = Tcl_NewByteArrayObj((unsigned char *) dataTmp, - outSize - zshPtr->stream.avail_out); /* - * Now append the compressed data to the outData list. + * Output buffer too small to hold the data being generated or we + * are doing the end-of-stream flush (which can spit out masses of + * data). This means we need to put a new buffer into place after + * saving the old generated data to the outData list. */ - Tcl_ListObjAppendElement(NULL, zshPtr->outData, obj); - } + AppendByteArray(zshPtr->outData, dataTmp, outSize); - if (dataTmp) { - ckfree(dataTmp); + if (outSize < BUFFER_SIZE_LIMIT) { + outSize = BUFFER_SIZE_LIMIT; + /* There may be *lots* of data left to output... */ + dataTmp = ckrealloc(dataTmp, outSize); + } } + + /* + * And append the final data block to the outData list. + */ + + AppendByteArray(zshPtr->outData, dataTmp, toStore); + ckfree(dataTmp); } else { /* * This is easy. Just append to the inData list. @@ -1353,9 +1390,7 @@ Tcl_ZlibStreamGet( if (IsRawStream(zshPtr) && HaveDictToSet(zshPtr)) { e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj); if (e != Z_OK) { - if (zshPtr->interp) { - ConvertError(zshPtr->interp, e, zshPtr->stream.adler); - } + ConvertError(zshPtr->interp, e, zshPtr->stream.adler); return TCL_ERROR; } DictWasSet(zshPtr); @@ -1535,7 +1570,7 @@ Tcl_ZlibDeflate( if (!interp) { return TCL_ERROR; } - + /* * Compressed format is specified by the wbits parameter. See zlib.h for * details. @@ -1758,6 +1793,7 @@ Tcl_ZlibInflate( if (headerPtr) { e = inflateGetHeader(&stream, headerPtr); if (e != Z_OK) { + inflateEnd(&stream); goto error; } } @@ -1781,7 +1817,7 @@ Tcl_ZlibInflate( if ((stream.avail_in == 0) && (stream.avail_out > 0)) { e = Z_STREAM_ERROR; - goto error; + break; } newBufferSize = bufferSize + 5 * stream.avail_in; if (newBufferSize == bufferSize) { @@ -2860,7 +2896,7 @@ ZlibTransformClose( Tcl_Interp *interp) { ZlibChannelData *cd = instanceData; - int e, result = TCL_OK; + int e, written, result = TCL_OK; /* * Delete the support timer. @@ -2875,9 +2911,18 @@ ZlibTransformClose( if (cd->mode == TCL_ZLIB_STREAM_DEFLATE) { cd->outStream.avail_in = 0; do { - cd->outStream.next_out = (Bytef *) cd->outBuffer; - cd->outStream.avail_out = (unsigned) cd->outAllocated; - e = deflate(&cd->outStream, Z_FINISH); + e = Deflate(&cd->outStream, cd->outBuffer, cd->outAllocated, + Z_FINISH, &written); + + /* + * Can't be sure that deflate() won't declare the buffer to be + * full (with Z_BUF_ERROR) so handle that case. + */ + + if (e == Z_BUF_ERROR) { + e = Z_OK; + written = cd->outAllocated; + } if (e != Z_OK && e != Z_STREAM_END) { /* TODO: is this the right way to do errors on close? */ if (!TclInThreadExit()) { @@ -2886,31 +2931,32 @@ ZlibTransformClose( result = TCL_ERROR; break; } - if (cd->outStream.avail_out != (unsigned) cd->outAllocated) { - if (Tcl_WriteRaw(cd->parent, cd->outBuffer, - cd->outAllocated - cd->outStream.avail_out) < 0) { - /* TODO: is this the right way to do errors on close? - * Note: when close is called from FinalizeIOSubsystem - * then interp may be NULL */ - if (!TclInThreadExit() && interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "error while finalizing file: %s", - Tcl_PosixError(interp))); - } - result = TCL_ERROR; - break; + if (written && Tcl_WriteRaw(cd->parent, cd->outBuffer, written) < 0) { + /* TODO: is this the right way to do errors on close? + * Note: when close is called from FinalizeIOSubsystem then + * interp may be NULL */ + if (!TclInThreadExit() && interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error while finalizing file: %s", + Tcl_PosixError(interp))); } + result = TCL_ERROR; + break; } } while (e != Z_STREAM_END); - e = deflateEnd(&cd->outStream); + (void) deflateEnd(&cd->outStream); } else { - e = inflateEnd(&cd->inStream); + (void) inflateEnd(&cd->inStream); } /* * Release all memory. */ + if (cd->compDictObj) { + Tcl_DecrRefCount(cd->compDictObj); + cd->compDictObj = NULL; + } Tcl_DStringFree(&cd->decompressed); if (cd->inBuffer) { @@ -2994,47 +3040,18 @@ ZlibTransformInput( */ if (readBytes < 0) { - /* - * Report errors to caller. The state of the seek system is - * unchanged! - */ - - if ((Tcl_GetErrno() == EAGAIN) && (gotBytes > 0)) { - /* - * EAGAIN is a special situation. If we had some data before - * we report that instead of the request to re-try. - */ + /* See ReflectInput() in tclIORTrans.c */ + if (Tcl_InputBlocked(cd->parent) && (gotBytes > 0)) { return gotBytes; } *errorCodePtr = Tcl_GetErrno(); return -1; - } else if (readBytes == 0) { - /* - * Check wether we hit on EOF in 'parent' or not. If not, - * differentiate between blocking and non-blocking modes. In - * non-blocking mode we ran temporarily out of data. Signal this - * to the caller via EWOULDBLOCK and error return (-1). In the - * other cases we simply return what we got and let the caller - * wait for more. On the other hand, if we got an EOF we have to - * convert and flush all waiting partial data. - */ - - if (!Tcl_Eof(cd->parent)) { - /* - * The state of the seek system is unchanged! - */ - - if ((gotBytes == 0) && (cd->flags & ASYNC)) { - *errorCodePtr = EWOULDBLOCK; - return -1; - } - return gotBytes; - } - + } + if (readBytes == 0) { /* - * (Semi-)Eof in parent. + * Eof in parent. * * Now this is a bit different. The partial data waiting is * converted and returned. @@ -3052,12 +3069,6 @@ ZlibTransformInput( return gotBytes; } - - /* - * Reset eof, force caller to drain result buffer. - */ - - ((Channel *) cd->parent)->state->flags &= ~CHANNEL_EOF; } else /* readBytes > 0 */ { /* * Transform the read chunk, which was not empty. Anything we get @@ -3102,22 +3113,28 @@ ZlibTransformOutput( errorCodePtr); } + /* + * No zero-length writes. Flushes must be explicit. + */ + + if (toWrite == 0) { + return 0; + } + cd->outStream.next_in = (Bytef *) buf; cd->outStream.avail_in = toWrite; - do { - cd->outStream.next_out = (Bytef *) cd->outBuffer; - cd->outStream.avail_out = cd->outAllocated; - - e = deflate(&cd->outStream, Z_NO_FLUSH); - produced = cd->outAllocated - cd->outStream.avail_out; + while (cd->outStream.avail_in > 0) { + e = Deflate(&cd->outStream, cd->outBuffer, cd->outAllocated, + Z_NO_FLUSH, &produced); + if (e != Z_OK || produced == 0) { + break; + } - if (e == Z_OK && produced > 0) { - if (Tcl_WriteRaw(cd->parent, cd->outBuffer, produced) < 0) { - *errorCodePtr = Tcl_GetErrno(); - return -1; - } + if (Tcl_WriteRaw(cd->parent, cd->outBuffer, produced) < 0) { + *errorCodePtr = Tcl_GetErrno(); + return -1; } - } while (e == Z_OK && produced > 0 && cd->outStream.avail_in > 0); + } if (e == Z_OK) { return toWrite - cd->outStream.avail_in; @@ -3137,6 +3154,61 @@ ZlibTransformOutput( /* *---------------------------------------------------------------------- * + * ZlibTransformFlush -- + * + * How to perform a flush of a compressing transform. + * + *---------------------------------------------------------------------- + */ + +static int +ZlibTransformFlush( + Tcl_Interp *interp, + ZlibChannelData *cd, + int flushType) +{ + int e, len; + + cd->outStream.avail_in = 0; + do { + /* + * Get the bytes to go out of the compression engine. + */ + + e = Deflate(&cd->outStream, cd->outBuffer, cd->outAllocated, + flushType, &len); + if (e != Z_OK && e != Z_BUF_ERROR) { + ConvertError(interp, e, cd->outStream.adler); + return TCL_ERROR; + } + + /* + * Write the bytes we've received to the next layer. + */ + + if (len > 0 && Tcl_WriteRaw(cd->parent, cd->outBuffer, len) < 0) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "problem flushing channel: %s", + Tcl_PosixError(interp))); + return TCL_ERROR; + } + + /* + * If we get to this point, either we're in the Z_OK or the + * Z_BUF_ERROR state. In the former case, we're done. In the latter + * case, it's because there's more bytes to go than would fit in the + * buffer we provided, and we need to go round again to get some more. + * + * We also stop the loop if we would have done a zero-length write. + * Those can cause problems at the OS level. + */ + } while (len > 0 && e == Z_BUF_ERROR); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * ZlibTransformSetOption -- * * Writing side of [fconfigure] on our channel. @@ -3209,32 +3281,7 @@ ZlibTransformSetOption( /* not used */ * Try to actually do the flush now. */ - cd->outStream.avail_in = 0; - while (1) { - int e; - - cd->outStream.next_out = (Bytef *) cd->outBuffer; - cd->outStream.avail_out = cd->outAllocated; - - e = deflate(&cd->outStream, flushType); - if (e == Z_BUF_ERROR) { - break; - } else if (e != Z_OK) { - ConvertError(interp, e, cd->outStream.adler); - return TCL_ERROR; - } else if (cd->outStream.avail_out == 0) { - break; - } - - if (Tcl_WriteRaw(cd->parent, cd->outBuffer, - cd->outStream.next_out - (Bytef *) cd->outBuffer)<0) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "problem flushing channel: %s", - Tcl_PosixError(interp))); - return TCL_ERROR; - } - } - return TCL_OK; + return ZlibTransformFlush(interp, cd, flushType); } } else { if (optionName && strcmp(optionName, "-limit") == 0) { @@ -3338,10 +3385,13 @@ ZlibTransformGetOption( Tcl_DStringAppendElement(dsPtr, ""); } } else { - int len; - const char *str = Tcl_GetStringFromObj(cd->compDictObj, &len); + if (cd->compDictObj) { + int len; + const char *str = TclGetStringFromObj(cd->compDictObj, &len); - Tcl_DStringAppend(dsPtr, str, len); + Tcl_DStringAppend(dsPtr, str, len); + } + return TCL_OK; } } @@ -3543,7 +3593,6 @@ ZlibStackChannelTransform( ZlibChannelData *cd = ckalloc(sizeof(ZlibChannelData)); Tcl_Channel chan; int wbits = 0; - int e; if (mode != TCL_ZLIB_STREAM_DEFLATE && mode != TCL_ZLIB_STREAM_INFLATE) { Tcl_Panic("unknown mode: %d", mode); @@ -3597,43 +3646,35 @@ ZlibStackChannelTransform( */ if (mode == TCL_ZLIB_STREAM_INFLATE) { - e = inflateInit2(&cd->inStream, wbits); - if (e != Z_OK) { + if (inflateInit2(&cd->inStream, wbits) != Z_OK) { goto error; } cd->inAllocated = DEFAULT_BUFFER_SIZE; cd->inBuffer = ckalloc(cd->inAllocated); if (cd->flags & IN_HEADER) { - e = inflateGetHeader(&cd->inStream, &cd->inHeader.header); - if (e != Z_OK) { + if (inflateGetHeader(&cd->inStream, &cd->inHeader.header) != Z_OK) { goto error; } } if (cd->format == TCL_ZLIB_FORMAT_RAW && cd->compDictObj) { - e = SetInflateDictionary(&cd->inStream, cd->compDictObj); - if (e != Z_OK) { + if (SetInflateDictionary(&cd->inStream, cd->compDictObj) != Z_OK) { goto error; } - TclDecrRefCount(cd->compDictObj); - cd->compDictObj = NULL; } } else { - e = deflateInit2(&cd->outStream, level, Z_DEFLATED, wbits, - MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY); - if (e != Z_OK) { + if (deflateInit2(&cd->outStream, level, Z_DEFLATED, wbits, + MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY) != Z_OK) { goto error; } cd->outAllocated = DEFAULT_BUFFER_SIZE; cd->outBuffer = ckalloc(cd->outAllocated); if (cd->flags & OUT_HEADER) { - e = deflateSetHeader(&cd->outStream, &cd->outHeader.header); - if (e != Z_OK) { + if (deflateSetHeader(&cd->outStream, &cd->outHeader.header) != Z_OK) { goto error; } } if (cd->compDictObj) { - e = SetDeflateDictionary(&cd->outStream, cd->compDictObj); - if (e != Z_OK) { + if (SetDeflateDictionary(&cd->outStream, cd->compDictObj) != Z_OK) { goto error; } } @@ -3847,7 +3888,7 @@ TclZlibInit( * commands. */ - Tcl_Eval(interp, "namespace eval ::tcl::zlib {variable cmdcounter 0}"); + Tcl_EvalEx(interp, "namespace eval ::tcl::zlib {variable cmdcounter 0}", -1, 0); /* * Create the public scripted interface to this file's functionality. |