diff options
Diffstat (limited to 'generic')
97 files changed, 14999 insertions, 11270 deletions
diff --git a/generic/regc_color.c b/generic/regc_color.c index b7a571c..f5d6dfd 100644 --- a/generic/regc_color.c +++ b/generic/regc_color.c @@ -254,7 +254,14 @@ newcolor( * Oops, must allocate more. */ + if (cm->max == MAX_COLOR) { + CERR(REG_ECOLORS); + return COLORLESS; /* too many colors */ + } n = cm->ncds * 2; + if (n < MAX_COLOR + 1) { + n = MAX_COLOR + 1; + } if (cm->cd == cm->cdspace) { newCd = (struct colordesc *) MALLOC(n * sizeof(struct colordesc)); if (newCd != NULL) { diff --git a/generic/regc_locale.c b/generic/regc_locale.c index f3db471..d8664b5 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,97 +137,107 @@ 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}, + {0x3f7, 0x481}, {0x48a, 0x52f}, {0x531, 0x556}, {0x561, 0x587}, {0x5d0, 0x5ea}, {0x5f0, 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}, - {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}, - {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} + {0x800, 0x815}, {0x840, 0x858}, {0x8a0, 0x8b2}, {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}, {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}, {0x1401, 0x166c}, {0x166f, 0x167f}, + {0x1681, 0x169a}, {0x16a0, 0x16ea}, {0x16f1, 0x16f8}, {0x1700, 0x170c}, + {0x170e, 0x1711}, {0x1720, 0x1731}, {0x1740, 0x1751}, {0x1760, 0x176c}, + {0x176e, 0x1770}, {0x1780, 0x17b3}, {0x1820, 0x1877}, {0x1880, 0x18a8}, + {0x18b0, 0x18f5}, {0x1900, 0x191e}, {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, 0xa69d}, + {0xa6a0, 0xa6e5}, {0xa717, 0xa71f}, {0xa722, 0xa788}, {0xa78b, 0xa78e}, + {0xa790, 0xa7ad}, {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, 0xab5f}, {0xabc0, 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 ,{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}, + {0x10300, 0x1031f}, {0x10330, 0x10340}, {0x10342, 0x10349}, {0x10350, 0x10375}, + {0x10380, 0x1039d}, {0x103a0, 0x103c3}, {0x103c8, 0x103cf}, {0x10400, 0x1049d}, + {0x10500, 0x10527}, {0x10530, 0x10563}, {0x10600, 0x10736}, {0x10740, 0x10755}, + {0x10760, 0x10767}, {0x10800, 0x10805}, {0x1080a, 0x10835}, {0x1083f, 0x10855}, + {0x10860, 0x10876}, {0x10880, 0x1089e}, {0x10900, 0x10915}, {0x10920, 0x10939}, {0x10980, 0x109b7}, {0x10a10, 0x10a13}, {0x10a15, 0x10a17}, {0x10a19, 0x10a33}, - {0x10a60, 0x10a7c}, {0x10b00, 0x10b35}, {0x10b40, 0x10b55}, {0x10b60, 0x10b72}, + {0x10a60, 0x10a7c}, {0x10a80, 0x10a9c}, {0x10ac0, 0x10ac7}, {0x10ac9, 0x10ae4}, + {0x10b00, 0x10b35}, {0x10b40, 0x10b55}, {0x10b60, 0x10b72}, {0x10b80, 0x10b91}, {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}, + {0x11103, 0x11126}, {0x11150, 0x11172}, {0x11183, 0x111b2}, {0x111c1, 0x111c4}, + {0x11200, 0x11211}, {0x11213, 0x1122b}, {0x112b0, 0x112de}, {0x11305, 0x1130c}, + {0x11313, 0x11328}, {0x1132a, 0x11330}, {0x11335, 0x11339}, {0x1135d, 0x11361}, + {0x11480, 0x114af}, {0x11580, 0x115ae}, {0x11600, 0x1162f}, {0x11680, 0x116aa}, + {0x118a0, 0x118df}, {0x11ac0, 0x11af8}, {0x12000, 0x12398}, {0x13000, 0x1342e}, + {0x16800, 0x16a38}, {0x16a40, 0x16a5e}, {0x16ad0, 0x16aed}, {0x16b00, 0x16b2f}, + {0x16b40, 0x16b43}, {0x16b63, 0x16b77}, {0x16b7d, 0x16b8f}, {0x16f00, 0x16f44}, + {0x16f93, 0x16f9f}, {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}, {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} + {0x1d7aa, 0x1d7c2}, {0x1d7c4, 0x1d7cb}, {0x1e800, 0x1e8c4}, {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} #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, @@ -241,14 +251,16 @@ static const chr alphaCharTable[] = { 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 + 0x303b, 0x303c, 0xa62a, 0xa62b, 0xa7b0, 0xa7b1, 0xa8fb, 0xa9cf, 0xaa7a, + 0xaab1, 0xaab5, 0xaab6, 0xaac0, 0xaac2, 0xab64, 0xab65, 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 + 0x11176, 0x111da, 0x1130f, 0x11310, 0x11332, 0x11333, 0x1133d, 0x114c4, 0x114c5, + 0x114c7, 0x11644, 0x118ff, 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 #endif }; @@ -259,17 +271,19 @@ static const chr alphaCharTable[] = { */ static const crange controlRangeTable[] = { - {0x7f, 0x9f}, {0x600, 0x604}, {0x200b, 0x200f}, {0x202a, 0x202e}, - {0x2060, 0x2064}, {0x206a, 0x206f}, {0xe000, 0xf8ff}, {0xfff9, 0xfffb} + {0x0, 0x1f}, {0x7f, 0x9f}, {0x600, 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} + ,{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 + 0xad, 0x61c, 0x6dd, 0x70f, 0x180e, 0xfeff #if TCL_UTF_MAX > 4 ,0x110bd, 0xe0001 #endif @@ -285,15 +299,18 @@ 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} + {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 TCL_UTF_MAX > 4 ,{0x104a0, 0x104a9}, {0x11066, 0x1106f}, {0x110f0, 0x110f9}, {0x11136, 0x1113f}, - {0x111d0, 0x111d9}, {0x116c0, 0x116c9}, {0x1d7ce, 0x1d7ff} + {0x111d0, 0x111d9}, {0x112f0, 0x112f9}, {0x114d0, 0x114d9}, {0x11650, 0x11659}, + {0x116c0, 0x116c9}, {0x118e0, 0x118e9}, {0x16a60, 0x16a69}, {0x16b50, 0x16b59}, + {0x1d7ce, 0x1d7ff} #endif }; @@ -315,15 +332,18 @@ static const crange punctRangeTable[] = { {0x17d8, 0x17da}, {0x1800, 0x180a}, {0x1aa0, 0x1aa6}, {0x1aa8, 0x1aad}, {0x1b5a, 0x1b60}, {0x1bfc, 0x1bff}, {0x1c3b, 0x1c3f}, {0x1cc0, 0x1cc7}, {0x2010, 0x2027}, {0x2030, 0x2043}, {0x2045, 0x2051}, {0x2053, 0x205e}, - {0x2768, 0x2775}, {0x27e6, 0x27ef}, {0x2983, 0x2998}, {0x29d8, 0x29db}, - {0x2cf9, 0x2cfc}, {0x2e00, 0x2e2e}, {0x2e30, 0x2e3b}, {0x3001, 0x3003}, - {0x3008, 0x3011}, {0x3014, 0x301f}, {0xa60d, 0xa60f}, {0xa6f2, 0xa6f7}, - {0xa874, 0xa877}, {0xa8f8, 0xa8fa}, {0xa9c1, 0xa9cd}, {0xaa5c, 0xaa5f}, - {0xfe10, 0xfe19}, {0xfe30, 0xfe52}, {0xfe54, 0xfe61}, {0xff01, 0xff03}, - {0xff05, 0xff0a}, {0xff0c, 0xff0f}, {0xff3b, 0xff3d}, {0xff5f, 0xff65} + {0x2308, 0x230b}, {0x2768, 0x2775}, {0x27e6, 0x27ef}, {0x2983, 0x2998}, + {0x29d8, 0x29db}, {0x2cf9, 0x2cfc}, {0x2e00, 0x2e2e}, {0x2e30, 0x2e42}, + {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} + ,{0x10100, 0x10102}, {0x10a50, 0x10a58}, {0x10af0, 0x10af6}, {0x10b39, 0x10b3f}, + {0x10b99, 0x10b9c}, {0x11047, 0x1104d}, {0x110be, 0x110c1}, {0x11140, 0x11143}, + {0x111c5, 0x111c8}, {0x11238, 0x1123d}, {0x115c1, 0x115c9}, {0x11641, 0x11643}, + {0x12470, 0x12474}, {0x16b37, 0x16b3b} #endif }; @@ -343,7 +363,8 @@ static const chr punctCharTable[] = { 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 + ,0x1039f, 0x103d0, 0x1056f, 0x10857, 0x1091f, 0x1093f, 0x10a7f, 0x110bb, 0x110bc, + 0x11174, 0x11175, 0x111cd, 0x114c6, 0x16a6e, 0x16a6f, 0x16af5, 0x16b44, 0x1bc9f #endif }; @@ -381,15 +402,16 @@ static const crange lowerRangeTable[] = { {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} + {0xa771, 0xa778}, {0xa793, 0xa795}, {0xab30, 0xab5a}, {0xfb00, 0xfb06}, + {0xfb13, 0xfb17}, {0xff41, 0xff5a} #if TCL_UTF_MAX > 4 - ,{0x10428, 0x1044f}, {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} + ,{0x10428, 0x1044f}, {0x118c0, 0x118df}, {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} #endif }; @@ -425,39 +447,41 @@ 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 + 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, + 0xa7fa, 0xab64, 0xab65 #if TCL_UTF_MAX > 4 ,0x1d4bb, 0x1d7cb #endif @@ -479,14 +503,15 @@ static const crange upperRangeTable[] = { {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} + {0xa7aa, 0xa7ad}, {0xff21, 0xff3a} #if TCL_UTF_MAX > 4 - ,{0x10400, 0x10427}, {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} + ,{0x10400, 0x10427}, {0x118a0, 0x118bf}, {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} #endif }; @@ -509,52 +534,54 @@ 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 + 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, 0xa7b0, + 0xa7b1 #if TCL_UTF_MAX > 4 ,0x1d49c, 0x1d49e, 0x1d49f, 0x1d4a2, 0x1d4a5, 0x1d4a6, 0x1d504, 0x1d505, 0x1d538, 0x1d539, 0x1d546, 0x1d7ca @@ -568,34 +595,34 @@ 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}, - {0x993, 0x9a8}, {0x9aa, 0x9b0}, {0x9b6, 0x9b9}, {0x9bc, 0x9c4}, - {0x9cb, 0x9ce}, {0x9df, 0x9e3}, {0x9e6, 0x9fb}, {0xa01, 0xa03}, - {0xa05, 0xa0a}, {0xa13, 0xa28}, {0xa2a, 0xa30}, {0xa3e, 0xa42}, - {0xa4b, 0xa4d}, {0xa59, 0xa5c}, {0xa66, 0xa75}, {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}, + {0x21, 0x7e}, {0xa1, 0xac}, {0xae, 0x377}, {0x37a, 0x37f}, + {0x384, 0x38a}, {0x38e, 0x3a1}, {0x3a3, 0x52f}, {0x531, 0x556}, + {0x559, 0x55f}, {0x561, 0x587}, {0x58d, 0x58f}, {0x591, 0x5c7}, + {0x5d0, 0x5ea}, {0x5f0, 0x5f4}, {0x606, 0x61b}, {0x61e, 0x6dc}, + {0x6de, 0x70d}, {0x710, 0x74a}, {0x74d, 0x7b1}, {0x7c0, 0x7fa}, + {0x800, 0x82d}, {0x830, 0x83e}, {0x840, 0x85b}, {0x8a0, 0x8b2}, + {0x8e4, 0x983}, {0x985, 0x98c}, {0x993, 0x9a8}, {0x9aa, 0x9b0}, + {0x9b6, 0x9b9}, {0x9bc, 0x9c4}, {0x9cb, 0x9ce}, {0x9df, 0x9e3}, + {0x9e6, 0x9fb}, {0xa01, 0xa03}, {0xa05, 0xa0a}, {0xa13, 0xa28}, + {0xa2a, 0xa30}, {0xa3e, 0xa42}, {0xa4b, 0xa4d}, {0xa59, 0xa5c}, + {0xa66, 0xa75}, {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}, {0xc00, 0xc03}, {0xc05, 0xc0c}, + {0xc0e, 0xc10}, {0xc12, 0xc28}, {0xc2a, 0xc39}, {0xc3d, 0xc44}, + {0xc46, 0xc48}, {0xc4a, 0xc4d}, {0xc60, 0xc63}, {0xc66, 0xc6f}, + {0xc78, 0xc7f}, {0xc81, 0xc83}, {0xc85, 0xc8c}, {0xc8e, 0xc90}, + {0xc92, 0xca8}, {0xcaa, 0xcb3}, {0xcb5, 0xcb9}, {0xcbc, 0xcc4}, + {0xcc6, 0xcc8}, {0xcca, 0xccd}, {0xce0, 0xce3}, {0xce6, 0xcef}, + {0xd01, 0xd03}, {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}, + {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}, @@ -604,105 +631,123 @@ static const crange graphRangeTable[] = { {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}, + {0x13a0, 0x13f4}, {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}, + {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} + {0x1ab0, 0x1abe}, {0x1b00, 0x1b4b}, {0x1b50, 0x1b7c}, {0x1b80, 0x1bf3}, + {0x1bfc, 0x1c37}, {0x1c3b, 0x1c49}, {0x1c4d, 0x1c7f}, {0x1cc0, 0x1cc7}, + {0x1cd0, 0x1cf6}, {0x1d00, 0x1df5}, {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, 0x20bd}, + {0x20d0, 0x20f0}, {0x2100, 0x2189}, {0x2190, 0x23fa}, {0x2400, 0x2426}, + {0x2440, 0x244a}, {0x2460, 0x2b73}, {0x2b76, 0x2b95}, {0x2b98, 0x2bb9}, + {0x2bbd, 0x2bc8}, {0x2bca, 0x2bd1}, {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, 0x2e42}, {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, 0xa69d}, + {0xa69f, 0xa6f7}, {0xa700, 0xa78e}, {0xa790, 0xa7ad}, {0xa7f7, 0xa82b}, + {0xa830, 0xa839}, {0xa840, 0xa877}, {0xa880, 0xa8c4}, {0xa8ce, 0xa8d9}, + {0xa8e0, 0xa8fb}, {0xa900, 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, 0xab5f}, {0xabc0, 0xabed}, {0xabf0, 0xabf9}, {0xac00, 0xd7a3}, + {0xd7b0, 0xd7c6}, {0xd7cb, 0xd7fb}, {0xdc00, 0xdc3e}, {0xdc40, 0xdc7e}, + {0xdc80, 0xdcbe}, {0xdcc0, 0xdcfe}, {0xdd80, 0xddbe}, {0xddc0, 0xddfe}, + {0xde80, 0xdebe}, {0xdec0, 0xdefe}, {0xdf00, 0xdf3e}, {0xdf40, 0xdf7e}, + {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, 0xfe2d}, {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 ,{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}, - {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} + {0x10137, 0x1018c}, {0x10190, 0x1019b}, {0x101d0, 0x101fd}, {0x10280, 0x1029c}, + {0x102a0, 0x102d0}, {0x102e0, 0x102fb}, {0x10300, 0x10323}, {0x10330, 0x1034a}, + {0x10350, 0x1037a}, {0x10380, 0x1039d}, {0x1039f, 0x103c3}, {0x103c8, 0x103d5}, + {0x10400, 0x1049d}, {0x104a0, 0x104a9}, {0x10500, 0x10527}, {0x10530, 0x10563}, + {0x10600, 0x10736}, {0x10740, 0x10755}, {0x10760, 0x10767}, {0x10800, 0x10805}, + {0x1080a, 0x10835}, {0x1083f, 0x10855}, {0x10857, 0x1089e}, {0x108a7, 0x108af}, + {0x10900, 0x1091b}, {0x1091f, 0x10939}, {0x10980, 0x109b7}, {0x10a00, 0x10a03}, + {0x10a0c, 0x10a13}, {0x10a15, 0x10a17}, {0x10a19, 0x10a33}, {0x10a38, 0x10a3a}, + {0x10a3f, 0x10a47}, {0x10a50, 0x10a58}, {0x10a60, 0x10a9f}, {0x10ac0, 0x10ae6}, + {0x10aeb, 0x10af6}, {0x10b00, 0x10b35}, {0x10b39, 0x10b55}, {0x10b58, 0x10b72}, + {0x10b78, 0x10b91}, {0x10b99, 0x10b9c}, {0x10ba9, 0x10baf}, {0x10c00, 0x10c48}, + {0x10e60, 0x10e7e}, {0x11000, 0x1104d}, {0x11052, 0x1106f}, {0x1107f, 0x110bc}, + {0x110be, 0x110c1}, {0x110d0, 0x110e8}, {0x110f0, 0x110f9}, {0x11100, 0x11134}, + {0x11136, 0x11143}, {0x11150, 0x11176}, {0x11180, 0x111c8}, {0x111d0, 0x111da}, + {0x111e1, 0x111f4}, {0x11200, 0x11211}, {0x11213, 0x1123d}, {0x112b0, 0x112ea}, + {0x112f0, 0x112f9}, {0x11301, 0x11303}, {0x11305, 0x1130c}, {0x11313, 0x11328}, + {0x1132a, 0x11330}, {0x11335, 0x11339}, {0x1133c, 0x11344}, {0x1134b, 0x1134d}, + {0x1135d, 0x11363}, {0x11366, 0x1136c}, {0x11370, 0x11374}, {0x11480, 0x114c7}, + {0x114d0, 0x114d9}, {0x11580, 0x115b5}, {0x115b8, 0x115c9}, {0x11600, 0x11644}, + {0x11650, 0x11659}, {0x11680, 0x116b7}, {0x116c0, 0x116c9}, {0x118a0, 0x118f2}, + {0x11ac0, 0x11af8}, {0x12000, 0x12398}, {0x12400, 0x1246e}, {0x12470, 0x12474}, + {0x13000, 0x1342e}, {0x16800, 0x16a38}, {0x16a40, 0x16a5e}, {0x16a60, 0x16a69}, + {0x16ad0, 0x16aed}, {0x16af0, 0x16af5}, {0x16b00, 0x16b45}, {0x16b50, 0x16b59}, + {0x16b5b, 0x16b61}, {0x16b63, 0x16b77}, {0x16b7d, 0x16b8f}, {0x16f00, 0x16f44}, + {0x16f50, 0x16f7e}, {0x16f8f, 0x16f9f}, {0x1bc00, 0x1bc6a}, {0x1bc70, 0x1bc7c}, + {0x1bc80, 0x1bc88}, {0x1bc90, 0x1bc99}, {0x1bc9c, 0x1bc9f}, {0x1d000, 0x1d0f5}, + {0x1d100, 0x1d126}, {0x1d129, 0x1d172}, {0x1d17b, 0x1d1dd}, {0x1d200, 0x1d245}, + {0x1d300, 0x1d356}, {0x1d360, 0x1d371}, {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}, {0x1e800, 0x1e8c4}, {0x1e8c7, 0x1e8d6}, + {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, 0x1f12e}, {0x1f130, 0x1f16b}, {0x1f170, 0x1f19a}, + {0x1f1e6, 0x1f202}, {0x1f210, 0x1f23a}, {0x1f240, 0x1f248}, {0x1f300, 0x1f32c}, + {0x1f330, 0x1f37d}, {0x1f380, 0x1f3ce}, {0x1f3d4, 0x1f3f7}, {0x1f400, 0x1f4fe}, + {0x1f500, 0x1f54a}, {0x1f550, 0x1f579}, {0x1f57b, 0x1f5a3}, {0x1f5a5, 0x1f642}, + {0x1f645, 0x1f6cf}, {0x1f6e0, 0x1f6ec}, {0x1f6f0, 0x1f6f3}, {0x1f700, 0x1f773}, + {0x1f780, 0x1f7d4}, {0x1f800, 0x1f80b}, {0x1f810, 0x1f847}, {0x1f850, 0x1f859}, + {0x1f860, 0x1f887}, {0x1f890, 0x1f8ad}, {0x20000, 0x2a6d6}, {0x2a700, 0x2b734}, + {0x2b740, 0x2b81d}, {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 + 0x38c, 0x589, 0x58a, 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, 0xc58, 0xc59, 0xcd5, + 0xcd6, 0xcde, 0xcf1, 0xcf2, 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, 0x1cf8, 0x1cf9, 0x1f59, 0x1f5b, 0x1f5d, 0x2070, 0x2071, + 0x2d27, 0x2d2d, 0x2d6f, 0x2d70, 0xa7b0, 0xa7b1, 0xab64, 0xab65, 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 + ,0x1003c, 0x1003d, 0x101a0, 0x1056f, 0x10808, 0x10837, 0x10838, 0x1083c, 0x1093f, + 0x109be, 0x109bf, 0x10a05, 0x10a06, 0x111cd, 0x1130f, 0x11310, 0x11332, 0x11333, + 0x11347, 0x11348, 0x11357, 0x118ff, 0x16a6e, 0x16a6f, 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 #endif }; diff --git a/generic/regc_nfa.c b/generic/regc_nfa.c index 4fb3ea6..42489dd 100644 --- a/generic/regc_nfa.c +++ b/generic/regc_nfa.c @@ -497,6 +497,62 @@ freearc( } /* + - hasnonemptyout - Does state have a non-EMPTY out arc? + ^ static int hasnonemptyout(struct state *); + */ +static int +hasnonemptyout( + struct state *s) +{ + struct arc *a; + + for (a = s->outs; a != NULL; a = a->outchain) { + if (a->type != EMPTY) { + return 1; + } + } + return 0; +} + +/* + - nonemptyouts - count non-EMPTY out arcs of a state + ^ static int nonemptyouts(struct state *); + */ +static int +nonemptyouts( + struct state *s) +{ + int n = 0; + struct arc *a; + + for (a = s->outs; a != NULL; a = a->outchain) { + if (a->type != EMPTY) { + n++; + } + } + return n; +} + +/* + - nonemptyins - count non-EMPTY in arcs of a state + ^ static int nonemptyins(struct state *); + */ +static int +nonemptyins( + struct state *s) +{ + int n = 0; + struct arc *a; + + for (a = s->ins; a != NULL; a = a->inchain) { + if (a->type != EMPTY) { + n++; + } + } + return n; +} + +/* - findarc - find arc, if any, from given source with given type and color * If there is more than one such arc, the result is random. ^ static struct arc *findarc(struct state *, int, pcolor); @@ -559,21 +615,25 @@ moveins( } /* - - copyins - copy all in arcs of a state to another state - ^ static void copyins(struct nfa *, struct state *, struct state *); + - copyins - copy in arcs of a state to another state + * Either all arcs, or only non-empty ones as determined by all value. + ^ static VOID copyins(struct nfa *, struct state *, struct state *, int); */ static void copyins( struct nfa *nfa, struct state *oldState, - struct state *newState) + struct state *newState, + int all) { struct arc *a; assert(oldState != newState); for (a=oldState->ins ; a!=NULL ; a=a->inchain) { - cparc(nfa, a, a->from, newState); + if (all || a->type != EMPTY) { + cparc(nfa, a, a->from, newState); + } } } @@ -598,21 +658,25 @@ moveouts( } /* - - copyouts - copy all out arcs of a state to another state - ^ static void copyouts(struct nfa *, struct state *, struct state *); + - copyouts - copy out arcs of a state to another state + * Either all arcs, or only non-empty ones as determined by all value. + ^ static VOID copyouts(struct nfa *, struct state *, struct state *, int); */ static void copyouts( struct nfa *nfa, struct state *oldState, - struct state *newState) + struct state *newState, + int all) { struct arc *a; assert(oldState != newState); for (a=oldState->outs ; a!=NULL ; a=a->outchain) { - cparc(nfa, a, newState, a->to); + if (all || a->type != EMPTY) { + cparc(nfa, a, newState, a->to); + } } } @@ -759,7 +823,9 @@ duptraverse( * Arbitrary depth limit. Needs tuning, but this value is sufficient to * make all normal tests (not reg-33.14) pass. */ -#define DUPTRAVERSE_MAX_DEPTH 500 +#ifndef DUPTRAVERSE_MAX_DEPTH +#define DUPTRAVERSE_MAX_DEPTH 15000 +#endif if (depth++ > DUPTRAVERSE_MAX_DEPTH) { NERR(REG_ESPACE); @@ -968,9 +1034,9 @@ pull( if (NISERR()) { return 0; } - assert(to != from); /* con is not an inarc */ - copyins(nfa, from, s); /* duplicate inarcs */ - cparc(nfa, con, s, to); /* move constraint arc */ + assert(to != from); /* con is not an inarc */ + copyins(nfa, from, s, 1); /* duplicate inarcs */ + cparc(nfa, con, s, to); /* move constraint arc */ freearc(nfa, con); from = s; con = from->outs; @@ -1128,7 +1194,7 @@ push( if (NISERR()) { return 0; } - copyouts(nfa, to, s); /* duplicate outarcs */ + copyouts(nfa, to, s, 1); /* duplicate outarcs */ cparc(nfa, con, from, s); /* move constraint */ freearc(nfa, con); to = s; @@ -1245,100 +1311,209 @@ fixempties( FILE *f) /* for debug output; NULL none */ { struct state *s; + struct state *s2; struct state *nexts; struct arc *a; struct arc *nexta; - int progress; /* - * Find and eliminate empties until there are no more. + * First, get rid of any states whose sole out-arc is an EMPTY, + * since they're basically just aliases for their successor. The + * parsing algorithm creates enough of these that it's worth + * special-casing this. */ + for (s = nfa->states; s != NULL && !NISERR(); s = nexts) { + nexts = s->next; + if (s->flag || s->nouts != 1) { + continue; + } + a = s->outs; + assert(a != NULL && a->outchain == NULL); + if (a->type != EMPTY) { + continue; + } + if (s != a->to) { + moveins(nfa, s, a->to); + } + dropstate(nfa, s); + } - do { - progress = 0; - for (s = nfa->states; s != NULL && !NISERR() - && s->no != FREESTATE; s = nexts) { - nexts = s->next; - for (a = s->outs; a != NULL && !NISERR(); a = nexta) { - nexta = a->outchain; - if (a->type == EMPTY && unempty(nfa, a)) { - progress = 1; - } - assert(nexta == NULL || s->no != FREESTATE); + /* + * Similarly, get rid of any state with a single EMPTY in-arc, by + * folding it into its predecessor. + */ + for (s = nfa->states; s != NULL && !NISERR(); s = nexts) { + nexts = s->next; + /* Ensure tmp fields are clear for next step */ + assert(s->tmp = NULL); + if (s->flag || s->nins != 1) { + continue; + } + a = s->ins; + assert(a != NULL && a->inchain == NULL); + if (a->type != EMPTY) { + continue; + } + if (s != a->from) { + moveouts(nfa, s, a->from); + } + dropstate(nfa, s); + } + + /* + * For each remaining NFA state, find all other states that are + * reachable from it by a chain of one or more EMPTY arcs. Then + * generate new arcs that eliminate the need for each such chain. + * + * If we just do this straightforwardly, the algorithm gets slow in + * complex graphs, because the same arcs get copied to all + * intermediate states of an EMPTY chain, and then uselessly pushed + * repeatedly to the chain's final state; we waste a lot of time in + * newarc's duplicate checking. To improve matters, we decree that + * any state with only EMPTY out-arcs is "doomed" and will not be + * part of the final NFA. That can be ensured by not adding any new + * out-arcs to such a state. Having ensured that, we need not update + * the state's in-arcs list either; all arcs that might have gotten + * pushed forward to it will just get pushed directly to successor + * states. This eliminates most of the useless duplicate arcs. + */ + for (s = nfa->states; s != NULL && !NISERR(); s = s->next) { + for (s2 = emptyreachable(s, s); s2 != s && !NISERR(); + s2 = nexts) { + /* + * If s2 is doomed, we decide that (1) we will always push + * arcs forward to it, not pull them back to s; and (2) we + * can optimize away the push-forward, per comment above. + * So do nothing. + */ + if (s2->flag || hasnonemptyout(s2)) { + replaceempty(nfa, s, s2); } + + /* Reset the tmp fields as we walk back */ + nexts = s2->tmp; + s2->tmp = NULL; } - if (progress && f != NULL) { - dumpnfa(nfa, f); + s->tmp = NULL; + } + if (NISERR()) { + return; + } + + /* + * Remove all the EMPTY arcs, since we don't need them anymore. + */ + for (s = nfa->states; s != NULL; s = s->next) { + for (a = s->outs; a != NULL; a = nexta) { + nexta = a->outchain; + if (a->type == EMPTY) { + freearc(nfa, a); + } } - } while (progress && !NISERR()); + } + + /* + * And remove any states that have become useless. (This cleanup is + * not very thorough, and would be even less so if we tried to + * combine it with the previous step; but cleanup() will take care + * of anything we miss.) + */ + for (s = nfa->states; s != NULL; s = nexts) { + nexts = s->next; + if ((s->nins == 0 || s->nouts == 0) && !s->flag) { + dropstate(nfa, s); + } + } + + if (f != NULL) { + dumpnfa(nfa, f); + } } /* - - unempty - optimize out an EMPTY arc, if possible - * Actually, as it stands this function always succeeds, but the return value - * is kept with an eye on possible future changes. - ^ static int unempty(struct nfa *, struct arc *); + - emptyreachable - recursively find all states reachable from s by EMPTY arcs + * The return value is the last such state found. Its tmp field links back + * to the next-to-last such state, and so on back to s, so that all these + * states can be located without searching the whole NFA. + * The maximum recursion depth here is equal to the length of the longest + * loop-free chain of EMPTY arcs, which is surely no more than the size of + * the NFA, and in practice will be a lot less than that. + ^ static struct state *emptyreachable(struct state *, struct state *); */ -static int /* 0 couldn't, 1 could */ -unempty( - struct nfa *nfa, - struct arc *a) +static struct state * +emptyreachable( + struct state *s, + struct state *lastfound) { - struct state *from = a->from; - struct state *to = a->to; - int usefrom; /* work on from, as opposed to to? */ - - assert(a->type == EMPTY); - assert(from != nfa->pre && to != nfa->post); + struct arc *a; - if (from == to) { /* vacuous loop */ - freearc(nfa, a); - return 1; + s->tmp = lastfound; + lastfound = s; + for (a = s->outs; a != NULL; a = a->outchain) { + if (a->type == EMPTY && a->to->tmp == NULL) { + lastfound = emptyreachable(a->to, lastfound); + } } + return lastfound; +} + +/* + - replaceempty - replace an EMPTY arc chain with some non-empty arcs + * The EMPTY arc(s) should be deleted later, but we can't do it here because + * they may still be needed to identify other arc chains during fixempties(). + ^ static void replaceempty(struct nfa *, struct state *, struct state *); + */ +static void +replaceempty( + struct nfa *nfa, + struct state *from, + struct state *to) +{ + int fromouts; + int toins; + + assert(from != to); /* - * Decide which end to work on. + * Create replacement arcs that bypass the need for the EMPTY chain. We + * can do this either by pushing arcs forward (linking directly from + * "from"'s predecessors to "to") or by pulling them back (linking + * directly from "from" to "to"'s successors). In general, we choose + * whichever way creates greater fan-out or fan-in, so as to improve the + * odds of reducing the other state to zero in-arcs or out-arcs and + * thereby being able to delete it. However, if "from" is doomed (has no + * non-EMPTY out-arcs), we must keep it so, so always push forward in that + * case. + * + * The fan-out/fan-in comparison should count only non-EMPTY arcs. If + * "from" is doomed, we can skip counting "to"'s arcs, since we want to + * force taking the copynonemptyins path in that case. */ + fromouts = nonemptyouts(from); + toins = (fromouts == 0) ? 1 : nonemptyins(to); - usefrom = 1; /* default: attack from */ - if (from->nouts > to->nins) { - usefrom = 0; - } else if (from->nouts == to->nins) { - /* - * Decide on secondary issue: move/copy fewest arcs. - */ - - if (from->nins > to->nouts) { - usefrom = 0; - } + if (fromouts > toins) { + copyouts(nfa, to, from, 0); + return; + } + if (fromouts < toins) { + copyins(nfa, from, to, 0); + return; } - freearc(nfa, a); - if (usefrom) { - if (from->nouts == 0) { - /* - * Was the state's only outarc. - */ - - moveins(nfa, from, to); - freestate(nfa, from); - } else { - copyins(nfa, from, to); - } - } else { - if (to->nins == 0) { - /* - * Was the state's only inarc. - */ - - moveouts(nfa, to, from); - freestate(nfa, to); - } else { - copyouts(nfa, to, from); - } + /* + * fromouts == toins. Decide on secondary issue: copy fewest arcs. + * + * Doesn't seem to be worth the trouble to exclude empties from these + * comparisons; that takes extra time and doesn't seem to improve the + * resulting graph much. + */ + if (from->nins > to->nouts) { + copyouts(nfa, to, from, 0); + return; } - return 1; + copyins(nfa, from, to, 0); } /* diff --git a/generic/regcomp.c b/generic/regcomp.c index 65555aa..c93eb24 100644 --- a/generic/regcomp.c +++ b/generic/regcomp.c @@ -121,12 +121,15 @@ static void destroystate(struct nfa *, struct state *); static void newarc(struct nfa *, int, pcolor, struct state *, struct state *); static struct arc *allocarc(struct nfa *, struct state *); static void freearc(struct nfa *, struct arc *); +static int hasnonemptyout(struct state *); +static int nonemptyouts(struct state *); +static int nonemptyins(struct state *); static struct arc *findarc(struct state *, int, pcolor); static void cparc(struct nfa *, struct arc *, struct state *, struct state *); static void moveins(struct nfa *, struct state *, struct state *); -static void copyins(struct nfa *, struct state *, struct state *); +static void copyins(struct nfa *, struct state *, struct state *, int); static void moveouts(struct nfa *, struct state *, struct state *); -static void copyouts(struct nfa *, struct state *, struct state *); +static void copyouts(struct nfa *, struct state *, struct state *, int); static void cloneouts(struct nfa *, struct state *, struct state *, struct state *, int); static void delsub(struct nfa *, struct state *, struct state *); static void deltraverse(struct nfa *, struct state *, struct state *); @@ -144,7 +147,8 @@ static int push(struct nfa *, struct arc *); #define COMPATIBLE 3 /* compatible but not satisfied yet */ static int combine(struct arc *, struct arc *); static void fixempties(struct nfa *, FILE *); -static int unempty(struct nfa *, struct arc *); +static struct state *emptyreachable(struct state *, struct state *); +static void replaceempty(struct nfa *, struct state *, struct state *); static void cleanup(struct nfa *); static void markreachable(struct nfa *, struct state *, struct state *, struct state *); static void markcanreach(struct nfa *, struct state *, struct state *, struct state *); @@ -607,7 +611,7 @@ makesearch( for (s=slist ; s!=NULL ; s=s2) { s2 = newstate(nfa); - copyouts(nfa, s, s2); + copyouts(nfa, s, s2, 1); for (a=s->ins ; a!=NULL ; a=b) { b = a->inchain; @@ -738,6 +742,7 @@ parsebranch( /* NB, recursion in parseqatom() may swallow rest of branch */ parseqatom(v, stopper, type, lp, right, t); + NOERRN(); } if (!seencontent) { /* empty branch */ @@ -1234,6 +1239,7 @@ parseqatom( EMPTYARC(atom->end, rp); t->right = subre(v, '=', 0, atom->end, rp); } + NOERR(); assert(SEE('|') || SEE(stopper) || SEE(EOS)); t->flags |= COMBINE(t->flags, t->right->flags); top->flags |= COMBINE(top->flags, t->flags); diff --git a/generic/regerrs.h b/generic/regerrs.h index 259c0cb..72548ff 100644 --- a/generic/regerrs.h +++ b/generic/regerrs.h @@ -17,3 +17,4 @@ { REG_MIXED, "REG_MIXED", "character widths of regex and string differ" }, { REG_BADOPT, "REG_BADOPT", "invalid embedded option" }, { REG_ETOOBIG, "REG_ETOOBIG", "nfa has too many states" }, +{ REG_ECOLORS, "REG_ECOLORS", "too many colors" }, diff --git a/generic/regex.h b/generic/regex.h index d6d46ce..9466fbb 100644 --- a/generic/regex.h +++ b/generic/regex.h @@ -281,6 +281,7 @@ typedef struct { #define REG_MIXED 17 /* character widths of regex and string differ */ #define REG_BADOPT 18 /* invalid embedded option */ #define REG_ETOOBIG 19 /* nfa has too many states */ +#define REG_ECOLORS 20 /* too many colors */ /* two specials for debugging and testing */ #define REG_ATOI 101 /* convert error-code name to number */ #define REG_ITOA 102 /* convert error-code number to name */ diff --git a/generic/regexec.c b/generic/regexec.c index 9b6a693..ad4b6e6 100644 --- a/generic/regexec.c +++ b/generic/regexec.c @@ -504,12 +504,7 @@ complicatedFindLoop( return er; } if ((shorter) ? end == estop : end == begin) { - /* - * No point in trying again. - */ - - *coldp = cold; - return REG_NOMATCH; + break; } /* diff --git a/generic/regguts.h b/generic/regguts.h index e57b8f8..b478e4c 100644 --- a/generic/regguts.h +++ b/generic/regguts.h @@ -145,6 +145,7 @@ typedef short color; /* colors of characters */ typedef int pcolor; /* what color promotes to */ +#define MAX_COLOR SHRT_MAX /* max color value */ #define COLORLESS (-1) /* impossible color */ #define WHITE 0 /* default color, parent of all others */ @@ -340,12 +341,12 @@ struct subre { #define CAP 010 /* capturing parens below */ #define BACKR 020 /* back reference below */ #define INUSE 0100 /* in use in final tree */ -#define LOCAL 03 /* bits which may not propagate up */ +#define NOPROP 03 /* bits which may not propagate up */ #define LMIX(f) ((f)<<2) /* LONGER -> MIXED */ #define SMIX(f) ((f)<<1) /* SHORTER -> MIXED */ -#define UP(f) (((f)&~LOCAL) | (LMIX(f) & SMIX(f) & MIXED)) +#define UP(f) (((f)&~NOPROP) | (LMIX(f) & SMIX(f) & MIXED)) #define MESSY(f) ((f)&(MIXED|CAP|BACKR)) -#define PREF(f) ((f)&LOCAL) +#define PREF(f) ((f)&NOPROP) #define PREF2(f1, f2) ((PREF(f1) != 0) ? PREF(f1) : PREF(f2)) #define COMBINE(f1, f2) (UP((f1)|(f2)) | PREF2(f1, f2)) short retry; /* index into retry memory */ @@ -366,7 +367,7 @@ struct subre { */ struct fns { - VOID FUNCPTR(free, (regex_t *)); + void FUNCPTR(free, (regex_t *)); }; /* diff --git a/generic/tcl.h b/generic/tcl.h index 7155453..e557290 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -56,10 +56,10 @@ extern "C" { #define TCL_MAJOR_VERSION 8 #define TCL_MINOR_VERSION 6 #define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE -#define TCL_RELEASE_SERIAL 0 +#define TCL_RELEASE_SERIAL 1 #define TCL_VERSION "8.6" -#define TCL_PATCH_LEVEL "8.6.0" +#define TCL_PATCH_LEVEL "8.6.1" /* *---------------------------------------------------------------------------- @@ -67,15 +67,12 @@ extern "C" { * 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 +# ifndef WIN32 +# define WIN32 # endif #endif @@ -83,11 +80,11 @@ extern "C" { * STRICT: See MSDN Article Q83456 */ -#ifdef __WIN32__ +#ifdef _WIN32 # ifndef STRICT # define STRICT # endif -#endif /* __WIN32__ */ +#endif /* _WIN32 */ /* * Utility macros: STRINGIFY takes an argument and wraps it in "" (double @@ -168,7 +165,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 +188,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 @@ -315,24 +312,26 @@ extern "C" { * VOID. This block is skipped under Cygwin and Mingw. */ -#if defined(__WIN32__) && !defined(HAVE_WINNT_IGNORE_VOID) +#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 *" * in ANSI C; maps them to type "char *" in non-ANSI systems. */ -#ifndef NO_VOID -# define VOID void -#else -# define VOID char +#ifndef __VXWORKS__ +# ifndef NO_VOID +# define VOID void +# else +# define VOID char +# endif #endif /* @@ -388,7 +387,7 @@ 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" @@ -398,7 +397,7 @@ typedef long LONG; # elif defined(__GNUC__) # define TCL_WIDE_INT_TYPE long long # define TCL_LL_MODIFIER "ll" -# else /* ! __WIN32__ && ! __GNUC__ */ +# else /* ! _WIN32 && ! __GNUC__ */ /* * Don't know what platform it is and configure hasn't discovered what is * going on for us. Try to guess... @@ -413,7 +412,7 @@ typedef long LONG; # define TCL_WIDE_INT_TYPE long long # endif # endif /* NO_LIMITS_H */ -# endif /* __WIN32__ */ +# endif /* _WIN32 */ #endif /* !TCL_WIDE_INT_TYPE & !TCL_WIDE_INT_IS_LONG */ #ifdef TCL_WIDE_INT_IS_LONG # undef TCL_WIDE_INT_TYPE @@ -445,7 +444,7 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; # define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val))) #endif /* TCL_WIDE_INT_IS_LONG */ -#if defined(__WIN32__) +#if defined(_WIN32) # ifdef __BORLANDC__ typedef struct stati64 Tcl_StatBuf; # elif defined(_WIN64) @@ -456,7 +455,7 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; typedef struct _stat32i64 Tcl_StatBuf; # endif /* _MSC_VER < 1400 */ #elif defined(__CYGWIN__) - typedef struct _stat32i64 { + typedef struct { dev_t st_dev; unsigned short st_ino; unsigned short st_mode; @@ -472,7 +471,7 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; struct {long tv_sec;} st_ctim; /* Here is a 4-byte gap */ } Tcl_StatBuf; -#elif defined(HAVE_STRUCT_STAT64) +#elif defined(HAVE_STRUCT_STAT64) && !defined(__APPLE__) typedef struct stat64 Tcl_StatBuf; #else typedef struct stat Tcl_StatBuf; @@ -504,11 +503,11 @@ typedef struct Tcl_Interp /* TIP #330: Strongly discourage extensions from using the string * result. */ #ifdef USE_INTERP_RESULT - char *result TCL_DEPRECATED_API("use Tcl_GetResult/Tcl_SetResult"); + char *result TCL_DEPRECATED_API("use Tcl_GetStringResult/Tcl_SetResult"); /* If the last command returned a string * result, this points to it. */ void (*freeProc) (char *blockPtr) - TCL_DEPRECATED_API("use Tcl_GetResult/Tcl_SetResult"); + TCL_DEPRECATED_API("use Tcl_GetStringResult/Tcl_SetResult"); /* Zero means the string result is statically * allocated. TCL_DYNAMIC means it was * allocated with ckalloc and should be freed @@ -560,7 +559,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); @@ -572,7 +571,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 @@ -2415,7 +2414,7 @@ const char * TclTomMathInitializeStubs(Tcl_Interp *interp, */ #define Tcl_Main(argc, argv, proc) Tcl_MainEx(argc, argv, proc, \ - (Tcl_FindExecutable(argv[0]), (Tcl_CreateInterp)())) + ((Tcl_CreateInterp)())) EXTERN void Tcl_MainEx(int argc, char **argv, Tcl_AppInitProc *appInitProc, Tcl_Interp *interp); EXTERN const char * Tcl_PkgInitStubsCheck(Tcl_Interp *interp, @@ -2434,9 +2433,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" /* @@ -2449,15 +2454,15 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); #ifdef TCL_MEM_DEBUG # define ckalloc(x) \ - ((VOID *) Tcl_DbCkalloc((unsigned)(x), __FILE__, __LINE__)) + ((void *) Tcl_DbCkalloc((unsigned)(x), __FILE__, __LINE__)) # define ckfree(x) \ Tcl_DbCkfree((char *)(x), __FILE__, __LINE__) # define ckrealloc(x,y) \ - ((VOID *) Tcl_DbCkrealloc((char *)(x), (unsigned)(y), __FILE__, __LINE__)) + ((void *) Tcl_DbCkrealloc((char *)(x), (unsigned)(y), __FILE__, __LINE__)) # define attemptckalloc(x) \ - ((VOID *) Tcl_AttemptDbCkalloc((unsigned)(x), __FILE__, __LINE__)) + ((void *) Tcl_AttemptDbCkalloc((unsigned)(x), __FILE__, __LINE__)) # define attemptckrealloc(x,y) \ - ((VOID *) Tcl_AttemptDbCkrealloc((char *)(x), (unsigned)(y), __FILE__, __LINE__)) + ((void *) Tcl_AttemptDbCkrealloc((char *)(x), (unsigned)(y), __FILE__, __LINE__)) #else /* !TCL_MEM_DEBUG */ @@ -2468,15 +2473,15 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); */ # define ckalloc(x) \ - ((VOID *) Tcl_Alloc((unsigned)(x))) + ((void *) Tcl_Alloc((unsigned)(x))) # define ckfree(x) \ Tcl_Free((char *)(x)) # define ckrealloc(x,y) \ - ((VOID *) Tcl_Realloc((char *)(x), (unsigned)(y))) + ((void *) Tcl_Realloc((char *)(x), (unsigned)(y))) # define attemptckalloc(x) \ - ((VOID *) Tcl_AttemptAlloc((unsigned)(x))) + ((void *) Tcl_AttemptAlloc((unsigned)(x))) # define attemptckrealloc(x,y) \ - ((VOID *) Tcl_AttemptRealloc((char *)(x), (unsigned)(y))) + ((void *) Tcl_AttemptRealloc((char *)(x), (unsigned)(y))) # undef Tcl_InitMemory # define Tcl_InitMemory(x) # undef Tcl_DumpActiveMemory diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 7833105..d1866c8 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -20,12 +20,13 @@ *- break and continue - if exception ranges can be sorted out. *- foreach_start4, foreach_step4 *- returnImm, returnStk - *- expandStart, expandStkTop, invokeExpanded + *- expandStart, expandStkTop, invokeExpanded, expandDrop *- dictFirst, dictNext, dictDone *- dictUpdateStart, dictUpdateEnd *- jumpTable testing *- 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. */ }; @@ -183,7 +184,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; @@ -324,29 +325,6 @@ static const Tcl_ObjType assembleCodeType = { }; /* - * TIP #280: Remember the per-word line information of the current command. An - * index is used instead of a pointer as recursive compilation may reallocate, - * i.e. move, the array. This is also the reason to save the nuloc now, it may - * change during the course of the function. - * - * Macro to encapsulate the variable definition and setup. - */ - -#define DefineLineInformation \ - ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ - int eclIndex = mapPtr->nuloc - 1 - -#define SetLineInformation(word) \ - envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ - envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] - -/* - * Flags bits used by PushVarName. - */ - -#define TCL_NO_LARGE_INDEX 1 /* Do not return localIndex value > 255 */ - -/* * Source instructions recognized in the Tcl Assembly Language (TAL) */ @@ -372,7 +350,8 @@ static const TalInstDesc TalInstructionTable[] = { {"bitnot", ASSEM_1BYTE, INST_BITNOT, 1, 1}, {"bitor", ASSEM_1BYTE, INST_BITOR, 2, 1}, {"bitxor", ASSEM_1BYTE, INST_BITXOR, 2, 1}, - {"concat", ASSEM_CONCAT1, INST_CONCAT1, INT_MIN,1}, + {"concat", ASSEM_CONCAT1, INST_STR_CONCAT1, INT_MIN,1}, + {"concatStk", ASSEM_LIST, INST_CONCAT_STK, INT_MIN,1}, {"coroName", ASSEM_1BYTE, INST_COROUTINE_NAME, 0, 1}, {"currentNamespace",ASSEM_1BYTE, INST_NS_CURRENT, 0, 1}, {"dictAppend", ASSEM_LVT4, INST_DICT_APPEND, 2, 1}, @@ -410,9 +389,8 @@ static const TalInstDesc TalInstructionTable[] = { {"incrArrayStkImm", ASSEM_SINT1, INST_INCR_ARRAY_STK_IMM,2, 1}, {"incrImm", ASSEM_LVT1_SINT1, INST_INCR_SCALAR1_IMM, 0, 1}, - {"incrStk", ASSEM_1BYTE, INST_INCR_SCALAR_STK, 2, 1}, - {"incrStkImm", ASSEM_SINT1, INST_INCR_SCALAR_STK_IMM, - 1, 1}, + {"incrStk", ASSEM_1BYTE, INST_INCR_STK, 2, 1}, + {"incrStkImm", ASSEM_SINT1, INST_INCR_STK_IMM, 1, 1}, {"infoLevelArgs", ASSEM_1BYTE, INST_INFO_LEVEL_ARGS, 1, 1}, {"infoLevelNumber", ASSEM_1BYTE, INST_INFO_LEVEL_NUM, 0, 1}, {"invokeStk", ASSEM_INVOKE, (INST_INVOKE_STK1 << 8 @@ -437,6 +415,7 @@ static const TalInstDesc TalInstructionTable[] = { {"lindexMulti", ASSEM_LINDEX_MULTI, INST_LIST_INDEX_MULTI, INT_MIN,1}, {"list", ASSEM_LIST, INST_LIST, INT_MIN,1}, + {"listConcat", ASSEM_1BYTE, INST_LIST_CONCAT, 2, 1}, {"listIn", ASSEM_1BYTE, INST_LIST_IN, 2, 1}, {"listIndex", ASSEM_1BYTE, INST_LIST_INDEX, 2, 1}, {"listIndexImm", ASSEM_INDEX, INST_LIST_INDEX_IMM, 1, 1}, @@ -447,7 +426,7 @@ static const TalInstDesc TalInstructionTable[] = { {"loadArray", ASSEM_LVT, (INST_LOAD_ARRAY1<<8 | INST_LOAD_ARRAY4), 1, 1}, {"loadArrayStk", ASSEM_1BYTE, INST_LOAD_ARRAY_STK, 2, 1}, - {"loadStk", ASSEM_1BYTE, INST_LOAD_SCALAR_STK, 1, 1}, + {"loadStk", ASSEM_1BYTE, INST_LOAD_STK, 1, 1}, {"lor", ASSEM_1BYTE, INST_LOR, 2, 1}, {"lsetFlat", ASSEM_LSET_FLAT,INST_LSET_FLAT, INT_MIN,1}, {"lsetList", ASSEM_1BYTE, INST_LSET_LIST, 3, 1}, @@ -459,6 +438,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}, @@ -474,8 +455,12 @@ static const TalInstDesc TalInstructionTable[] = { {"storeArray", ASSEM_LVT, (INST_STORE_ARRAY1<<8 | INST_STORE_ARRAY4), 2, 1}, {"storeArrayStk", ASSEM_1BYTE, INST_STORE_ARRAY_STK, 3, 1}, - {"storeStk", ASSEM_1BYTE, INST_STORE_SCALAR_STK, 2, 1}, + {"storeStk", ASSEM_1BYTE, INST_STORE_STK, 2, 1}, + {"strcaseLower", ASSEM_1BYTE, INST_STR_LOWER, 1, 1}, + {"strcaseTitle", ASSEM_1BYTE, INST_STR_TITLE, 1, 1}, + {"strcaseUpper", ASSEM_1BYTE, INST_STR_UPPER, 1, 1}, {"strcmp", ASSEM_1BYTE, INST_STR_CMP, 2, 1}, + {"strcat", ASSEM_CONCAT1, INST_STR_CONCAT1, INT_MIN,1}, {"streq", ASSEM_1BYTE, INST_STR_EQ, 2, 1}, {"strfind", ASSEM_1BYTE, INST_STR_FIND, 2, 1}, {"strindex", ASSEM_1BYTE, INST_STR_INDEX, 2, 1}, @@ -484,12 +469,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}, @@ -516,6 +506,7 @@ static const unsigned char NonThrowingByteCodes[] = { INST_PUSH1, INST_PUSH4, INST_POP, INST_DUP, /* 1-4 */ INST_JUMP1, INST_JUMP4, /* 34-35 */ INST_END_CATCH, INST_PUSH_RESULT, INST_PUSH_RETURN_CODE, /* 70-72 */ + INST_LIST, /* 79 */ INST_OVER, /* 95 */ INST_PUSH_RETURN_OPTIONS, /* 108 */ INST_REVERSE, /* 126 */ @@ -525,7 +516,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 */ }; /* @@ -673,7 +668,7 @@ BBEmitOpcode( } TclEmitInt1(op, envPtr); - envPtr->atCmdStart = ((op) == INST_START_CMD); + TclUpdateAtCmdStart(op, envPtr); BBUpdateStackReqs(bbPtr, tblIdx, count); } @@ -705,7 +700,7 @@ BBEmitInstInt4( * BBEmitInst1or4 -- * * Emits a 1- or 4-byte operation according to the magnitude of the - * operand + * operand. * *----------------------------------------------------------------------------- */ @@ -734,7 +729,7 @@ BBEmitInst1or4( } else { TclEmitInt4(param, envPtr); } - envPtr->atCmdStart = ((op) == INST_START_CMD); + TclUpdateAtCmdStart(op, envPtr); BBUpdateStackReqs(bbPtr, tblIdx, count); } @@ -798,12 +793,10 @@ TclNRAssembleObjCmd( if (codePtr == NULL) { Tcl_AddErrorInfo(interp, "\n (\""); - Tcl_AddErrorInfo(interp, Tcl_GetString(objv[0])); + Tcl_AppendObjToErrorInfo(interp, objv[0]); Tcl_AddErrorInfo(interp, "\" body, line "); backtrace = Tcl_NewIntObj(Tcl_GetErrorLine(interp)); - Tcl_IncrRefCount(backtrace); - Tcl_AddErrorInfo(interp, Tcl_GetString(backtrace)); - Tcl_DecrRefCount(backtrace); + Tcl_AppendObjToErrorInfo(interp, backtrace); Tcl_AddErrorInfo(interp, ")"); return TCL_ERROR; } @@ -841,16 +834,11 @@ CompileAssembleObj( CompileEnv compEnv; /* Compilation environment structure */ register ByteCode *codePtr = NULL; /* Bytecode resulting from the assembly */ - register const AuxData * auxDataPtr; - /* Pointer to an auxiliary data element - * in a compilation environment being - * destroyed. */ Namespace* namespacePtr; /* Namespace in which variable and command * names in the bytecode resolve */ int status; /* Status return from Tcl_AssembleCode */ const char* source; /* String representation of the source code */ int sourceLen; /* Length of the source code in bytes */ - int i; /* @@ -860,7 +848,7 @@ CompileAssembleObj( if (objPtr->typePtr == &assembleCodeType) { namespacePtr = iPtr->varFramePtr->nsPtr; - codePtr = objPtr->internalRep.otherValuePtr; + codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle == iPtr) && (codePtr->compileEpoch == iPtr->compileEpoch) && (codePtr->nsPtr == namespacePtr) @@ -888,44 +876,6 @@ CompileAssembleObj( /* * Assembly failed. Clean up and report the error. */ - - /* - * Free any literals that were constructed for the assembly. - */ - for (i = 0; i < compEnv.literalArrayNext; i++) { - TclReleaseLiteral(interp, compEnv.literalArrayPtr[i].objPtr); - } - - /* - * Free any auxiliary data that was attached to the bytecode - * under construction. - */ - - for (i = 0; i < compEnv.auxDataArrayNext; i++) { - auxDataPtr = compEnv.auxDataArrayPtr + i; - if (auxDataPtr->type->freeProc != NULL) { - (auxDataPtr->type->freeProc)(auxDataPtr->clientData); - } - } - - /* - * TIP 280. If there is extended command line information, - * we need to clean it up. - */ - - if (compEnv.extCmdMapPtr != NULL) { - if (compEnv.extCmdMapPtr->type == TCL_LOCATION_SOURCE) { - Tcl_DecrRefCount(compEnv.extCmdMapPtr->path); - } - for (i = 0; i < compEnv.extCmdMapPtr->nuloc; ++i) { - ckfree(compEnv.extCmdMapPtr->loc[i].line); - } - if (compEnv.extCmdMapPtr->loc != NULL) { - ckfree(compEnv.extCmdMapPtr->loc); - } - Tcl_DeleteHashTable(&(compEnv.extCmdMapPtr->litInfo)); - } - TclFreeCompileEnv(&compEnv); return NULL; } @@ -945,7 +895,7 @@ CompileAssembleObj( * Record the local variable context to which the bytecode pertains */ - codePtr = objPtr->internalRep.otherValuePtr; + codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; @@ -998,6 +948,10 @@ TclCompileAssembleCmd( { Tcl_Token *tokenPtr; /* Token in the input script */ + int numCommands = envPtr->numCommands; + int offset = envPtr->codeNext - envPtr->codeStart; + int depth = envPtr->currStackDepth; + /* * Make sure that the command has a single arg that is a simple word. */ @@ -1011,10 +965,23 @@ TclCompileAssembleCmd( } /* - * Compile the code and return any error from the compilation. + * Compile the code and convert any error from the compilation into + * bytecode reporting the error; */ - return TclAssembleCode(envPtr, tokenPtr[1].start, tokenPtr[1].size, 0); + if (TCL_ERROR == TclAssembleCode(envPtr, tokenPtr[1].start, + tokenPtr[1].size, TCL_EVAL_DIRECT)) { + + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"%.*s\" body, line %d)", + parsePtr->tokenPtr->size, parsePtr->tokenPtr->start, + Tcl_GetErrorLine(interp))); + envPtr->numCommands = numCommands; + envPtr->codeNext = envPtr->codeStart + offset; + envPtr->currStackDepth = depth; + TclCompileSyntaxError(interp, envPtr); + } + return TCL_OK; } /* @@ -1053,8 +1020,6 @@ TclAssembleCode( const char* instPtr = codePtr; /* Where to start looking for a line of code */ - int instLen; /* Length in bytes of the current line of - * code */ const char* nextPtr; /* Pointer to the end of the line of code */ int bytesLeft = codeLen; /* Number of bytes of source code remaining to * be parsed */ @@ -1068,10 +1033,6 @@ TclAssembleCode( */ status = Tcl_ParseCommand(interp, instPtr, bytesLeft, 0, parsePtr); - instLen = parsePtr->commandSize; - if (parsePtr->term == parsePtr->commandStart + instLen - 1) { - --instLen; - } /* * Report errors in the parse. @@ -1080,7 +1041,7 @@ TclAssembleCode( if (status != TCL_OK) { if (flags & TCL_EVAL_DIRECT) { Tcl_LogCommandInfo(interp, codePtr, parsePtr->commandStart, - instLen); + parsePtr->term + 1 - parsePtr->commandStart); } FreeAssemblyEnv(assemEnvPtr); return TCL_ERROR; @@ -1100,6 +1061,13 @@ TclAssembleCode( */ if (parsePtr->numWords > 0) { + int instLen = parsePtr->commandSize; + /* Length in bytes of the current command */ + + if (parsePtr->term == parsePtr->commandStart + instLen - 1) { + --instLen; + } + /* * If tracing, show each line assembled as it happens. */ @@ -1175,7 +1143,7 @@ NewAssemblyEnv( assemEnvPtr->envPtr = envPtr; assemEnvPtr->parsePtr = parsePtr; - assemEnvPtr->cmdLine = envPtr->line; + assemEnvPtr->cmdLine = 1; assemEnvPtr->clNext = envPtr->clNext; /* @@ -2667,6 +2635,7 @@ AllocBB( bb->minStackDepth = 0; bb->maxStackDepth = 0; bb->finalStackDepth = 0; + bb->catchDepth = 0; bb->enclosingCatch = NULL; bb->foreignExceptionBase = -1; bb->foreignExceptionCount = 0; @@ -3097,7 +3066,7 @@ ResolveJumpTableTargets( auxDataIndex = TclGetInt4AtPtr(envPtr->codeStart + bbPtr->jumpOffset + 1); DEBUG_PRINT("bbPtr = %p jumpOffset = %d auxDataIndex = %d\n", bbPtr, bbPtr->jumpOffset, auxDataIndex); - realJumpTablePtr = envPtr->auxDataArrayPtr[auxDataIndex].clientData; + realJumpTablePtr = TclFetchAuxData(envPtr, auxDataIndex); realJumpHashPtr = &realJumpTablePtr->hashTable; /* @@ -4270,11 +4239,11 @@ AddBasicBlockRangeToErrorInfo( Tcl_AddErrorInfo(interp, "\n in assembly code between lines "); lineNo = Tcl_NewIntObj(bbPtr->startLine); Tcl_IncrRefCount(lineNo); - Tcl_AddErrorInfo(interp, Tcl_GetString(lineNo)); + Tcl_AppendObjToErrorInfo(interp, lineNo); Tcl_AddErrorInfo(interp, " and "); if (bbPtr->successor1 != NULL) { Tcl_SetIntObj(lineNo, bbPtr->successor1->startLine); - Tcl_AddErrorInfo(interp, Tcl_GetString(lineNo)); + Tcl_AppendObjToErrorInfo(interp, lineNo); } else { Tcl_AddErrorInfo(interp, "end of assembly code"); } @@ -4338,14 +4307,13 @@ static void FreeAssembleCodeInternalRep( Tcl_Obj *objPtr) { - ByteCode *codePtr = objPtr->internalRep.otherValuePtr; + ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; codePtr->refCount--; if (codePtr->refCount <= 0) { TclCleanupByteCode(codePtr); } objPtr->typePtr = NULL; - objPtr->internalRep.otherValuePtr = NULL; } /* diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 6c53547..2a334c4 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -127,15 +127,12 @@ static Tcl_ObjCmdProc ExprSqrtFunc; static Tcl_ObjCmdProc ExprSrandFunc; static Tcl_ObjCmdProc ExprUnaryFunc; static Tcl_ObjCmdProc ExprWideFunc; -static Tcl_Obj * GetCommandSource(Interp *iPtr, int objc, - Tcl_Obj *const objv[], int lookup); static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected, int actual, Tcl_Obj *const *objv); static Tcl_NRPostProc NRCoroutineCallerCallback; static Tcl_NRPostProc NRCoroutineExitCallback; static int NRCommand(ClientData data[], Tcl_Interp *interp, int result); -static Tcl_NRPostProc NRRunObjProc; static Tcl_ObjCmdProc OldMathFuncProc; static void OldMathFuncDeleteProc(ClientData clientData); static void ProcessUnexpectedResult(Tcl_Interp *interp, @@ -149,8 +146,8 @@ static inline Command * TEOV_LookupCmdFromObj(Tcl_Interp *interp, static int TEOV_NotFound(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Namespace *lookupNsPtr); static int TEOV_RunEnterTraces(Tcl_Interp *interp, - Command **cmdPtrPtr, int objc, - Tcl_Obj *const objv[], Namespace *lookupNsPtr); + Command **cmdPtrPtr, Tcl_Obj *commandPtr, int objc, + Tcl_Obj *const objv[]); static Tcl_NRPostProc RewindCoroutineCallback; static Tcl_NRPostProc TailcallCleanup; static Tcl_NRPostProc TEOEx_ByteCodeCallback; @@ -160,8 +157,11 @@ static Tcl_NRPostProc TEOV_Exception; static Tcl_NRPostProc TEOV_NotFoundCallback; static Tcl_NRPostProc TEOV_RestoreVarFrame; static Tcl_NRPostProc TEOV_RunLeaveTraces; +static Tcl_NRPostProc EvalObjvCore; +static Tcl_NRPostProc Dispatch; static Tcl_ObjCmdProc NRCoroInjectObjCmd; +static Tcl_NRPostProc NRPostInvoke; MODULE_SCOPE const TclStubs tclStubs; @@ -185,11 +185,16 @@ typedef struct { Tcl_ObjCmdProc *objProc; /* Object-based function for command. */ CompileProc *compileProc; /* Function called to compile command. */ Tcl_ObjCmdProc *nreProc; /* NR-based function for command */ - int isSafe; /* If non-zero, command will be present in - * safe interpreter. Otherwise it will be - * hidden. */ + int flags; /* Various flag bits, as defined below. */ } CmdInfo; +#define CMD_IS_SAFE 1 /* Whether this command is part of the set of + * commands present by default in a safe + * interpreter. */ +/* CMD_COMPILES_EXPANDED - Whether the compiler for this command can handle + * expansion for itself rather than needing the generic layer to take care of + * it for it. Defined in tclInt.h. */ + /* * The built-in commands, and the functions that implement them: */ @@ -199,95 +204,95 @@ static const CmdInfo builtInCmds[] = { * Commands in the generic core. */ - {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, 1}, - {"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, 1}, - {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, 1}, + {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, CMD_IS_SAFE}, + {"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, CMD_IS_SAFE}, + {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, CMD_IS_SAFE}, #ifndef EXCLUDE_OBSOLETE_COMMANDS - {"case", Tcl_CaseObjCmd, NULL, NULL, 1}, + {"case", Tcl_CaseObjCmd, NULL, NULL, CMD_IS_SAFE}, #endif - {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, 1}, - {"concat", Tcl_ConcatObjCmd, NULL, NULL, 1}, - {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, 1}, - {"coroutine", NULL, NULL, TclNRCoroutineObjCmd, 1}, - {"error", Tcl_ErrorObjCmd, TclCompileErrorCmd, NULL, 1}, - {"eval", Tcl_EvalObjCmd, NULL, TclNREvalObjCmd, 1}, - {"expr", Tcl_ExprObjCmd, TclCompileExprCmd, TclNRExprObjCmd, 1}, - {"for", Tcl_ForObjCmd, TclCompileForCmd, TclNRForObjCmd, 1}, - {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, TclNRForeachCmd, 1}, - {"format", Tcl_FormatObjCmd, TclCompileFormatCmd, NULL, 1}, - {"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, NULL, 1}, - {"if", Tcl_IfObjCmd, TclCompileIfCmd, TclNRIfObjCmd, 1}, - {"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, NULL, 1}, - {"join", Tcl_JoinObjCmd, NULL, NULL, 1}, - {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, NULL, 1}, - {"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, NULL, 1}, - {"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, 1}, - {"linsert", Tcl_LinsertObjCmd, NULL, NULL, 1}, - {"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, 1}, - {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, 1}, - {"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, 1}, - {"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, NULL, 1}, - {"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, 1}, - {"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, 1}, - {"lreverse", Tcl_LreverseObjCmd, NULL, NULL, 1}, - {"lsearch", Tcl_LsearchObjCmd, NULL, NULL, 1}, - {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, 1}, - {"lsort", Tcl_LsortObjCmd, NULL, NULL, 1}, - {"package", Tcl_PackageObjCmd, NULL, NULL, 1}, - {"proc", Tcl_ProcObjCmd, NULL, NULL, 1}, - {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, 1}, - {"regsub", Tcl_RegsubObjCmd, TclCompileRegsubCmd, NULL, 1}, - {"rename", Tcl_RenameObjCmd, NULL, NULL, 1}, - {"return", Tcl_ReturnObjCmd, TclCompileReturnCmd, NULL, 1}, - {"scan", Tcl_ScanObjCmd, NULL, NULL, 1}, - {"set", Tcl_SetObjCmd, TclCompileSetCmd, NULL, 1}, - {"split", Tcl_SplitObjCmd, NULL, NULL, 1}, - {"subst", Tcl_SubstObjCmd, TclCompileSubstCmd, TclNRSubstObjCmd, 1}, - {"switch", Tcl_SwitchObjCmd, TclCompileSwitchCmd, TclNRSwitchObjCmd, 1}, - {"tailcall", NULL, TclCompileTailcallCmd, TclNRTailcallObjCmd, 1}, - {"throw", Tcl_ThrowObjCmd, TclCompileThrowCmd, NULL, 1}, - {"trace", Tcl_TraceObjCmd, NULL, NULL, 1}, - {"try", Tcl_TryObjCmd, TclCompileTryCmd, TclNRTryObjCmd, 1}, - {"unset", Tcl_UnsetObjCmd, TclCompileUnsetCmd, NULL, 1}, - {"uplevel", Tcl_UplevelObjCmd, NULL, TclNRUplevelObjCmd, 1}, - {"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, NULL, 1}, - {"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, NULL, 1}, - {"while", Tcl_WhileObjCmd, TclCompileWhileCmd, TclNRWhileObjCmd, 1}, - {"yield", NULL, TclCompileYieldCmd, TclNRYieldObjCmd, 1}, - {"yieldto", NULL, NULL, TclNRYieldToObjCmd, 1}, + {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, CMD_IS_SAFE}, + {"concat", Tcl_ConcatObjCmd, TclCompileConcatCmd, NULL, CMD_IS_SAFE}, + {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, CMD_IS_SAFE}, + {"coroutine", NULL, NULL, TclNRCoroutineObjCmd, CMD_IS_SAFE}, + {"error", Tcl_ErrorObjCmd, TclCompileErrorCmd, NULL, CMD_IS_SAFE}, + {"eval", Tcl_EvalObjCmd, NULL, TclNREvalObjCmd, CMD_IS_SAFE}, + {"expr", Tcl_ExprObjCmd, TclCompileExprCmd, TclNRExprObjCmd, CMD_IS_SAFE}, + {"for", Tcl_ForObjCmd, TclCompileForCmd, TclNRForObjCmd, CMD_IS_SAFE}, + {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, TclNRForeachCmd, CMD_IS_SAFE}, + {"format", Tcl_FormatObjCmd, TclCompileFormatCmd, NULL, CMD_IS_SAFE}, + {"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, NULL, CMD_IS_SAFE}, + {"if", Tcl_IfObjCmd, TclCompileIfCmd, TclNRIfObjCmd, CMD_IS_SAFE}, + {"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, NULL, CMD_IS_SAFE}, + {"join", Tcl_JoinObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, NULL, CMD_IS_SAFE}, + {"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, NULL, CMD_IS_SAFE}, + {"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, CMD_IS_SAFE}, + {"linsert", Tcl_LinsertObjCmd, TclCompileLinsertCmd, NULL, CMD_IS_SAFE}, + {"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, CMD_IS_SAFE|CMD_COMPILES_EXPANDED}, + {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, CMD_IS_SAFE}, + {"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, CMD_IS_SAFE}, + {"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, NULL, CMD_IS_SAFE}, + {"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, CMD_IS_SAFE}, + {"lreverse", Tcl_LreverseObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"lsearch", Tcl_LsearchObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, CMD_IS_SAFE}, + {"lsort", Tcl_LsortObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"package", Tcl_PackageObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"proc", Tcl_ProcObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, CMD_IS_SAFE}, + {"regsub", Tcl_RegsubObjCmd, TclCompileRegsubCmd, NULL, CMD_IS_SAFE}, + {"rename", Tcl_RenameObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"return", Tcl_ReturnObjCmd, TclCompileReturnCmd, NULL, CMD_IS_SAFE}, + {"scan", Tcl_ScanObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"set", Tcl_SetObjCmd, TclCompileSetCmd, NULL, CMD_IS_SAFE}, + {"split", Tcl_SplitObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"subst", Tcl_SubstObjCmd, TclCompileSubstCmd, TclNRSubstObjCmd, CMD_IS_SAFE}, + {"switch", Tcl_SwitchObjCmd, TclCompileSwitchCmd, TclNRSwitchObjCmd, CMD_IS_SAFE}, + {"tailcall", NULL, TclCompileTailcallCmd, TclNRTailcallObjCmd, CMD_IS_SAFE}, + {"throw", Tcl_ThrowObjCmd, TclCompileThrowCmd, NULL, CMD_IS_SAFE}, + {"trace", Tcl_TraceObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"try", Tcl_TryObjCmd, TclCompileTryCmd, TclNRTryObjCmd, CMD_IS_SAFE}, + {"unset", Tcl_UnsetObjCmd, TclCompileUnsetCmd, NULL, CMD_IS_SAFE}, + {"uplevel", Tcl_UplevelObjCmd, NULL, TclNRUplevelObjCmd, CMD_IS_SAFE}, + {"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, NULL, CMD_IS_SAFE}, + {"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, NULL, CMD_IS_SAFE}, + {"while", Tcl_WhileObjCmd, TclCompileWhileCmd, TclNRWhileObjCmd, CMD_IS_SAFE}, + {"yield", NULL, TclCompileYieldCmd, TclNRYieldObjCmd, CMD_IS_SAFE}, + {"yieldto", NULL, TclCompileYieldToCmd, TclNRYieldToObjCmd, CMD_IS_SAFE}, /* * Commands in the OS-interface. Note that many of these are unsafe. */ - {"after", Tcl_AfterObjCmd, NULL, NULL, 1}, + {"after", Tcl_AfterObjCmd, NULL, NULL, CMD_IS_SAFE}, {"cd", Tcl_CdObjCmd, NULL, NULL, 0}, - {"close", Tcl_CloseObjCmd, NULL, NULL, 1}, - {"eof", Tcl_EofObjCmd, NULL, NULL, 1}, + {"close", Tcl_CloseObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"eof", Tcl_EofObjCmd, NULL, NULL, CMD_IS_SAFE}, {"encoding", Tcl_EncodingObjCmd, NULL, NULL, 0}, {"exec", Tcl_ExecObjCmd, NULL, NULL, 0}, {"exit", Tcl_ExitObjCmd, NULL, NULL, 0}, - {"fblocked", Tcl_FblockedObjCmd, NULL, NULL, 1}, + {"fblocked", Tcl_FblockedObjCmd, NULL, NULL, CMD_IS_SAFE}, {"fconfigure", Tcl_FconfigureObjCmd, NULL, NULL, 0}, - {"fcopy", Tcl_FcopyObjCmd, NULL, NULL, 1}, - {"fileevent", Tcl_FileEventObjCmd, NULL, NULL, 1}, - {"flush", Tcl_FlushObjCmd, NULL, NULL, 1}, - {"gets", Tcl_GetsObjCmd, NULL, NULL, 1}, + {"fcopy", Tcl_FcopyObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"fileevent", Tcl_FileEventObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"flush", Tcl_FlushObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"gets", Tcl_GetsObjCmd, NULL, NULL, CMD_IS_SAFE}, {"glob", Tcl_GlobObjCmd, NULL, NULL, 0}, {"load", Tcl_LoadObjCmd, NULL, NULL, 0}, {"open", Tcl_OpenObjCmd, NULL, NULL, 0}, - {"pid", Tcl_PidObjCmd, NULL, NULL, 1}, - {"puts", Tcl_PutsObjCmd, NULL, NULL, 1}, + {"pid", Tcl_PidObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"puts", Tcl_PutsObjCmd, NULL, NULL, CMD_IS_SAFE}, {"pwd", Tcl_PwdObjCmd, NULL, NULL, 0}, - {"read", Tcl_ReadObjCmd, NULL, NULL, 1}, - {"seek", Tcl_SeekObjCmd, NULL, NULL, 1}, + {"read", Tcl_ReadObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"seek", Tcl_SeekObjCmd, NULL, NULL, CMD_IS_SAFE}, {"socket", Tcl_SocketObjCmd, NULL, NULL, 0}, {"source", Tcl_SourceObjCmd, NULL, TclNRSourceObjCmd, 0}, - {"tell", Tcl_TellObjCmd, NULL, NULL, 1}, - {"time", Tcl_TimeObjCmd, NULL, NULL, 1}, + {"tell", Tcl_TellObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"time", Tcl_TimeObjCmd, NULL, NULL, CMD_IS_SAFE}, {"unload", Tcl_UnloadObjCmd, NULL, NULL, 0}, - {"update", Tcl_UpdateObjCmd, NULL, NULL, 1}, - {"vwait", Tcl_VwaitObjCmd, NULL, NULL, 1}, + {"update", Tcl_UpdateObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"vwait", Tcl_VwaitObjCmd, NULL, NULL, CMD_IS_SAFE}, {NULL, NULL, NULL, NULL, 0} }; @@ -481,6 +486,18 @@ Tcl_CreateInterp(void) Tcl_Panic("Tcl_CallFrame must not be smaller than CallFrame"); } +#if defined(_WIN32) && !defined(_WIN64) + if (sizeof(time_t) != 4) { + /*NOTREACHED*/ + Tcl_Panic("<time.h> is not compatible with MSVC"); + } + if ((TclOffset(Tcl_StatBuf,st_atime) != 32) + || (TclOffset(Tcl_StatBuf,st_ctime) != 40)) { + /*NOTREACHED*/ + Tcl_Panic("<sys/stat.h> is not compatible with MSVC"); + } +#endif + if (cancelTableInitialized == 0) { Tcl_MutexLock(&cancelLock); if (cancelTableInitialized == 0) { @@ -509,6 +526,9 @@ Tcl_CreateInterp(void) iPtr->hiddenCmdTablePtr = NULL; iPtr->interpInfo = NULL; + TCL_CT_ASSERT(sizeof(iPtr->extra) <= sizeof(Tcl_HashTable)); + iPtr->extra.optimizer = TclOptimizeBytecode; + iPtr->numLevels = 0; iPtr->maxNestingDepth = MAX_NESTING_DEPTH; iPtr->framePtr = NULL; /* Initialise as soon as :: is available */ @@ -768,6 +788,9 @@ Tcl_CreateInterp(void) cmdPtr->deleteProc = NULL; cmdPtr->deleteData = NULL; cmdPtr->flags = 0; + if (cmdInfoPtr->flags & CMD_COMPILES_EXPANDED) { + cmdPtr->flags |= CMD_COMPILES_EXPANDED; + } cmdPtr->importRefPtr = NULL; cmdPtr->tracePtr = NULL; cmdPtr->nreProc = cmdInfoPtr->nreProc; @@ -1000,7 +1023,7 @@ TclHideUnsafeCommands( return TCL_ERROR; } for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) { - if (!cmdInfoPtr->isSafe) { + if (!(cmdInfoPtr->flags & CMD_IS_SAFE)) { Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name); } } @@ -1589,8 +1612,6 @@ DeleteInterpProc( ckfree(eclPtr->loc); } - Tcl_DeleteHashTable(&eclPtr->litInfo); - ckfree(eclPtr); Tcl_DeleteHashEntry(hPtr); } @@ -2064,10 +2085,19 @@ Tcl_CreateCommand( */ 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); + + if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) { + oldRefPtr = cmdPtr->importRefPtr; + cmdPtr->importRefPtr = NULL; + } + TclCleanupCommandMacro(cmdPtr); + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); if (!isNew) { /* @@ -2156,12 +2186,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 @@ -2228,17 +2255,22 @@ Tcl_CreateObjCommand( if (!isNew) { cmdPtr = Tcl_GetHashValue(hPtr); + /* Command already exists. */ + /* - * Command already exists. If its object-based Tcl_ObjCmdProc is - * TclInvokeStringCommand, we just set its Tcl_ObjCmdProc to the - * argument "proc". Otherwise, we delete the old command. + * [***] This is wrong. See Tcl Bug a16752c252. + * However, this buggy behavior is kept under particular + * circumstances to accommodate deployed binaries of the + * "tclcompiler" program. http://sourceforge.net/projects/tclpro/ + * that crash if the bug is fixed. */ - if (cmdPtr->objProc == TclInvokeStringCommand) { + if (cmdPtr->objProc == TclInvokeStringCommand + && cmdPtr->clientData == clientData + && cmdPtr->deleteData == clientData + && cmdPtr->deleteProc == deleteProc) { cmdPtr->objProc = proc; cmdPtr->objClientData = clientData; - cmdPtr->deleteProc = deleteProc; - cmdPtr->deleteData = clientData; return (Tcl_Command) cmdPtr; } @@ -2249,10 +2281,19 @@ Tcl_CreateObjCommand( * intact. */ - oldRefPtr = cmdPtr->importRefPtr; - cmdPtr->importRefPtr = NULL; + cmdPtr->refCount++; + if (cmdPtr->importRefPtr) { + cmdPtr->flags |= CMD_REDEF_IN_PROGRESS; + } Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); + + if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) { + oldRefPtr = cmdPtr->importRefPtr; + cmdPtr->importRefPtr = NULL; + } + TclCleanupCommandMacro(cmdPtr); + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); if (!isNew) { /* @@ -2391,8 +2432,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. * *---------------------------------------------------------------------- */ @@ -3094,12 +3135,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); + } } /* @@ -3335,66 +3377,6 @@ CancelEvalProc( /* *---------------------------------------------------------------------- * - * GetCommandSource -- - * - * This function returns a Tcl_Obj with the full source string for the - * command. This insures that traces get a correct NUL-terminated command - * string. The Tcl_Obj has refCount==1. - * - * *** MAINTAINER WARNING *** - * The returned Tcl_Obj is all wrong for any purpose but getting the - * source string for an objc/objv command line in the stringRep (no - * stringRep if no source is available) and the corresponding substituted - * version in the List intrep. - * This means that the intRep and stringRep DO NOT COINCIDE! Using these - * Tcl_Objs normally is likely to break things. - * - *---------------------------------------------------------------------- - */ - -static Tcl_Obj * -GetCommandSource( - Interp *iPtr, - int objc, - Tcl_Obj *const objv[], - int lookup) -{ - Tcl_Obj *objPtr, *obj2Ptr; - CmdFrame *cfPtr = iPtr->cmdFramePtr; - const char *command = NULL; - int numChars; - - objPtr = Tcl_NewListObj(objc, objv); - if (lookup && cfPtr && (cfPtr->numLevels == iPtr->numLevels-1)) { - switch (cfPtr->type) { - case TCL_LOCATION_EVAL: - case TCL_LOCATION_SOURCE: - command = cfPtr->cmd.str.cmd; - numChars = cfPtr->cmd.str.len; - break; - case TCL_LOCATION_BC: - case TCL_LOCATION_PREBC: - command = TclGetSrcInfoForCmd(iPtr, &numChars); - break; - case TCL_LOCATION_EVAL_LIST: - /* Got it already */ - break; - } - if (command) { - obj2Ptr = Tcl_NewStringObj(command, numChars); - objPtr->bytes = obj2Ptr->bytes; - objPtr->length = numChars; - obj2Ptr->bytes = NULL; - Tcl_DecrRefCount(obj2Ptr); - } - } - Tcl_IncrRefCount(objPtr); - return objPtr; -} - -/* - *---------------------------------------------------------------------- - * * TclCleanupCommand -- * * This function frees up a Command structure unless it is still @@ -4155,46 +4137,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. */ 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]); - - callbackPtr->data[2] = INT2PTR(objc); - callbackPtr->data[3] = (ClientData) objv; iPtr->numLevels++; - result = TclInterpReady(interp); - - if ((result != TCL_OK) || (objc == 0)) { - return result; - } - - if (cmdPtr) { - goto commandFound; - } + TclNRAddCallback(interp, EvalObjvCore, cmdPtr, INT2PTR(flags), + INT2PTR(objc), objv); + return TCL_OK; +} +static int +EvalObjvCore( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Command *cmdPtr = NULL, *preCmdPtr = data[0]; + int flags = PTR2INT(data[1]); + int objc = PTR2INT(data[2]); + Tcl_Obj **objv = data[3]; + Interp *iPtr = (Interp *) interp; + Namespace *lookupNsPtr = NULL; + int enterTracesDone = 0; + /* * Push records for task to be done on return, in INVERSE order. First, if * needed, the exception handlers (as they should happen last). @@ -4204,61 +4179,150 @@ TclNREvalObjv( TEOV_PushExceptionHandlers(interp, objc, objv, flags); } + if (TCL_OK != TclInterpReady(interp)) { + return TCL_ERROR; + } + + if (objc == 0) { + return TCL_OK; + } + + if (TclLimitExceeded(iPtr->limit)) { + return TCL_ERROR; + } + /* * Configure evaluation context to match the requested flags. */ - if ((flags & TCL_EVAL_INVOKE) || lookupNsPtr) { - if (!lookupNsPtr) { - lookupNsPtr = iPtr->globalNsPtr; - } + if (iPtr->lookupNsPtr) { + + /* + * Capture the namespace we should do command name resolution in, as + * instructed by our caller sneaking it in to us in a private interp + * field. Clear that field right away so we cannot possibly have its + * use leak where it should not. The sneaky message pass is done. + * + * Use of this mechanism overrides the TCL_EVAL_GLOBAL flag. + * TODO: Is that a bug? + */ + + lookupNsPtr = iPtr->lookupNsPtr; + iPtr->lookupNsPtr = NULL; + } else if (flags & TCL_EVAL_INVOKE) { + lookupNsPtr = iPtr->globalNsPtr; } else { - if (flags & TCL_EVAL_GLOBAL) { - TEOV_SwitchVarFrame(interp); - lookupNsPtr = iPtr->globalNsPtr; - } /* * TCL_EVAL_INVOKE was not set: clear rewrite rules */ iPtr->ensembleRewrite.sourceObjs = NULL; + + if (flags & TCL_EVAL_GLOBAL) { + TEOV_SwitchVarFrame(interp); + lookupNsPtr = iPtr->globalNsPtr; + } } /* - * Lookup the command + * Lookup the Command to dispatch. */ - cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); - if (!cmdPtr) { - return TEOV_NotFound(interp, objc, objv, lookupNsPtr); + reresolve: + assert(cmdPtr == NULL); + if (preCmdPtr) { + /* Caller gave it to us */ + if (!(preCmdPtr->flags & CMD_IS_DELETED)) { + /* So long as it exists, use it. */ + cmdPtr = preCmdPtr; + } else if (flags & TCL_EVAL_NORESOLVE) { + /* + * When it's been deleted, and we're told not to attempt + * resolving it ourselves, all we can do is raise an error. + */ + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "attempt to invoke a deleted command")); + Tcl_SetErrorCode(interp, "TCL", "EVAL", "DELETEDCOMMAND", NULL); + return TCL_ERROR; + } } - - iPtr->cmdCount++; - if (TclLimitExceeded(iPtr->limit)) { - return TCL_ERROR; + if (cmdPtr == NULL) { + cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); + if (!cmdPtr) { + return TEOV_NotFound(interp, objc, objv, lookupNsPtr); + } } - /* - * Found a command! The real work begins now ... - */ + if (enterTracesDone || iPtr->tracePtr + || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { - commandFound: - if (iPtr->tracePtr || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { - /* - * Call enter traces. They will schedule a call to the leave traces if - * necessary. - */ + Tcl_Obj *commandPtr = TclGetSourceFromFrame( + flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL, + objc, objv); + Tcl_IncrRefCount(commandPtr); - result = TEOV_RunEnterTraces(interp, &cmdPtr, objc, objv, lookupNsPtr); - if (!cmdPtr) { - return TEOV_NotFound(interp, objc, objv, lookupNsPtr); - } - if (result != TCL_OK) { - return result; + if (!enterTracesDone) { + + int code = TEOV_RunEnterTraces(interp, &cmdPtr, commandPtr, + objc, objv); + + /* + * Send any exception from enter traces back as an exception + * raised by the traced command. + * TODO: Is this a bug? Letting an execution trace BREAK or + * CONTINUE or RETURN in the place of the traced command? + * Would either converting all exceptions to TCL_ERROR, or + * just swallowing them be better? (Swallowing them has the + * problem of permanently hiding program errors.) + */ + + if (code != TCL_OK) { + Tcl_DecrRefCount(commandPtr); + return code; + } + + /* + * If the enter traces made the resolved cmdPtr unusable, go + * back and resolve again, but next time don't run enter + * traces again. + */ + + if (cmdPtr == NULL) { + enterTracesDone = 1; + Tcl_DecrRefCount(commandPtr); + goto reresolve; + } } + + /* + * Schedule leave traces. Raise the refCount on the resolved + * cmdPtr, so that when it passes to the leave traces we know + * it's still valid. + */ + + cmdPtr->refCount++; + TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc), + commandPtr, cmdPtr, objv); } + TclNRAddCallback(interp, Dispatch, + cmdPtr->nreProc ? cmdPtr->nreProc : cmdPtr->objProc, + cmdPtr->objClientData, INT2PTR(objc), objv); + return TCL_OK; +} + +static int +Dispatch( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_ObjCmdProc *objProc = data[0]; + ClientData clientData = data[1]; + int objc = PTR2INT(data[2]); + Tcl_Obj **objv = data[3]; + Interp *iPtr = (Interp *) interp; #ifdef USE_DTRACE if (TCL_DTRACE_CMD_ARGS_ENABLED()) { @@ -4279,34 +4343,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 @@ -4352,13 +4400,8 @@ 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 @@ -4385,22 +4428,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); -} - /* *---------------------------------------------------------------------- @@ -4664,27 +4691,21 @@ static int TEOV_RunEnterTraces( Tcl_Interp *interp, Command **cmdPtrPtr, + Tcl_Obj *commandPtr, int objc, - Tcl_Obj *const objv[], - Namespace *lookupNsPtr) + Tcl_Obj *const objv[]) { Interp *iPtr = (Interp *) interp; Command *cmdPtr = *cmdPtrPtr; - int traceCode = TCL_OK; - int cmdEpoch = cmdPtr->cmdEpoch; - int newEpoch; - const char *command; - int length; - Tcl_Obj *commandPtr; - - commandPtr = GetCommandSource(iPtr, objc, objv, 1); - command = Tcl_GetStringFromObj(commandPtr, &length); + int newEpoch, cmdEpoch = cmdPtr->cmdEpoch; + int length, traceCode = TCL_OK; + const char *command = Tcl_GetStringFromObj(commandPtr, &length); /* * Call trace functions. * Execute any command or execution traces. Note that we bump up the - * command's reference count for the duration of the calling of the traces - * so that the structure doesn't go away underneath our feet. + * command's reference count for the duration of the calling of the + * traces so that the structure doesn't go away underneath our feet. */ cmdPtr->refCount++; @@ -4699,29 +4720,22 @@ TEOV_RunEnterTraces( newEpoch = cmdPtr->cmdEpoch; TclCleanupCommandMacro(cmdPtr); - /* - * If the traces modified/deleted the command or any existing traces, they - * will update the command's epoch. We need to lookup again, but do not - * run enter traces on the newly found cmdPtr. - */ - - if (cmdEpoch != newEpoch) { - cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); - *cmdPtrPtr = cmdPtr; + if (traceCode != TCL_OK) { + if (traceCode == TCL_ERROR) { + Tcl_Obj *info; + + TclNewLiteralStringObj(info, "\n (enter trace on \""); + Tcl_AppendLimitedToObj(info, command, length, 55, "..."); + Tcl_AppendToObj(info, "\")", 2); + Tcl_AppendObjToErrorInfo(interp, info); + iPtr->flags |= ERR_ALREADY_LOGGED; + } + return traceCode; } - - if (cmdPtr) { - /* - * Command was found: push a record to schedule the leave traces. - */ - - TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(traceCode), - commandPtr, cmdPtr, NULL); - cmdPtr->refCount++; - } else { - Tcl_DecrRefCount(commandPtr); + if (cmdEpoch != newEpoch) { + *cmdPtrPtr = NULL; } - return traceCode; + return TCL_OK; } static int @@ -4731,20 +4745,16 @@ TEOV_RunLeaveTraces( int result) { Interp *iPtr = (Interp *) interp; - const char *command; - int length, objc; - Tcl_Obj **objv; - int traceCode = PTR2INT(data[0]); + int traceCode = TCL_OK; + int objc = PTR2INT(data[0]); Tcl_Obj *commandPtr = data[1]; Command *cmdPtr = data[2]; - - command = Tcl_GetStringFromObj(commandPtr, &length); - if (TCL_OK != Tcl_ListObjGetElements(interp, commandPtr, &objc, &objv)) { - Tcl_Panic("Who messed with commandPtr?"); - } + Tcl_Obj **objv = data[3]; + int length; + const char *command = Tcl_GetStringFromObj(commandPtr, &length); if (!(cmdPtr->flags & CMD_IS_DELETED)) { - if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && traceCode == TCL_OK){ + if (cmdPtr->flags & CMD_HAS_EXEC_TRACES){ traceCode = TclCheckExecutionTraces(interp, command, length, cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv); } @@ -4753,7 +4763,6 @@ TEOV_RunLeaveTraces( cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv); } } - Tcl_DecrRefCount(commandPtr); /* * As cmdPtr is set, TclNRRunCallbacks is about to reduce the numlevels. @@ -4764,8 +4773,18 @@ TEOV_RunLeaveTraces( TclCleanupCommandMacro(cmdPtr); if (traceCode != TCL_OK) { - return traceCode; + if (traceCode == TCL_ERROR) { + Tcl_Obj *info; + + TclNewLiteralStringObj(info, "\n (leave trace on \""); + Tcl_AppendLimitedToObj(info, command, length, 55, "..."); + Tcl_AppendToObj(info, "\")", 2); + Tcl_AppendObjToErrorInfo(interp, info); + iPtr->flags |= ERR_ALREADY_LOGGED; + } + result = traceCode; } + Tcl_DecrRefCount(commandPtr); return result; } @@ -4781,7 +4800,6 @@ TEOV_LookupCmdFromObj( if (lookupNsPtr) { iPtr->varFramePtr->nsPtr = lookupNsPtr; - iPtr->lookupNsPtr = NULL; } cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, namePtr); iPtr->varFramePtr->nsPtr = savedNsPtr; @@ -5000,31 +5018,22 @@ TclEvalEx( /* * TIP #280 Initialize tracking. Do not push on the frame stack yet. * - * We may continue counting based on a specific context (CTX), or open a - * new context, either for a sourced script, or 'eval'. For sourced files - * we always have a path object, even if nothing was specified in the - * interp itself. That makes code using it simpler as NULL checks can be - * left out. Sourced file without path in the 'scriptFile' is possible - * during Tcl initialization. + * We open a new context, either for a sourced script, or 'eval'. + * For sourced files we always have a path object, even if nothing was + * specified in the interp itself. That makes code using it simpler as + * NULL checks can be left out. Sourced file without path in the + * 'scriptFile' is possible during Tcl initialization. */ eeFramePtr->level = iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level + 1 : 1; - eeFramePtr->numLevels = iPtr->numLevels; eeFramePtr->framePtr = iPtr->framePtr; eeFramePtr->nextPtr = iPtr->cmdFramePtr; eeFramePtr->nline = 0; eeFramePtr->line = NULL; + eeFramePtr->cmdObj = NULL; iPtr->cmdFramePtr = eeFramePtr; - if (iPtr->evalFlags & TCL_EVAL_CTX) { - /* - * Path information comes out of the context. - */ - - eeFramePtr->type = TCL_LOCATION_SOURCE; - eeFramePtr->data.eval.path = iPtr->invokeCmdFramePtr->data.eval.path; - Tcl_IncrRefCount(eeFramePtr->data.eval.path); - } else if (iPtr->evalFlags & TCL_EVAL_FILE) { + if (iPtr->evalFlags & TCL_EVAL_FILE) { /* * Set up for a sourced file. */ @@ -5067,7 +5076,9 @@ TclEvalEx( do { if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) { code = TCL_ERROR; - goto error; + Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, + parsePtr->term + 1 - parsePtr->commandStart); + goto posterror; } /* @@ -5233,23 +5244,28 @@ TclEvalEx( * have been executed. */ - eeFramePtr->cmd.str.cmd = parsePtr->commandStart; - eeFramePtr->cmd.str.len = parsePtr->commandSize; + eeFramePtr->cmd = parsePtr->commandStart; + eeFramePtr->len = parsePtr->commandSize; if (parsePtr->term == parsePtr->commandStart + parsePtr->commandSize - 1) { - eeFramePtr->cmd.str.len--; + eeFramePtr->len--; } eeFramePtr->nline = objectsUsed; eeFramePtr->line = lines; TclArgumentEnter(interp, objv, objectsUsed, eeFramePtr); - code = Tcl_EvalObjv(interp, objectsUsed, objv, TCL_EVAL_NOERR); + code = Tcl_EvalObjv(interp, objectsUsed, objv, + TCL_EVAL_NOERR | TCL_EVAL_SOURCE_IN_FRAME); TclArgumentRelease(interp, objv, objectsUsed); eeFramePtr->line = NULL; eeFramePtr->nline = 0; + if (eeFramePtr->cmdObj) { + Tcl_DecrRefCount(eeFramePtr->cmdObj); + eeFramePtr->cmdObj = NULL; + } if (code != TCL_OK) { goto error; @@ -5323,6 +5339,7 @@ TclEvalEx( Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, commandLength); } + posterror: iPtr->flags &= ~ERR_ALREADY_LOGGED; /* @@ -5597,76 +5614,88 @@ TclArgumentBCEnter( int objc, void *codePtr, CmdFrame *cfPtr, + int cmd, int pc) { + ExtCmdLoc *eclPtr; + int word; + ECL *ePtr; + CFWordBC *lastPtr = NULL; Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr); - ExtCmdLoc *eclPtr; if (!hePtr) { return; } eclPtr = Tcl_GetHashValue(hePtr); - hePtr = Tcl_FindHashEntry(&eclPtr->litInfo, INT2PTR(pc)); - if (hePtr) { - int word; - int cmd = PTR2INT(Tcl_GetHashValue(hePtr)); - ECL *ePtr = &eclPtr->loc[cmd]; - CFWordBC *lastPtr = NULL; + ePtr = &eclPtr->loc[cmd]; - /* - * A few truths ... - * (1) ePtr->nline == objc - * (2) (ePtr->line[word] < 0) => !literal, for all words - * (3) (word == 0) => !literal - * - * Item (2) is why we can use objv to get the literals, and do not - * have to save them at compile time. - */ + /* + * ePtr->nline is the number of words originally parsed. + * + * objc is the number of elements getting invoked. + * + * If they are not the same, we arrived here by compiling an + * ensemble dispatch. Ensemble subcommands that lead to script + * evaluation are not supposed to get compiled, because a command + * such as [info level] in the script can expose some of the dispatch + * shenanigans. This means that we don't have to tend to the + * housekeeping, and can escape now. + */ + + if (ePtr->nline != objc) { + return; + } - if (ePtr->nline != objc) { - Tcl_Panic ("TIP 280 data structure inconsistency"); - } + /* + * Having disposed of the ensemble cases, we can state... + * A few truths ... + * (1) ePtr->nline == objc + * (2) (ePtr->line[word] < 0) => !literal, for all words + * (3) (word == 0) => !literal + * + * Item (2) is why we can use objv to get the literals, and do not + * have to save them at compile time. + */ - for (word = 1; word < objc; word++) { - if (ePtr->line[word] >= 0) { - int isnew; - Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(iPtr->lineLABCPtr, - objv[word], &isnew); - CFWordBC *cfwPtr = ckalloc(sizeof(CFWordBC)); - - cfwPtr->framePtr = cfPtr; - cfwPtr->obj = objv[word]; - cfwPtr->pc = pc; - cfwPtr->word = word; - cfwPtr->nextPtr = lastPtr; - lastPtr = cfwPtr; - - if (isnew) { - /* - * The word is not on the stack yet, remember the current - * location and initialize references. - */ - - cfwPtr->prevPtr = NULL; - } else { - /* - * The object is already on the stack, however it may have - * a different location now (literal sharing may map - * multiple location to a single Tcl_Obj*. Save the old - * information in the new structure. - */ - - cfwPtr->prevPtr = Tcl_GetHashValue(hPtr); - } + for (word = 1; word < objc; word++) { + if (ePtr->line[word] >= 0) { + int isnew; + Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(iPtr->lineLABCPtr, + objv[word], &isnew); + CFWordBC *cfwPtr = ckalloc(sizeof(CFWordBC)); + + cfwPtr->framePtr = cfPtr; + cfwPtr->obj = objv[word]; + cfwPtr->pc = pc; + cfwPtr->word = word; + cfwPtr->nextPtr = lastPtr; + lastPtr = cfwPtr; + + if (isnew) { + /* + * The word is not on the stack yet, remember the current + * location and initialize references. + */ + + cfwPtr->prevPtr = NULL; + } else { + /* + * The object is already on the stack, however it may have + * a different location now (literal sharing may map + * multiple location to a single Tcl_Obj*. Save the old + * information in the new structure. + */ - Tcl_SetHashValue(hPtr, cfwPtr); + cfwPtr->prevPtr = Tcl_GetHashValue(hPtr); } - } /* for */ - cfPtr->litarg = lastPtr; - } /* if */ + Tcl_SetHashValue(hPtr, cfwPtr); + } + } /* for */ + + cfPtr->litarg = lastPtr; } /* @@ -5814,6 +5843,7 @@ TclArgumentGet( *---------------------------------------------------------------------- */ +#undef Tcl_Eval int Tcl_Eval( Tcl_Interp *interp, /* Token for command interpreter (returned by @@ -5849,6 +5879,7 @@ Tcl_Eval( *---------------------------------------------------------------------- */ +#undef Tcl_EvalObj int Tcl_EvalObj( Tcl_Interp *interp, @@ -5856,6 +5887,7 @@ Tcl_EvalObj( { return Tcl_EvalObjEx(interp, objPtr, 0); } +#undef Tcl_GlobalEvalObj int Tcl_GlobalEvalObj( Tcl_Interp *interp, @@ -5873,6 +5905,11 @@ Tcl_GlobalEvalObj( * compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT is * specified. * + * If the flag TCL_EVAL_DIRECT is passed in, the value of invoker + * must be NULL. Support for non-NULL invokers in that mode has + * been removed since it was unused and untested. Failure to + * follow this limitation will lead to an assertion panic. + * * Results: * The return value is one of the return codes defined in tcl.h (such as * TCL_OK), and the interpreter's result contains a value to supplement @@ -5941,13 +5978,12 @@ TclNREvalObjEx( */ if (TclListObjIsCanonical(objPtr)) { - Tcl_Obj *listPtr = objPtr; CmdFrame *eoFramePtr = NULL; int objc; - Tcl_Obj **objv; + Tcl_Obj *listPtr, **objv; /* - * Pure List Optimization (no string representation). In this case, we + * Canonical List Optimization: In this case, we * can safely use Tcl_EvalObjv instead and get an appreciable * improvement in execution speed. This is because it allows us to * avoid a setFromAny step that would just pack everything into a @@ -5955,11 +5991,6 @@ TclNREvalObjEx( * * This also preserves any associations between list elements and * location information for such elements. - * - * This restriction has been relaxed a bit by storing in lists whether - * they are "canonical" or not (a canonical list being one that is - * either pure or that has its string rep derived by - * UpdateStringOfList from the internal rep). */ /* @@ -5968,13 +5999,13 @@ TclNREvalObjEx( * we always make a copy. The callback takes care od the refCounts for * both listPtr and objPtr. * + * TODO: Create a test to demo this need, or eliminate it. * FIXME OPT: preserve just the internal rep? */ Tcl_IncrRefCount(objPtr); listPtr = TclListObjCopy(interp, objPtr); Tcl_IncrRefCount(listPtr); - TclDecrRefCount(objPtr); if (word != INT_MIN) { /* @@ -5997,22 +6028,25 @@ TclNREvalObjEx( eoFramePtr->nline = 0; eoFramePtr->line = NULL; - eoFramePtr->type = TCL_LOCATION_EVAL_LIST; + eoFramePtr->type = TCL_LOCATION_EVAL; eoFramePtr->level = (iPtr->cmdFramePtr == NULL? 1 : iPtr->cmdFramePtr->level + 1); - eoFramePtr->numLevels = iPtr->numLevels; eoFramePtr->framePtr = iPtr->framePtr; eoFramePtr->nextPtr = iPtr->cmdFramePtr; - eoFramePtr->cmd.listPtr = listPtr; + eoFramePtr->cmdObj = objPtr; + eoFramePtr->cmd = NULL; + eoFramePtr->len = 0; eoFramePtr->data.eval.path = NULL; iPtr->cmdFramePtr = eoFramePtr; + + flags |= TCL_EVAL_SOURCE_IN_FRAME; } TclMarkTailcall(interp); TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr, - NULL, NULL); + objPtr, NULL); ListObjGetElements(listPtr, objc, objv); return TclNREvalObjv(interp, objc, objv, flags, NULL); @@ -6052,14 +6086,6 @@ TclNREvalObjEx( * We're not supposed to use the compiler or byte-code * interpreter. Let Tcl_EvalEx evaluate the command directly (and * probably more slowly). - * - * TIP #280. Propagate context as much as we can. Especially if the - * script to evaluate is a single literal it makes sense to look if - * our context is one with absolute line numbers we can then track - * into the literal itself too. - * - * See also tclCompile.c, TclInitCompileEnv, for the equivalent code - * in the bytecode compiler. */ const char *script; @@ -6083,92 +6109,19 @@ TclNREvalObjEx( */ ContLineLoc *saveCLLocPtr = iPtr->scriptCLLocPtr; - ContLineLoc *clLocPtr = TclContinuationsGet(objPtr); - - if (clLocPtr) { - iPtr->scriptCLLocPtr = clLocPtr; - Tcl_Preserve(iPtr->scriptCLLocPtr); - } else { - iPtr->scriptCLLocPtr = NULL; - } - Tcl_IncrRefCount(objPtr); - if (invoker == NULL) { - /* - * No context, force opening of our own. - */ - - script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); - result = Tcl_EvalEx(interp, script, numSrcBytes, flags); - } else { - /* - * We have an invoker, describing the command asking for the - * evaluation of a subordinate script. This script may originate - * in a literal word, or from a variable, etc. Using the line - * array we now check if we have good line information for the - * relevant word. The type of context is relevant as well. In a - * non-'source' context we don't have to try tracking lines. - * - * First see if the word exists and is a literal. If not we go - * through the easy dynamic branch. No need to perform more - * complex invokations. - */ + assert(invoker == NULL); - int pc = 0; - CmdFrame *ctxPtr = TclStackAlloc(interp, sizeof(CmdFrame)); - - *ctxPtr = *invoker; - if (invoker->type == TCL_LOCATION_BC) { - /* - * Note: Type BC => ctxPtr->data.eval.path is not used. - * ctxPtr->data.tebc.codePtr is used instead. - */ - - TclGetSrcInfoForPc(ctxPtr); - pc = 1; - } - - script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); - - if ((invoker->nline <= word) || - (invoker->line[word] < 0) || - (ctxPtr->type != TCL_LOCATION_SOURCE)) { - /* - * Dynamic script, or dynamic context, force our own context. - */ - - result = Tcl_EvalEx(interp, script, numSrcBytes, flags); - } else { - /* - * Absolute context to reuse. - */ + iPtr->scriptCLLocPtr = TclContinuationsGet(objPtr); - iPtr->invokeCmdFramePtr = ctxPtr; - iPtr->evalFlags |= TCL_EVAL_CTX; - - result = TclEvalEx(interp, script, numSrcBytes, flags, - ctxPtr->line[word], NULL, script); - } - if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) { - /* - * Death of SrcInfo reference. - */ + Tcl_IncrRefCount(objPtr); - Tcl_DecrRefCount(ctxPtr->data.eval.path); - } - TclStackFree(interp, ctxPtr); - } + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + result = Tcl_EvalEx(interp, script, numSrcBytes, flags); - /* - * Now release the lock on the continuation line information, if any, - * and restore the caller's settings. - */ + TclDecrRefCount(objPtr); - if (iPtr->scriptCLLocPtr) { - Tcl_Release(iPtr->scriptCLLocPtr); - } iPtr->scriptCLLocPtr = saveCLLocPtr; - TclDecrRefCount(objPtr); return result; } } @@ -6228,6 +6181,7 @@ TEOEx_ListCallback( Interp *iPtr = (Interp *) interp; Tcl_Obj *listPtr = data[0]; CmdFrame *eoFramePtr = data[1]; + Tcl_Obj *objPtr = data[2]; /* * Remove the cmdFrame @@ -6237,6 +6191,7 @@ TEOEx_ListCallback( iPtr->cmdFramePtr = eoFramePtr->nextPtr; TclStackFree(interp, eoFramePtr); } + TclDecrRefCount(objPtr); TclDecrRefCount(listPtr); return result; @@ -6599,30 +6554,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; @@ -6638,36 +6595,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; } @@ -6744,6 +6692,7 @@ Tcl_ExprString( *---------------------------------------------------------------------- */ +#undef Tcl_AddObjErrorInfo void Tcl_AppendObjToErrorInfo( Tcl_Interp *interp, /* Interpreter to which error information @@ -6777,6 +6726,7 @@ Tcl_AppendObjToErrorInfo( *---------------------------------------------------------------------- */ +#undef Tcl_AddErrorInfo void Tcl_AddErrorInfo( Tcl_Interp *interp, /* Interpreter to which error information @@ -6957,6 +6907,7 @@ Tcl_VarEval( *---------------------------------------------------------------------- */ +#undef Tcl_GlobalEval int Tcl_GlobalEval( Tcl_Interp *interp, /* Interpreter in which to evaluate @@ -7475,7 +7426,7 @@ ExprAbsFunc( return TCL_OK; } -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG if (type == TCL_NUMBER_WIDE) { Tcl_WideInt w = *((const Tcl_WideInt *) ptr); @@ -8115,39 +8066,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); } /* @@ -8240,7 +8163,8 @@ Tcl_NRCmdSwap( Tcl_Obj *const objv[], int flags) { - return TclNREvalObjv(interp, objc, objv, flags, (Command *) cmd); + return TclNREvalObjv(interp, objc, objv, flags|TCL_EVAL_NOERR, + (Command *) cmd); } /***************************************************************************** @@ -8511,8 +8435,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 ...?"); @@ -8526,11 +8449,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. @@ -8539,15 +8464,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. */ diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 455b5a6..981f174 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[] = { @@ -204,9 +207,10 @@ typedef struct ByteArray { #define BYTEARRAY_SIZE(len) \ ((unsigned) (TclOffset(ByteArray, bytes) + (len))) #define GET_BYTEARRAY(objPtr) \ - ((ByteArray *) (objPtr)->internalRep.otherValuePtr) + ((ByteArray *) (objPtr)->internalRep.twoPtrValue.ptr1) #define SET_BYTEARRAY(objPtr, baPtr) \ - (objPtr)->internalRep.otherValuePtr = (void *) (baPtr) + (objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (baPtr) + /* *---------------------------------------------------------------------- @@ -325,7 +329,7 @@ Tcl_SetByteArrayObj( Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayObj"); } TclFreeIntRep(objPtr); - Tcl_InvalidateStringRep(objPtr); + TclInvalidateStringRep(objPtr); if (length < 0) { length = 0; @@ -420,7 +424,7 @@ Tcl_SetByteArrayLength( byteArrayPtr->allocated = length; SET_BYTEARRAY(objPtr, byteArrayPtr); } - Tcl_InvalidateStringRep(objPtr); + TclInvalidateStringRep(objPtr); byteArrayPtr->used = length; return byteArrayPtr->bytes; } @@ -606,9 +610,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. @@ -627,6 +629,7 @@ TclAppendBytesToByteArray( int len) { ByteArray *byteArrayPtr; + int needed; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object","TclAppendBytesToByteArray"); @@ -635,64 +638,57 @@ TclAppendBytesToByteArray( Tcl_Panic("%s must be called with definite number of bytes to append", "TclAppendBytesToByteArray"); } + if (len == 0) { + /* Append zero bytes is a no-op. */ + return; + } if (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; - Tcl_InvalidateStringRep(objPtr); } + byteArrayPtr->used += len; + TclInvalidateStringRep(objPtr); } /* @@ -2311,7 +2307,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) { @@ -2323,8 +2318,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; @@ -2385,29 +2380,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; @@ -2435,7 +2433,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 @@ -2471,7 +2469,6 @@ BinaryEncode64( { Tcl_Obj *resultObj; unsigned char *data, *cursor, *limit; - const char *digits = clientData; int maxlen = 0; const char *wrapchar = "\n"; int wrapcharlen = 1; @@ -2494,6 +2491,13 @@ BinaryEncode64( if (Tcl_GetIntFromObj(interp, objv[i+1], &maxlen) != TCL_OK) { return TCL_ERROR; } + if (maxlen < 0) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "line length out of range", -1)); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", + "LINE_LENGTH", NULL); + return TCL_ERROR; + } break; case OPT_WRAPCHAR: wrapchar = Tcl_GetStringFromObj(objv[i+1], &wrapcharlen); @@ -2524,17 +2528,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]); } } } @@ -2546,6 +2550,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. @@ -2569,8 +2692,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 }; @@ -2596,44 +2719,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 ab977cb..70e64f0 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -156,6 +156,10 @@ TclInitDbCkalloc(void) if (!ckallocInit) { ckallocInit = 1; ckallocMutexPtr = Tcl_GetAllocMutex(); +#ifndef TCL_THREADS + /* Silence compiler warning */ + (void)ckallocMutexPtr; +#endif } } diff --git a/generic/tclClock.c b/generic/tclClock.c index 6d2976d..7e917f6 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 @@ -548,18 +548,21 @@ ClockGetjuliandayfromerayearmonthdayObjCmd( } dict = objv[1]; if (Tcl_DictObjGet(interp, dict, literals[LIT_ERA], &fieldPtr) != TCL_OK + || fieldPtr == NULL || Tcl_GetIndexFromObj(interp, fieldPtr, eras, "era", TCL_EXACT, &era) != TCL_OK - || Tcl_DictObjGet(interp, dict, literals[LIT_YEAR], - &fieldPtr) != TCL_OK + || Tcl_DictObjGet(interp, dict, literals[LIT_YEAR], &fieldPtr) != TCL_OK + || fieldPtr == NULL || TclGetIntFromObj(interp, fieldPtr, &fields.year) != TCL_OK - || Tcl_DictObjGet(interp, dict, literals[LIT_MONTH], - &fieldPtr) != TCL_OK + || Tcl_DictObjGet(interp, dict, literals[LIT_MONTH], &fieldPtr) != TCL_OK + || fieldPtr == NULL || TclGetIntFromObj(interp, fieldPtr, &fields.month) != TCL_OK - || Tcl_DictObjGet(interp, dict, literals[LIT_DAYOFMONTH], - &fieldPtr) != TCL_OK + || Tcl_DictObjGet(interp, dict, literals[LIT_DAYOFMONTH], &fieldPtr) != TCL_OK + || fieldPtr == NULL || TclGetIntFromObj(interp, fieldPtr, &fields.dayOfMonth)!=TCL_OK || TclGetIntFromObj(interp, objv[2], &changeover) != TCL_OK) { + if (fieldPtr == NULL) + Tcl_SetObjResult(interp, Tcl_NewStringObj("expected key(s) not found in dictionary", -1)); return TCL_ERROR; } fields.era = era; @@ -638,18 +641,21 @@ ClockGetjuliandayfromerayearweekdayObjCmd( } dict = objv[1]; if (Tcl_DictObjGet(interp, dict, literals[LIT_ERA], &fieldPtr) != TCL_OK + || fieldPtr == NULL || 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 + || Tcl_DictObjGet(interp, dict, literals[LIT_ISO8601YEAR], &fieldPtr) != TCL_OK + || fieldPtr == NULL + || TclGetIntFromObj(interp, fieldPtr, &(fields.iso8601Year)) != TCL_OK + || Tcl_DictObjGet(interp, dict, literals[LIT_ISO8601WEEK], &fieldPtr) != TCL_OK + || fieldPtr == NULL + || TclGetIntFromObj(interp, fieldPtr, &(fields.iso8601Week)) != TCL_OK + || Tcl_DictObjGet(interp, dict, literals[LIT_DAYOFWEEK], &fieldPtr) != TCL_OK + || fieldPtr == NULL + || TclGetIntFromObj(interp, fieldPtr, &(fields.dayOfWeek)) != TCL_OK || TclGetIntFromObj(interp, objv[2], &changeover) != TCL_OK) { + if (fieldPtr == NULL) + Tcl_SetObjResult(interp, Tcl_NewStringObj("expected key(s) not found in dictionary", -1)); return TCL_ERROR; } fields.era = era; @@ -1697,7 +1703,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 +1873,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; } diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 820eec5..d90a747 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -11,7 +11,6 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#include <sys/stat.h> #include "tclInt.h" #include <locale.h> @@ -195,8 +194,7 @@ Tcl_CaseObjCmd( for (i = 0; i < caseObjc; i += 2) { int patObjc, j; const char **patObjv; - const char *pat; - unsigned char *p; + const char *pat, *p; if (i == caseObjc-1) { Tcl_ResetResult(interp); @@ -211,8 +209,8 @@ Tcl_CaseObjCmd( */ pat = TclGetString(caseObjv[i]); - for (p = (unsigned char *) pat; *p != '\0'; p++) { - if (isspace(*p) || (*p == '\\')) { /* INTL: ISO space, UCHAR */ + for (p = pat; *p != '\0'; p++) { + if (TclIsSpaceProc(*p) || (*p == '\\')) { break; } } @@ -1592,7 +1590,7 @@ FileAttrIsOwnedCmd( * test for equivalence to the current user. */ -#if defined(__WIN32__) || defined(__CYGWIN__) +#if defined(_WIN32) || defined(__CYGWIN__) value = 1; #else value = (geteuid() == buf.st_uid); diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index c70ba23..f870245 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; @@ -1147,41 +1147,38 @@ InfoFrameCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Interp *iPtr = (Interp *) interp; - int level, topLevel, code = TCL_OK; - CmdFrame *runPtr, *framePtr; + int level, code = TCL_OK; + CmdFrame *framePtr, **cmdFramePtrPtr = &iPtr->cmdFramePtr; CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; + int topLevel = 0; if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "?number?"); return TCL_ERROR; } - topLevel = ((iPtr->cmdFramePtr == NULL) - ? 0 - : iPtr->cmdFramePtr->level); - - if (corPtr) { - /* - * A coroutine: must fix the level computations AND the cmdFrame chain, - * which is interrupted at the base. - */ - - CmdFrame *lastPtr = NULL; - - runPtr = iPtr->cmdFramePtr; + while (corPtr) { + while (*cmdFramePtrPtr) { + topLevel++; + cmdFramePtrPtr = &((*cmdFramePtrPtr)->nextPtr); + } + if (corPtr->caller.cmdFramePtr) { + *cmdFramePtrPtr = corPtr->caller.cmdFramePtr; + } + corPtr = corPtr->callerEEPtr->corPtr; + } + topLevel += (*cmdFramePtrPtr)->level; - /* TODO - deal with overflow */ - topLevel += corPtr->caller.cmdFramePtr->level; - while (runPtr) { - runPtr->level += corPtr->caller.cmdFramePtr->level; - lastPtr = runPtr; - runPtr = runPtr->nextPtr; + if (topLevel != iPtr->cmdFramePtr->level) { + framePtr = iPtr->cmdFramePtr; + while (framePtr) { + framePtr->level = topLevel--; + framePtr = framePtr->nextPtr; } - if (lastPtr) { - lastPtr->nextPtr = corPtr->caller.cmdFramePtr; - } else { - iPtr->cmdFramePtr = corPtr->caller.cmdFramePtr; + if (topLevel) { + Tcl_Panic("Broken frame level calculation"); } + topLevel = iPtr->cmdFramePtr->level; } if (objc == 1) { @@ -1231,20 +1228,27 @@ InfoFrameCmd( Tcl_SetObjResult(interp, TclInfoFrame(interp, framePtr)); done: - if (corPtr) { + cmdFramePtrPtr = &iPtr->cmdFramePtr; + corPtr = iPtr->execEnvPtr->corPtr; + while (corPtr) { + CmdFrame *endPtr = corPtr->caller.cmdFramePtr; + + if (endPtr) { + if (*cmdFramePtrPtr == endPtr) { + *cmdFramePtrPtr = NULL; + } else { + CmdFrame *runPtr = *cmdFramePtrPtr; - if (iPtr->cmdFramePtr == corPtr->caller.cmdFramePtr) { - iPtr->cmdFramePtr = NULL; - } else { - runPtr = iPtr->cmdFramePtr; - while (runPtr->nextPtr != corPtr->caller.cmdFramePtr) { - runPtr->level -= corPtr->caller.cmdFramePtr->level; - runPtr = runPtr->nextPtr; + while (runPtr->nextPtr != endPtr) { + runPtr->level -= endPtr->level; + runPtr = runPtr->nextPtr; + } + runPtr->level = 1; + runPtr->nextPtr = NULL; } - runPtr->level = 1; - runPtr->nextPtr = NULL; + cmdFramePtrPtr = &corPtr->caller.cmdFramePtr; } - + corPtr = corPtr->callerEEPtr->corPtr; } return code; } @@ -1284,6 +1288,9 @@ TclInfoFrame( }; Proc *procPtr = framePtr->framePtr ? framePtr->framePtr->procPtr : NULL; + /* Super ugly hack added to the pile so we can plug memleak */ + int needsFree = -1; + /* * Pull the information and construct the dictionary to return, as list. * Regarding use of the CmdFrame fields see tclInt.h, and its definition. @@ -1302,28 +1309,12 @@ TclInfoFrame( */ ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1)); - ADD_PAIR("line", Tcl_NewIntObj(framePtr->line[0])); - ADD_PAIR("cmd", Tcl_NewStringObj(framePtr->cmd.str.cmd, - framePtr->cmd.str.len)); - break; - - case TCL_LOCATION_EVAL_LIST: - /* - * List optimized evaluation. Type, line, cmd, the latter through - * listPtr, possibly a frame. - */ - - ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1)); - ADD_PAIR("line", Tcl_NewIntObj(1)); - - /* - * We put a duplicate of the command list obj into the result to - * ensure that the 'pure List'-property of the command itself is not - * destroyed. Otherwise the query here would disable the list - * optimization path in Tcl_EvalObjEx. - */ - - ADD_PAIR("cmd", Tcl_DuplicateObj(framePtr->cmd.listPtr)); + if (framePtr->line) { + ADD_PAIR("line", Tcl_NewIntObj(framePtr->line[0])); + } else { + ADD_PAIR("line", Tcl_NewIntObj(1)); + } + ADD_PAIR("cmd", TclGetSourceFromFrame(framePtr, 0, NULL)); break; case TCL_LOCATION_PREBC: @@ -1371,8 +1362,8 @@ TclInfoFrame( Tcl_DecrRefCount(fPtr->data.eval.path); } - ADD_PAIR("cmd", - Tcl_NewStringObj(fPtr->cmd.str.cmd, fPtr->cmd.str.len)); + ADD_PAIR("cmd", TclGetSourceFromFrame(fPtr, 0, NULL)); + needsFree = lc-1; TclStackFree(interp, fPtr); break; } @@ -1391,8 +1382,7 @@ TclInfoFrame( * the result list object. */ - ADD_PAIR("cmd", Tcl_NewStringObj(framePtr->cmd.str.cmd, - framePtr->cmd.str.len)); + ADD_PAIR("cmd", TclGetSourceFromFrame(framePtr, 0, NULL)); break; case TCL_LOCATION_PROC: @@ -1461,7 +1451,11 @@ TclInfoFrame( } } - return Tcl_NewListObj(lc, lv); + tmpObj = Tcl_NewListObj(lc, lv); + if (needsFree >= 0) { + Tcl_DecrRefCount(lv[needsFree]); + } + return tmpObj; } /* @@ -2907,7 +2901,8 @@ Tcl_LsearchObjCmd( { const char *bytes, *patternBytes; int i, match, index, result, listc, length, elemLen, bisect; - int dataType, isIncreasing, lower, upper, patInt, objInt, offset; + int dataType, isIncreasing, lower, upper, offset; + Tcl_WideInt patWide, objWide; int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase; double patDouble, objDouble; SortInfo sortInfo; @@ -3005,7 +3000,7 @@ Tcl_LsearchObjCmd( dataType = INTEGER; break; case LSEARCH_NOCASE: /* -nocase */ - strCmpFn = strcasecmp; + strCmpFn = TclUtfCasecmp; noCase = 1; break; case LSEARCH_NOT: /* -not */ @@ -3226,7 +3221,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; } @@ -3295,13 +3290,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; @@ -3400,7 +3395,7 @@ Tcl_LsearchObjCmd( */ if (noCase) { - match = (strcasecmp(bytes, patternBytes) == 0); + match = (TclUtfCasecmp(bytes, patternBytes) == 0); } else { match = (memcmp(bytes, patternBytes, (size_t) length) == 0); @@ -3414,14 +3409,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: @@ -3645,7 +3640,8 @@ Tcl_LsortObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument values. */ { - int i, j, index, indices, length, nocase = 0, sortMode, indexc; + int i, j, index, indices, length, nocase = 0, indexc; + int sortMode = SORTMODE_ASCII; int group, groupSize, groupOffset, idx, allocatedIndexVector = 0; Tcl_Obj *resultPtr, *cmdPtr, **listObjPtrs, *listObj, *indexPtr; SortElement *elementArray, *elementPtr; @@ -3984,14 +3980,14 @@ 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; } - elementArray[i].collationKey.intValue = a; - } else if (sortInfo.sortMode == SORTMODE_REAL) { + elementArray[i].collationKey.wideValue = a; + } else if (sortMode == SORTMODE_REAL) { double a; if (Tcl_GetDoubleFromObj(sortInfo.interp, indexPtr, @@ -4088,7 +4084,7 @@ Tcl_LsortObjCmd( TclStackFree(interp, elementArray); done: - if (sortInfo.sortMode == SORTMODE_COMMAND) { + if (sortMode == SORTMODE_COMMAND) { TclDecrRefCount(sortInfo.compareCmdPtr); TclDecrRefCount(listObj); sortInfo.compareCmdPtr = NULL; @@ -4233,16 +4229,16 @@ SortCompare( order = strcmp(elemPtr1->collationKey.strValuePtr, elemPtr2->collationKey.strValuePtr); } else if (infoPtr->sortMode == SORTMODE_ASCII_NC) { - order = strcasecmp(elemPtr1->collationKey.strValuePtr, + order = TclUtfCasecmp(elemPtr1->collationKey.strValuePtr, elemPtr2->collationKey.strValuePtr); } else if (infoPtr->sortMode == SORTMODE_DICTIONARY) { order = DictionaryCompare(elemPtr1->collationKey.strValuePtr, 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; diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 95debf8..0f7f20a 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -18,6 +18,7 @@ #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); @@ -37,32 +38,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 +161,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 +217,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 +231,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; } @@ -517,7 +521,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; } @@ -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); @@ -1540,7 +1544,8 @@ StringIsCmd( case STR_IS_BOOL: case STR_IS_TRUE: case STR_IS_FALSE: - if (TCL_OK != Tcl_ConvertToType(NULL, objPtr, &tclBooleanType)) { + if ((objPtr->typePtr != &tclBooleanType) + && (TCL_OK != TclSetBooleanFromAny(NULL, objPtr))) { if (strict) { result = 0; } else { @@ -1564,7 +1569,7 @@ StringIsCmd( /* TODO */ if ((objPtr->typePtr == &tclDoubleType) || (objPtr->typePtr == &tclIntType) || -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG (objPtr->typePtr == &tclWideIntType) || #endif (objPtr->typePtr == &tclBignumType)) { @@ -1601,7 +1606,7 @@ StringIsCmd( goto failedIntParse; case STR_IS_ENTIER: if ((objPtr->typePtr == &tclIntType) || -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG (objPtr->typePtr == &tclWideIntType) || #endif (objPtr->typePtr == &tclBignumType)) { @@ -3188,8 +3193,8 @@ 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; @@ -3236,8 +3241,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; @@ -3282,8 +3287,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; @@ -3329,21 +3334,21 @@ TclInitStringCmd( {"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} @@ -3388,7 +3393,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; } @@ -3526,7 +3531,7 @@ TclNRSwitchObjCmd( i++; goto finishedOptions; case OPT_NOCASE: - strCmpFn = strcasecmp; + strCmpFn = TclUtfCasecmp; noCase = 1; break; @@ -3588,7 +3593,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) { @@ -3635,7 +3640,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 503f339..d1d7a80 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -7,7 +7,7 @@ * Copyright (c) 1997-1998 Sun Microsystems, Inc. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * Copyright (c) 2002 ActiveState Corporation. - * Copyright (c) 2004-2006 by Donal K. Fellows. + * Copyright (c) 2004-2013 by Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -31,16 +31,9 @@ static void FreeForeachInfo(ClientData clientData); static void PrintForeachInfo(ClientData clientData, Tcl_Obj *appendObj, ByteCode *codePtr, unsigned int pcOffset); -static void CompileReturnInternal(CompileEnv *envPtr, - unsigned char op, int code, int level, - Tcl_Obj *returnOpts); -static int IndexTailVarIfKnown(Tcl_Interp *interp, - Tcl_Token *varTokenPtr, CompileEnv *envPtr); -static int PushVarName(Tcl_Interp *interp, - Tcl_Token *varTokenPtr, CompileEnv *envPtr, - int flags, int *localIndexPtr, - int *simpleVarNamePtr, int *isScalarPtr, - int line, int *clNext); +static void PrintNewForeachInfo(ClientData clientData, + Tcl_Obj *appendObj, ByteCode *codePtr, + unsigned int pcOffset); static int CompileEachloopCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, CompileEnv *envPtr, int collect); @@ -48,67 +41,6 @@ static int CompileDictEachCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr, int collect); - -/* - * Macro that encapsulates an efficiency trick that avoids a function call for - * the simplest of compiles. The ANSI C "prototype" for this macro is: - * - * static void CompileWord(CompileEnv *envPtr, Tcl_Token *tokenPtr, - * Tcl_Interp *interp, int word); - */ - -#define CompileWord(envPtr, tokenPtr, interp, word) \ - if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) { \ - TclEmitPush(TclRegisterNewLiteral((envPtr), (tokenPtr)[1].start, \ - (tokenPtr)[1].size), (envPtr)); \ - } else { \ - envPtr->line = mapPtr->loc[eclIndex].line[word]; \ - envPtr->clNext = mapPtr->loc[eclIndex].next[word]; \ - TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ - (envPtr)); \ - } - -/* - * TIP #280: Remember the per-word line information of the current command. An - * index is used instead of a pointer as recursive compilation may reallocate, - * i.e. move, the array. This is also the reason to save the nuloc now, it may - * change during the course of the function. - * - * Macro to encapsulate the variable definition and setup. - */ - -#define DefineLineInformation \ - ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ - int eclIndex = mapPtr->nuloc - 1 - -#define SetLineInformation(word) \ - envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ - envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] - -#define PushVarNameWord(i,v,e,f,l,s,sc,word) \ - PushVarName(i,v,e,f,l,s,sc, \ - mapPtr->loc[eclIndex].line[(word)], \ - mapPtr->loc[eclIndex].next[(word)]) - -/* - * Often want to issue one of two versions of an instruction based on whether - * the argument will fit in a single byte or not. This makes it much clearer. - */ - -#define Emit14Inst(nm,idx,envPtr) \ - if (idx <= 255) { \ - TclEmitInstInt1(nm##1,idx,envPtr); \ - } else { \ - TclEmitInstInt4(nm##4,idx,envPtr); \ - } - -/* - * Flags bits used by PushVarName. - */ - -#define TCL_NO_LARGE_INDEX 1 /* Do not return localIndex value > 255 */ -#define TCL_NO_ELEMENT 2 /* Do not push the array element. */ - /* * The structures below define the AuxData types defined in this file. */ @@ -120,6 +52,13 @@ const AuxDataType tclForeachInfoType = { PrintForeachInfo /* printProc */ }; +const AuxDataType tclNewForeachInfoType = { + "NewForeachInfo", /* name */ + DupForeachInfo, /* dupProc */ + FreeForeachInfo, /* freeProc */ + PrintNewForeachInfo /* printProc */ +}; + const AuxDataType tclDictUpdateInfoType = { "DictUpdateInfo", /* name */ DupDictUpdateInfo, /* dupProc */ @@ -155,9 +94,10 @@ TclCompileAppendCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr, *valueTokenPtr; - int simpleVarName, isScalar, localIndex, numWords; + int isScalar, localIndex, numWords, i; DefineLineInformation; /* TIP #280 */ + /* TODO: Consider support for compiling expanded args. */ numWords = parsePtr->numWords; if (numWords == 1) { return TCL_ERROR; @@ -169,10 +109,11 @@ TclCompileAppendCmd( return TclCompileSetCmd(interp, parsePtr, cmdPtr, envPtr); } else if (numWords > 3) { /* - * APPEND instructions currently only handle one value. + * APPEND instructions currently only handle one value, but we can + * handle some multi-value cases by stringing them together. */ - return TCL_ERROR; + goto appendMultiple; } /* @@ -186,7 +127,7 @@ TclCompileAppendCmd( varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarNameWord(interp, varTokenPtr, envPtr, 0, - &localIndex, &simpleVarName, &isScalar, 1); + &localIndex, &isScalar, 1); /* * We are doing an assignment, otherwise TclCompileSetCmd was called, so @@ -194,16 +135,13 @@ TclCompileAppendCmd( * each argument. */ - if (numWords > 2) { valueTokenPtr = TokenAfter(varTokenPtr); CompileWord(envPtr, valueTokenPtr, interp, 2); - } /* * Emit instructions to set/get the variable. */ - if (simpleVarName) { if (isScalar) { if (localIndex < 0) { TclEmitOpcode(INST_APPEND_STK, envPtr); @@ -217,8 +155,38 @@ TclCompileAppendCmd( Emit14Inst(INST_APPEND_ARRAY, localIndex, envPtr); } } - } else { - TclEmitOpcode(INST_APPEND_STK, envPtr); + + return TCL_OK; + + appendMultiple: + /* + * Can only handle the case where we are appending to a local scalar when + * there are multiple values to append. Fortunately, this is common. + */ + + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT, + &localIndex, &isScalar, 1); + if (!isScalar || localIndex < 0) { + return TCL_ERROR; + } + + /* + * Definitely appending to a local scalar; generate the words and append + * them. + */ + + valueTokenPtr = TokenAfter(varTokenPtr); + for (i = 2 ; i < numWords ; i++) { + CompileWord(envPtr, valueTokenPtr, interp, i); + valueTokenPtr = TokenAfter(valueTokenPtr); + } + TclEmitInstInt4( INST_REVERSE, numWords-2, envPtr); + for (i = 2 ; i < numWords ;) { + Emit14Inst( INST_APPEND_SCALAR, localIndex, envPtr); + if (++i < numWords) { + TclEmitOpcode(INST_POP, envPtr); + } } return TCL_OK; @@ -253,7 +221,7 @@ TclCompileArrayExistsCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int simpleVarName, isScalar, localIndex; + int isScalar, localIndex; if (parsePtr->numWords != 2) { return TCL_ERROR; @@ -261,7 +229,7 @@ TclCompileArrayExistsCmd( tokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarNameWord(interp, tokenPtr, envPtr, TCL_NO_ELEMENT, - &localIndex, &simpleVarName, &isScalar, 1); + &localIndex, &isScalar, 1); if (!isScalar) { return TCL_ERROR; } @@ -284,37 +252,61 @@ TclCompileArraySetCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr; - int simpleVarName, isScalar, localIndex; - int dataVar, iterVar, keyVar, valVar, infoIndex; - int back, fwd, offsetBack, offsetFwd, savedStackDepth; + Tcl_Token *varTokenPtr, *dataTokenPtr; + int isScalar, localIndex, code = TCL_OK; + int isDataLiteral, isDataValid, isDataEven, len; + int keyVar, valVar, infoIndex; + int fwd, offsetBack, offsetFwd; + Tcl_Obj *literalObj; ForeachInfo *infoPtr; if (parsePtr->numWords != 3) { return TCL_ERROR; } - tokenPtr = TokenAfter(parsePtr->tokenPtr); - if (envPtr->procPtr == NULL) { - Tcl_Token *tokPtr = TokenAfter(tokenPtr); + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + dataTokenPtr = TokenAfter(varTokenPtr); + literalObj = Tcl_NewObj(); + isDataLiteral = TclWordKnownAtCompileTime(dataTokenPtr, literalObj); + isDataValid = (isDataLiteral + && Tcl_ListObjLength(NULL, literalObj, &len) == TCL_OK); + isDataEven = (isDataValid && (len & 1) == 0); - if (tokPtr->type != TCL_TOKEN_SIMPLE_WORD || tokPtr[1].size != 0) { - return TCL_ERROR; - } + /* + * Special case: literal odd-length argument is always an error. + */ + + if (isDataValid && !isDataEven) { + PushStringLiteral(envPtr, "list must have an even number of elements"); + PushStringLiteral(envPtr, "-errorcode {TCL ARGUMENT FORMAT}"); + TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR, envPtr); + TclEmitInt4( 0, envPtr); + goto done; } - PushVarNameWord(interp, tokenPtr, envPtr, TCL_NO_ELEMENT, - &localIndex, &simpleVarName, &isScalar, 1); + + /* + * Except for the special "ensure array" case below, when we're not in + * a proc, we cannot do a better compile than generic. + */ + + if (envPtr->procPtr == NULL && !(isDataEven && len == 0)) { + code = TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); + goto done; + } + + PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT, + &localIndex, &isScalar, 1); if (!isScalar) { - return TCL_ERROR; + code = TCL_ERROR; + goto done; } - tokenPtr = TokenAfter(tokenPtr); /* * Special case: literal empty value argument is just an "ensure array" * operation. */ - if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD && tokenPtr[1].size == 0) { + if (isDataEven && len == 0) { if (localIndex >= 0) { TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr); @@ -323,33 +315,39 @@ TclCompileArraySetCmd( TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); TclEmitInstInt1(INST_JUMP_TRUE1, 5, envPtr); - savedStackDepth = envPtr->currStackDepth; TclEmitOpcode( INST_ARRAY_MAKE_STK, envPtr); TclEmitInstInt1(INST_JUMP1, 3, envPtr); - envPtr->currStackDepth = savedStackDepth; + /* Each branch decrements stack depth, but we only take one. */ + TclAdjustStackDepth(1, envPtr); TclEmitOpcode( INST_POP, envPtr); } - PushLiteral(envPtr, "", 0); - return TCL_OK; + PushStringLiteral(envPtr, ""); + goto done; } + if (localIndex < 0) { + /* + * a non-local variable: upvar from a local one! This consumes the + * variable name that was left at stacktop. + */ + + localIndex = AnonymousLocal(envPtr); + PushStringLiteral(envPtr, "0"); + TclEmitInstInt4(INST_REVERSE, 2, envPtr); + TclEmitInstInt4(INST_UPVAR, localIndex, envPtr); + TclEmitOpcode(INST_POP, envPtr); + } + /* * Prepare for the internal foreach. */ - if (envPtr->procPtr == NULL) { - return TCL_ERROR; - } - dataVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); - iterVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); - keyVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); - valVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); + keyVar = AnonymousLocal(envPtr); + valVar = AnonymousLocal(envPtr); - infoPtr = ckalloc(sizeof(ForeachInfo) + sizeof(ForeachVarList *)); + infoPtr = ckalloc(sizeof(ForeachInfo)); infoPtr->numLists = 1; - infoPtr->firstValueTemp = dataVar; - infoPtr->loopCtTemp = iterVar; - infoPtr->varLists[0] = ckalloc(sizeof(ForeachVarList) * 2*sizeof(int)); + infoPtr->varLists[0] = ckalloc(sizeof(ForeachVarList) + sizeof(int)); infoPtr->varLists[0]->numVars = 2; infoPtr->varLists[0]->varIndexes[0] = keyVar; infoPtr->varLists[0]->varIndexes[1] = valVar; @@ -359,73 +357,48 @@ TclCompileArraySetCmd( * Start issuing instructions to write to the array. */ - CompileWord(envPtr, tokenPtr, interp, 2); - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_LIST_LENGTH, envPtr); - PushLiteral(envPtr, "1", 1); - TclEmitOpcode( INST_BITAND, envPtr); - offsetFwd = CurrentOffset(envPtr); - TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr); - savedStackDepth = envPtr->currStackDepth; - PushLiteral(envPtr, "list must have an even number of elements", - strlen("list must have an even number of elements")); - PushLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}", - strlen("-errorCode {TCL ARGUMENT FORMAT}")); - TclEmitInstInt4( INST_RETURN_IMM, 1, envPtr); - TclEmitInt4( 0, envPtr); - envPtr->currStackDepth = savedStackDepth; - fwd = CurrentOffset(envPtr) - offsetFwd; - TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); - Emit14Inst( INST_STORE_SCALAR, dataVar, envPtr); - TclEmitOpcode( INST_POP, envPtr); + CompileWord(envPtr, dataTokenPtr, interp, 2); + if (!isDataLiteral || !isDataValid) { + /* + * Only need this safety check if we're handling a non-literal or list + * containing an invalid literal; with valid list literals, we've + * already checked (worth it because literals are a very common + * use-case with [array set]). + */ - if (localIndex >= 0) { - TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); - TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr); - TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr); - TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr); - offsetBack = CurrentOffset(envPtr); - TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr); - offsetFwd = CurrentOffset(envPtr); - TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); - savedStackDepth = envPtr->currStackDepth; - Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr); - Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr); - Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); - back = offsetBack - CurrentOffset(envPtr); - TclEmitInstInt1(INST_JUMP1, back, envPtr); - fwd = CurrentOffset(envPtr) - offsetFwd; - TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); - envPtr->currStackDepth = savedStackDepth; - } else { - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); - TclEmitInstInt1(INST_JUMP_TRUE1, 4, envPtr); TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_ARRAY_MAKE_STK, envPtr); - TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr); - offsetBack = CurrentOffset(envPtr); - TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr); + TclEmitOpcode( INST_LIST_LENGTH, envPtr); + PushStringLiteral(envPtr, "1"); + TclEmitOpcode( INST_BITAND, envPtr); offsetFwd = CurrentOffset(envPtr); TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); - savedStackDepth = envPtr->currStackDepth; - TclEmitOpcode( INST_DUP, envPtr); - Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr); - Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr); - TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr); - TclEmitOpcode( INST_POP, envPtr); - back = offsetBack - CurrentOffset(envPtr); - TclEmitInstInt1(INST_JUMP1, back, envPtr); + PushStringLiteral(envPtr, "list must have an even number of elements"); + PushStringLiteral(envPtr, "-errorcode {TCL ARGUMENT FORMAT}"); + TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR, envPtr); + TclEmitInt4( 0, envPtr); + TclAdjustStackDepth(-1, envPtr); fwd = CurrentOffset(envPtr) - offsetFwd; TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); - envPtr->currStackDepth = savedStackDepth; - TclEmitOpcode( INST_POP, envPtr); } - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( dataVar, envPtr); - PushLiteral(envPtr, "", 0); - return TCL_OK; + + TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); + TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr); + TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr); + TclEmitInstInt4(INST_FOREACH_START, infoIndex, envPtr); + offsetBack = CurrentOffset(envPtr); + Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr); + Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr); + Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); + infoPtr->loopCtTemp = offsetBack - CurrentOffset(envPtr); /*misuse */ + TclEmitOpcode( INST_FOREACH_STEP, envPtr); + TclEmitOpcode( INST_FOREACH_END, envPtr); + TclAdjustStackDepth(-3, envPtr); + PushStringLiteral(envPtr, ""); + + done: + Tcl_DecrRefCount(literalObj); + return code; } int @@ -439,14 +412,14 @@ TclCompileArrayUnsetCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - int simpleVarName, isScalar, localIndex, savedStackDepth; + int isScalar, localIndex; if (parsePtr->numWords != 2) { - return TCL_ERROR; + return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } PushVarNameWord(interp, tokenPtr, envPtr, TCL_NO_ELEMENT, - &localIndex, &simpleVarName, &isScalar, 1); + &localIndex, &isScalar, 1); if (!isScalar) { return TCL_ERROR; } @@ -460,13 +433,13 @@ TclCompileArrayUnsetCmd( TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); TclEmitInstInt1(INST_JUMP_FALSE1, 6, envPtr); - savedStackDepth = envPtr->currStackDepth; TclEmitInstInt1(INST_UNSET_STK, 1, envPtr); TclEmitInstInt1(INST_JUMP1, 3, envPtr); - envPtr->currStackDepth = savedStackDepth; + /* Each branch decrements stack depth, but we only take one. */ + TclAdjustStackDepth(1, envPtr); TclEmitOpcode( INST_POP, envPtr); } - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); return TCL_OK; } @@ -497,16 +470,34 @@ TclCompileBreakCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + ExceptionRange *rangePtr; + ExceptionAux *auxPtr; + if (parsePtr->numWords != 1) { return TCL_ERROR; } /* - * Emit a break instruction. + * Find the innermost exception range that contains this command. */ - TclEmitOpcode(INST_BREAK, envPtr); - PushLiteral(envPtr, "", 0); /* Evil hack! */ + rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_BREAK, &auxPtr); + if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) { + /* + * Found the target! No need for a nasty INST_BREAK here. + */ + + TclCleanupStackForBreakContinue(envPtr, auxPtr); + TclAddLoopBreakFixup(envPtr, auxPtr); + } else { + /* + * Emit a real break. + */ + + TclEmitOpcode(INST_BREAK, envPtr); + } + TclAdjustStackDepth(1, envPtr); + return TCL_OK; } @@ -539,12 +530,10 @@ TclCompileCatchCmd( { JumpFixup jumpFixup; Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr; - const char *name; - int resultIndex, optsIndex, nameChars, range; - int initStackDepth = envPtr->currStackDepth; - int savedStackDepth; + int resultIndex, optsIndex, range, dropScript = 0; DefineLineInformation; /* TIP #280 */ - + int depth = TclGetStackDepth(envPtr); + /* * If syntax does not match what we expect for [catch], do not compile. * Let runtime checks determine if syntax has changed. @@ -573,17 +562,7 @@ TclCompileCatchCmd( if (parsePtr->numWords >= 3) { resultNameTokenPtr = TokenAfter(cmdTokenPtr); /* DGP */ - if (resultNameTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - - name = resultNameTokenPtr[1].start; - nameChars = resultNameTokenPtr[1].size; - if (!TclIsLocalScalar(name, nameChars)) { - return TCL_ERROR; - } - resultIndex = TclFindCompiledLocal(resultNameTokenPtr[1].start, - resultNameTokenPtr[1].size, /*create*/ 1, envPtr); + resultIndex = LocalScalarFromToken(resultNameTokenPtr, envPtr); if (resultIndex < 0) { return TCL_ERROR; } @@ -591,16 +570,7 @@ TclCompileCatchCmd( /* DKF */ if (parsePtr->numWords == 4) { optsNameTokenPtr = TokenAfter(resultNameTokenPtr); - if (optsNameTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - name = optsNameTokenPtr[1].start; - nameChars = optsNameTokenPtr[1].size; - if (!TclIsLocalScalar(name, nameChars)) { - return TCL_ERROR; - } - optsIndex = TclFindCompiledLocal(optsNameTokenPtr[1].start, - optsNameTokenPtr[1].size, /*create*/ 1, envPtr); + optsIndex = LocalScalarFromToken(optsNameTokenPtr, envPtr); if (optsIndex < 0) { return TCL_ERROR; } @@ -610,11 +580,7 @@ TclCompileCatchCmd( /* * We will compile the catch command. Declare the exception range that it * uses. - */ - - range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); - - /* + * * If the body is a simple word, compile a BEGIN_CATCH instruction, * followed by the instructions to eval the body. * Otherwise, compile instructions to substitute the body text before @@ -627,83 +593,62 @@ TclCompileCatchCmd( * begin by undeflowing the stack below the mark set by BEGIN_CATCH4. */ - SetLineInformation(1); + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - savedStackDepth = envPtr->currStackDepth; TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); - CompileBody(envPtr, cmdTokenPtr, interp); + BODY(cmdTokenPtr, 1); } else { + SetLineInformation(1); CompileTokens(envPtr, cmdTokenPtr, interp); - savedStackDepth = envPtr->currStackDepth; TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_EVAL_STK, envPtr); - } - /* Stack at this point: - * nonsimple: script <mark> result - * simple: <mark> result - */ - - if (resultIndex == -1) { - /* - * Special case when neither result nor options are being saved. In - * that case, we can skip quite a bit of the command epilogue; all we - * have to do is drop the result and push the return code (and, of - * course, finish the catch context). - */ - + TclEmitInvoke(envPtr, INST_EVAL_STK); + /* drop the script */ + dropScript = 1; + TclEmitInstInt4( INST_REVERSE, 2, envPtr); TclEmitOpcode( INST_POP, envPtr); - PushLiteral(envPtr, "0", 1); - TclEmitInstInt1( INST_JUMP1, 3, envPtr); - envPtr->currStackDepth = savedStackDepth; - ExceptionRangeTarget(envPtr, range, catchOffset); - TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr); - ExceptionRangeEnds(envPtr, range); - TclEmitOpcode( INST_END_CATCH, envPtr); - - /* - * Stack at this point: - * nonsimple: script <mark> returnCode - * simple: <mark> returnCode - */ - - goto dropScriptAtEnd; } + ExceptionRangeEnds(envPtr, range); + /* * Emit the "no errors" epilogue: push "0" (TCL_OK) as the catch result, * and jump around the "error case" code. */ - PushLiteral(envPtr, "0", 1); + TclCheckStackDepth(depth+1, envPtr); + PushStringLiteral(envPtr, "0"); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); - /* Stack at this point: ?script? <mark> result TCL_OK */ /* * Emit the "error case" epilogue. Push the interpreter result and the * return code. */ - envPtr->currStackDepth = savedStackDepth; ExceptionRangeTarget(envPtr, range, catchOffset); - /* Stack at this point: ?script? */ + TclSetStackDepth(depth + dropScript, envPtr); + + if (dropScript) { + TclEmitOpcode( INST_POP, envPtr); + } + + + /* Stack at this point is empty */ TclEmitOpcode( INST_PUSH_RESULT, envPtr); TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr); - /* - * Update the target of the jump after the "no errors" code. - */ + /* Stack at this point on both branches: result returnCode */ - /* Stack at this point: ?script? result returnCode */ if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { Tcl_Panic("TclCompileCatchCmd: bad jump distance %d", (int)(CurrentOffset(envPtr) - jumpFixup.codeOffset)); } /* - * Push the return options if the caller wants them. + * Push the return options if the caller wants them. This needs to happen + * before INST_END_CATCH */ if (optsIndex != -1) { @@ -714,62 +659,118 @@ TclCompileCatchCmd( * End the catch */ - ExceptionRangeEnds(envPtr, range); TclEmitOpcode( INST_END_CATCH, envPtr); /* - * At this point, the top of the stack is inconveniently ordered: - * ?script? result returnCode ?returnOptions? - * Reverse the stack to bring the result to the top. + * Save the result and return options if the caller wants them. This needs + * to happen after INST_END_CATCH (compile-3.6/7). */ if (optsIndex != -1) { - TclEmitInstInt4( INST_REVERSE, 3, envPtr); - } else { - TclEmitInstInt4( INST_REVERSE, 2, envPtr); + Emit14Inst( INST_STORE_SCALAR, optsIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); } /* - * Store the result and remove it from the stack. + * At this point, the top of the stack is inconveniently ordered: + * result returnCode + * Reverse the stack to store the result. */ - Emit14Inst( INST_STORE_SCALAR, resultIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + if (resultIndex != -1) { + Emit14Inst( INST_STORE_SCALAR, resultIndex, envPtr); + } + TclEmitOpcode( INST_POP, envPtr); + + TclCheckStackDepth(depth+1, envPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileConcatCmd -- + * + * Procedure called to compile the "concat" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "concat" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileConcatCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Obj *objPtr, *listObj; + Tcl_Token *tokenPtr; + int i; + + /* TODO: Consider compiling expansion case. */ + if (parsePtr->numWords == 1) { + /* + * [concat] without arguments just pushes an empty object. + */ + + PushStringLiteral(envPtr, ""); + return TCL_OK; + } /* - * Stack is now ?script? ?returnOptions? returnCode. - * If the options dict has been requested, it is buried on the stack under - * the return code. Reverse the stack to bring it to the top, store it and - * remove it from the stack. + * Test if all arguments are compile-time known. If they are, we can + * implement with a simple push. */ - if (optsIndex != -1) { - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - Emit14Inst( INST_STORE_SCALAR, optsIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); + listObj = Tcl_NewObj(); + for (i = 1, tokenPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++) { + tokenPtr = TokenAfter(tokenPtr); + objPtr = Tcl_NewObj(); + if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) { + Tcl_DecrRefCount(objPtr); + Tcl_DecrRefCount(listObj); + listObj = NULL; + break; + } + (void) Tcl_ListObjAppendElement(NULL, listObj, objPtr); } + if (listObj != NULL) { + Tcl_Obj **objs; + const char *bytes; + int len; - dropScriptAtEnd: + Tcl_ListObjGetElements(NULL, listObj, &len, &objs); + objPtr = Tcl_ConcatObj(len, objs); + Tcl_DecrRefCount(listObj); + bytes = Tcl_GetStringFromObj(objPtr, &len); + PushLiteral(envPtr, bytes, len); + Tcl_DecrRefCount(objPtr); + return TCL_OK; + } /* - * Stack is now ?script? result. Get rid of the subst'ed script if it's - * hanging arond. + * General case: runtime concat. */ - if (cmdTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - TclEmitOpcode( INST_POP, envPtr); + for (i = 1, tokenPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++) { + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, i); } - /* - * Result of all this, on either branch, should have been to leave one - * operand -- the return code -- on the stack. - */ + TclEmitInstInt4( INST_CONCAT_STK, i-1, envPtr); - if (envPtr->currStackDepth != initStackDepth + 1) { - Tcl_Panic("in TclCompileCatchCmd, currStackDepth = %d should be %d", - envPtr->currStackDepth, initStackDepth+1); - } return TCL_OK; } @@ -800,6 +801,9 @@ TclCompileContinueCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { + ExceptionRange *rangePtr; + ExceptionAux *auxPtr; + /* * There should be no argument after the "continue". */ @@ -809,11 +813,27 @@ TclCompileContinueCmd( } /* - * Emit a continue instruction. + * See if we can find a valid continueOffset (i.e., not -1) in the + * innermost containing exception range. */ - TclEmitOpcode(INST_CONTINUE, envPtr); - PushLiteral(envPtr, "", 0); /* Evil hack! */ + rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_CONTINUE, &auxPtr); + if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) { + /* + * Found the target! No need for a nasty INST_CONTINUE here. + */ + + TclCleanupStackForBreakContinue(envPtr, auxPtr); + TclAddLoopContinueFixup(envPtr, auxPtr); + } else { + /* + * Emit a real continue. + */ + + TclEmitOpcode(INST_CONTINUE, envPtr); + } + TclAdjustStackDepth(1, envPtr); + return TCL_OK; } @@ -845,11 +865,9 @@ TclCompileDictSetCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *tokenPtr; - int numWords, i; + int i, dictVarIndex; DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr; - int dictVarIndex, nameChars; - const char *name; /* * There must be at least one argument after the command. @@ -866,15 +884,7 @@ TclCompileDictSetCmd( */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); - if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - name = varTokenPtr[1].start; - nameChars = varTokenPtr[1].size; - if (!TclIsLocalScalar(name, nameChars)) { - return TCL_ERROR; - } - dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr); + dictVarIndex = LocalScalarFromToken(varTokenPtr, envPtr); if (dictVarIndex < 0) { return TCL_ERROR; } @@ -884,8 +894,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); } @@ -894,7 +903,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; @@ -911,8 +920,7 @@ TclCompileDictIncrCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *keyTokenPtr; - int dictVarIndex, nameChars, incrAmount; - const char *name; + int dictVarIndex, incrAmount; /* * There must be at least two arguments after the command. @@ -936,7 +944,7 @@ TclCompileDictIncrCmd( incrTokenPtr = TokenAfter(keyTokenPtr); if (incrTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; + return TclCompileBasic2Or3ArgCmd(interp, parsePtr,cmdPtr, envPtr); } word = incrTokenPtr[1].start; numBytes = incrTokenPtr[1].size; @@ -946,7 +954,7 @@ TclCompileDictIncrCmd( code = TclGetIntFromObj(NULL, intObj, &incrAmount); TclDecrRefCount(intObj); if (code != TCL_OK) { - return TCL_ERROR; + return TclCompileBasic2Or3ArgCmd(interp, parsePtr,cmdPtr, envPtr); } } else { incrAmount = 1; @@ -958,24 +966,16 @@ TclCompileDictIncrCmd( * discover what the index is. */ - if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - name = varTokenPtr[1].start; - nameChars = varTokenPtr[1].size; - if (!TclIsLocalScalar(name, nameChars)) { - return TCL_ERROR; - } - dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr); + dictVarIndex = LocalScalarFromToken(varTokenPtr, envPtr); if (dictVarIndex < 0) { - return TCL_ERROR; + return TclCompileBasic2Or3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } /* * Emit the key and the code to actually do the increment. */ - CompileWord(envPtr, keyTokenPtr, interp, 3); + CompileWord(envPtr, keyTokenPtr, interp, 2); TclEmitInstInt4( INST_DICT_INCR_IMM, incrAmount, envPtr); TclEmitInt4( dictVarIndex, envPtr); return TCL_OK; @@ -991,7 +991,7 @@ TclCompileDictGetCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *tokenPtr; - int numWords, i; + int i; DefineLineInformation; /* TIP #280 */ /* @@ -999,21 +999,21 @@ TclCompileDictGetCmd( * case is legal, but too special and magic for us to deal with here). */ + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords < 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - numWords = parsePtr->numWords-1; /* * Only compile this because we need INST_DICT_GET anyway. */ - for (i=0 ; i<numWords ; i++) { + for (i=1 ; i<parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_DICT_GET, numWords-1, envPtr); + TclEmitInstInt4(INST_DICT_GET, parsePtr->numWords-2, envPtr); TclAdjustStackDepth(-1, envPtr); return TCL_OK; } @@ -1028,7 +1028,7 @@ TclCompileDictExistsCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *tokenPtr; - int numWords, i; + int i; DefineLineInformation; /* TIP #280 */ /* @@ -1036,21 +1036,21 @@ TclCompileDictExistsCmd( * case is legal, but too special and magic for us to deal with here). */ + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords < 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - numWords = parsePtr->numWords-1; /* * Now we do the code generation. */ - for (i=0 ; i<numWords ; i++) { + for (i=1 ; i<parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_DICT_EXISTS, numWords-1, envPtr); + TclEmitInstInt4(INST_DICT_EXISTS, parsePtr->numWords-2, envPtr); TclAdjustStackDepth(-1, envPtr); return TCL_OK; } @@ -1066,14 +1066,14 @@ TclCompileDictUnsetCmd( { Tcl_Token *tokenPtr; DefineLineInformation; /* TIP #280 */ - int i, dictVarIndex, nameChars; - const char *name; + int i, dictVarIndex; /* * There must be at least one argument after the variable name for us to * compile to bytecode. */ + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords < 3) { return TCL_ERROR; } @@ -1085,17 +1085,9 @@ TclCompileDictUnsetCmd( */ tokenPtr = TokenAfter(parsePtr->tokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - name = tokenPtr[1].start; - nameChars = tokenPtr[1].size; - if (!TclIsLocalScalar(name, nameChars)) { - return TCL_ERROR; - } - dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr); + dictVarIndex = LocalScalarFromToken(tokenPtr, envPtr); if (dictVarIndex < 0) { - return TCL_ERROR; + return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } /* @@ -1184,12 +1176,12 @@ TclCompileDictCreateCmd( */ nonConstant: - worker = TclFindCompiledLocal(NULL, 0, 1, envPtr); + worker = AnonymousLocal(envPtr); if (worker < 0) { - return TCL_ERROR; + return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr); } - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); Emit14Inst( INST_STORE_SCALAR, worker, envPtr); TclEmitOpcode( INST_POP, envPtr); tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1227,8 +1219,9 @@ TclCompileDictMergeCmd( * argument, the only thing to do is to verify the dict-ness. */ + /* TODO: Consider support for compiling expanded args. (less likely) */ if (parsePtr->numWords < 2) { - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); return TCL_OK; } else if (parsePtr->numWords == 2) { tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1245,11 +1238,11 @@ TclCompileDictMergeCmd( * command when there's an LVT present. */ - workerIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr); + workerIndex = AnonymousLocal(envPtr); if (workerIndex < 0) { - return TCL_ERROR; + return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } - infoIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr); + infoIndex = AnonymousLocal(envPtr); /* * Get the first dictionary and verify that it is so. @@ -1266,7 +1259,7 @@ TclCompileDictMergeCmd( * For each of the remaining dictionaries... */ - outLoop = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); + outLoop = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); TclEmitInstInt4( INST_BEGIN_CATCH4, outLoop, envPtr); ExceptionRangeStarts(envPtr, outLoop); for (i=2 ; i<parsePtr->numWords ; i++) { @@ -1308,6 +1301,7 @@ TclCompileDictMergeCmd( * subsequent) dicts. This is strictly not necessary, but it is nice. */ + TclAdjustStackDepth(-1, envPtr); ExceptionRangeTarget(envPtr, outLoop, catchOffset); TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); TclEmitOpcode( INST_PUSH_RESULT, envPtr); @@ -1366,18 +1360,15 @@ CompileDictEachCmd( int numVars, endTargetOffset; int collectVar = -1; /* Index of temp var holding the result * dict. */ - int savedStackDepth = envPtr->currStackDepth; - /* Needed because jumps confuse the stack - * space calculator. */ const char **argv; Tcl_DString buffer; /* - * There must be at least three argument after the command. + * There must be three arguments after the command. */ if (parsePtr->numWords != 4) { - return TCL_ERROR; + return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } varsTokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1385,7 +1376,7 @@ CompileDictEachCmd( bodyTokenPtr = TokenAfter(dictTokenPtr); if (varsTokenPtr->type != TCL_TOKEN_SIMPLE_WORD || bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; + return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } /* @@ -1394,10 +1385,9 @@ CompileDictEachCmd( */ if (collect == TCL_EACH_COLLECT) { - collectVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1, - envPtr); + collectVar = AnonymousLocal(envPtr); if (collectVar < 0) { - return TCL_ERROR; + return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } } @@ -1411,31 +1401,22 @@ CompileDictEachCmd( if (Tcl_SplitList(NULL, Tcl_DStringValue(&buffer), &numVars, &argv) != TCL_OK) { Tcl_DStringFree(&buffer); - return TCL_ERROR; + return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } Tcl_DStringFree(&buffer); if (numVars != 2) { ckfree(argv); - return TCL_ERROR; + return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } nameChars = strlen(argv[0]); - if (!TclIsLocalScalar(argv[0], nameChars)) { - ckfree(argv); - return TCL_ERROR; - } - keyVarIndex = TclFindCompiledLocal(argv[0], nameChars, 1, envPtr); - + keyVarIndex = LocalScalar(argv[0], nameChars, envPtr); nameChars = strlen(argv[1]); - if (!TclIsLocalScalar(argv[1], nameChars)) { - ckfree(argv); - return TCL_ERROR; - } - valueVarIndex = TclFindCompiledLocal(argv[1], nameChars, 1, envPtr); + valueVarIndex = LocalScalar(argv[1], nameChars, envPtr); ckfree(argv); if ((keyVarIndex < 0) || (valueVarIndex < 0)) { - return TCL_ERROR; + return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } /* @@ -1445,9 +1426,9 @@ CompileDictEachCmd( * (at which point it should also have been finished with). */ - infoIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr); + infoIndex = AnonymousLocal(envPtr); if (infoIndex < 0) { - return TCL_ERROR; + return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } /* @@ -1458,7 +1439,7 @@ CompileDictEachCmd( */ if (collect == TCL_EACH_COLLECT) { - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); Emit14Inst( INST_STORE_SCALAR, collectVar, envPtr); TclEmitOpcode( INST_POP, envPtr); } @@ -1468,20 +1449,21 @@ CompileDictEachCmd( * this point. */ - CompileWord(envPtr, dictTokenPtr, interp, 3); - TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr); - emptyTargetOffset = CurrentOffset(envPtr); - TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr); + CompileWord(envPtr, dictTokenPtr, interp, 2); /* * Now we catch errors from here on so that we can finalize the search * started by Tcl_DictObjFirst above. */ - catchRange = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); + catchRange = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); TclEmitInstInt4( INST_BEGIN_CATCH4, catchRange, envPtr); ExceptionRangeStarts(envPtr, catchRange); + TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr); + emptyTargetOffset = CurrentOffset(envPtr); + TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr); + /* * Inside the iteration, write the loop variables. */ @@ -1496,15 +1478,14 @@ CompileDictEachCmd( * Set up the loop exception targets. */ - loopRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE); + loopRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); ExceptionRangeStarts(envPtr, loopRange); /* * Compile the loop body itself. It should be stack-neutral. */ - SetLineInformation(3); - CompileBody(envPtr, bodyTokenPtr, interp); + BODY(bodyTokenPtr, 3); if (collect == TCL_EACH_COLLECT) { Emit14Inst( INST_LOAD_SCALAR, keyVarIndex, envPtr); TclEmitInstInt4(INST_OVER, 1, envPtr); @@ -1532,35 +1513,21 @@ CompileDictEachCmd( TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr); jumpDisplacement = bodyTargetOffset - CurrentOffset(envPtr); TclEmitInstInt4( INST_JUMP_FALSE4, jumpDisplacement, envPtr); - TclEmitOpcode( INST_POP, envPtr); - TclEmitOpcode( INST_POP, envPtr); - - /* - * Now do the final cleanup for the no-error case (this is where we break - * out of the loop to) by force-terminating the iteration (if not already - * terminated), ditching the exception info and jumping to the last - * instruction for this command. In theory, this could be done using the - * "finally" clause (next generated) but this is faster. - */ - - ExceptionRangeTarget(envPtr, loopRange, breakOffset); - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( infoIndex, envPtr); - TclEmitOpcode( INST_END_CATCH, envPtr); endTargetOffset = CurrentOffset(envPtr); - TclEmitInstInt4( INST_JUMP4, 0, envPtr); + TclEmitInstInt1( INST_JUMP1, 0, envPtr); /* * Error handler "finally" clause, which force-terminates the iteration * and rethrows the error. */ + TclAdjustStackDepth(-1, envPtr); ExceptionRangeTarget(envPtr, catchRange, catchOffset); TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); TclEmitOpcode( INST_PUSH_RESULT, envPtr); + TclEmitOpcode( INST_END_CATCH, envPtr); TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); TclEmitInt4( infoIndex, envPtr); - TclEmitOpcode( INST_END_CATCH, envPtr); if (collect == TCL_EACH_COLLECT) { TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr); TclEmitInt4( collectVar, envPtr); @@ -1573,14 +1540,17 @@ CompileDictEachCmd( * easy!) Note that we skip the END_CATCH. [Bug 1382528] */ - envPtr->currStackDepth = savedStackDepth + 2; jumpDisplacement = CurrentOffset(envPtr) - emptyTargetOffset; TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDisplacement, envPtr->codeStart + emptyTargetOffset); + jumpDisplacement = CurrentOffset(envPtr) - endTargetOffset; + TclUpdateInstInt1AtPc(INST_JUMP1, jumpDisplacement, + envPtr->codeStart + endTargetOffset); TclEmitOpcode( INST_POP, envPtr); TclEmitOpcode( INST_POP, envPtr); - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( infoIndex, envPtr); + ExceptionRangeTarget(envPtr, loopRange, breakOffset); + TclFinalizeLoopExceptionRange(envPtr, loopRange); + TclEmitOpcode( INST_END_CATCH, envPtr); /* * Final stage of the command (normal case) is that we push an empty @@ -1588,15 +1558,14 @@ CompileDictEachCmd( * last to promote peephole optimization when it's dropped immediately. */ - jumpDisplacement = CurrentOffset(envPtr) - endTargetOffset; - TclUpdateInstInt4AtPc(INST_JUMP4, jumpDisplacement, - envPtr->codeStart + endTargetOffset); + TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); + TclEmitInt4( infoIndex, envPtr); if (collect == TCL_EACH_COLLECT) { Emit14Inst( INST_LOAD_SCALAR, collectVar, envPtr); TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr); TclEmitInt4( collectVar, envPtr); } else { - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); } return TCL_OK; } @@ -1611,10 +1580,8 @@ TclCompileDictUpdateCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - const char *name; - int i, nameChars, dictIndex, numVars, range, infoIndex; + int i, dictIndex, numVars, range, infoIndex; Tcl_Token **keyTokenPtrs, *dictVarTokenPtr, *bodyTokenPtr, *tokenPtr; - int savedStackDepth = envPtr->currStackDepth; DictUpdateInfo *duiPtr; JumpFixup jumpFixup; @@ -1643,17 +1610,9 @@ TclCompileDictUpdateCmd( */ dictVarTokenPtr = TokenAfter(parsePtr->tokenPtr); - if (dictVarTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - name = dictVarTokenPtr[1].start; - nameChars = dictVarTokenPtr[1].size; - if (!TclIsLocalScalar(name, nameChars)) { - return TCL_ERROR; - } - dictIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr); + dictIndex = LocalScalarFromToken(dictVarTokenPtr, envPtr); if (dictIndex < 0) { - return TCL_ERROR; + goto issueFallback; } /* @@ -1664,8 +1623,7 @@ TclCompileDictUpdateCmd( duiPtr = ckalloc(sizeof(DictUpdateInfo) + sizeof(int) * (numVars - 1)); duiPtr->length = numVars; - keyTokenPtrs = TclStackAlloc(interp, - sizeof(Tcl_Token *) * numVars); + keyTokenPtrs = TclStackAlloc(interp, sizeof(Tcl_Token *) * numVars); tokenPtr = TokenAfter(dictVarTokenPtr); for (i=0 ; i<numVars ; i++) { @@ -1674,37 +1632,21 @@ TclCompileDictUpdateCmd( */ keyTokenPtrs[i] = tokenPtr; - - /* - * Variables first need to be checked for sanity. - */ - tokenPtr = TokenAfter(tokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - goto failedUpdateInfoAssembly; - } - name = tokenPtr[1].start; - nameChars = tokenPtr[1].size; - if (!TclIsLocalScalar(name, nameChars)) { - goto failedUpdateInfoAssembly; - } /* - * Stash the index in the auxiliary data. + * Stash the index in the auxiliary data (if it is indeed a local + * scalar that is resolvable at compile-time). */ - duiPtr->varIndices[i] = - TclFindCompiledLocal(name, nameChars, 1, envPtr); + duiPtr->varIndices[i] = LocalScalarFromToken(tokenPtr, envPtr); if (duiPtr->varIndices[i] < 0) { goto failedUpdateInfoAssembly; } tokenPtr = TokenAfter(tokenPtr); } if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - failedUpdateInfoAssembly: - ckfree(duiPtr); - TclStackFree(interp, keyTokenPtrs); - return TCL_ERROR; + goto failedUpdateInfoAssembly; } bodyTokenPtr = tokenPtr; @@ -1716,20 +1658,17 @@ TclCompileDictUpdateCmd( infoIndex = TclCreateAuxData(duiPtr, &tclDictUpdateInfoType, envPtr); for (i=0 ; i<numVars ; i++) { - CompileWord(envPtr, keyTokenPtrs[i], interp, i); + CompileWord(envPtr, keyTokenPtrs[i], interp, 2*i+2); } TclEmitInstInt4( INST_LIST, numVars, envPtr); TclEmitInstInt4( INST_DICT_UPDATE_START, dictIndex, envPtr); - TclEmitInt4( infoIndex, envPtr); + TclEmitInt4( infoIndex, envPtr); - range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); - envPtr->currStackDepth++; - SetLineInformation(parsePtr->numWords - 1); - CompileBody(envPtr, bodyTokenPtr, interp); - envPtr->currStackDepth = savedStackDepth; + BODY(bodyTokenPtr, parsePtr->numWords - 1); ExceptionRangeEnds(envPtr, range); /* @@ -1740,7 +1679,7 @@ TclCompileDictUpdateCmd( TclEmitOpcode( INST_END_CATCH, envPtr); TclEmitInstInt4( INST_REVERSE, 2, envPtr); TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr); - TclEmitInt4( infoIndex, envPtr); + TclEmitInt4( infoIndex, envPtr); /* * Jump around the exceptional termination code. @@ -1761,16 +1700,25 @@ TclCompileDictUpdateCmd( TclEmitInstInt4( INST_REVERSE, 3, envPtr); TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr); - TclEmitInt4( infoIndex, envPtr); - TclEmitOpcode( INST_RETURN_STK, envPtr); + TclEmitInt4( infoIndex, envPtr); + TclEmitInvoke(envPtr,INST_RETURN_STK); if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d", (int) (CurrentOffset(envPtr) - jumpFixup.codeOffset)); } TclStackFree(interp, keyTokenPtrs); - envPtr->currStackDepth = savedStackDepth + 1; return TCL_OK; + + /* + * Clean up after a failure to create the DictUpdateInfo structure. + */ + + failedUpdateInfoAssembly: + ckfree(duiPtr); + TclStackFree(interp, keyTokenPtrs); + issueFallback: + return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } int @@ -1792,6 +1740,7 @@ TclCompileDictAppendCmd( * speed quite so much. ;-) */ + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords<4 || parsePtr->numWords>100) { return TCL_ERROR; } @@ -1801,19 +1750,9 @@ TclCompileDictAppendCmd( */ tokenPtr = TokenAfter(parsePtr->tokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } else { - register const char *name = tokenPtr[1].start; - register int nameChars = tokenPtr[1].size; - - if (!TclIsLocalScalar(name, nameChars)) { - return TCL_ERROR; - } - dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr); - if (dictVarIndex < 0) { - return TCL_ERROR; - } + dictVarIndex = LocalScalarFromToken(tokenPtr, envPtr); + if (dictVarIndex < 0) { + return TclCompileBasicMin2ArgCmd(interp, parsePtr,cmdPtr, envPtr); } /* @@ -1826,7 +1765,7 @@ TclCompileDictAppendCmd( tokenPtr = TokenAfter(tokenPtr); } if (parsePtr->numWords > 4) { - TclEmitInstInt1(INST_CONCAT1, parsePtr->numWords-3, envPtr); + TclEmitInstInt1(INST_STR_CONCAT1, parsePtr->numWords-3, envPtr); } /* @@ -1848,34 +1787,36 @@ TclCompileDictLappendCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *keyTokenPtr, *valueTokenPtr; - int dictVarIndex, nameChars; - const char *name; + int dictVarIndex; /* * There must be three arguments after the command. */ + /* TODO: Consider support for compiling expanded args. */ + /* Probably not. Why is INST_DICT_LAPPEND limited to one value? */ if (parsePtr->numWords != 4) { return TCL_ERROR; } + /* + * Parse the arguments. + */ + varTokenPtr = TokenAfter(parsePtr->tokenPtr); keyTokenPtr = TokenAfter(varTokenPtr); valueTokenPtr = TokenAfter(keyTokenPtr); - if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - name = varTokenPtr[1].start; - nameChars = varTokenPtr[1].size; - if (!TclIsLocalScalar(name, nameChars)) { - return TCL_ERROR; - } - dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr); + dictVarIndex = LocalScalarFromToken(varTokenPtr, envPtr); if (dictVarIndex < 0) { - return TCL_ERROR; + return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } - CompileWord(envPtr, keyTokenPtr, interp, 3); - CompileWord(envPtr, valueTokenPtr, interp, 4); + + /* + * Issue the implementation. + */ + + CompileWord(envPtr, keyTokenPtr, interp, 2); + CompileWord(envPtr, valueTokenPtr, interp, 3); TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr); return TCL_OK; } @@ -1890,10 +1831,9 @@ TclCompileDictWithCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - int i, range, varNameTmp, pathTmp, keysTmp, gotPath, dictVar = -1; - int bodyIsEmpty = 1; + int i, range, varNameTmp = -1, pathTmp = -1, keysTmp, gotPath; + int dictVar, bodyIsEmpty = 1; Tcl_Token *varTokenPtr, *tokenPtr; - int savedStackDepth = envPtr->currStackDepth; JumpFixup jumpFixup; const char *ptr, *end; @@ -1901,6 +1841,7 @@ TclCompileDictWithCmd( * There must be at least one argument after the command. */ + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords < 3) { return TCL_ERROR; } @@ -1916,7 +1857,7 @@ TclCompileDictWithCmd( tokenPtr = TokenAfter(tokenPtr); } if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; + return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } /* @@ -1928,7 +1869,8 @@ TclCompileDictWithCmd( for (ptr=tokenPtr[1].start,end=ptr+tokenPtr[1].size ; ptr!=end ; ptr++) { if (*ptr!=' ' && *ptr!='\t' && *ptr!='\n' && *ptr!='\r') { if (envPtr->procPtr == NULL) { - return TCL_ERROR; + return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, + envPtr); } bodyIsEmpty = 0; break; @@ -1940,11 +1882,7 @@ TclCompileDictWithCmd( */ gotPath = (parsePtr->numWords > 3); - if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD && - TclIsLocalScalar(varTokenPtr[1].start, varTokenPtr[1].size)) { - dictVar = TclFindCompiledLocal(varTokenPtr[1].start, - varTokenPtr[1].size, 1, envPtr); - } + dictVar = LocalScalarFromToken(varTokenPtr, envPtr); /* * Special case: an empty body means we definitely have no need to issue @@ -1963,7 +1901,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); @@ -1971,18 +1909,16 @@ TclCompileDictWithCmd( TclEmitInstInt4(INST_OVER, 1, envPtr); TclEmitOpcode( INST_DICT_EXPAND, envPtr); TclEmitInstInt4(INST_DICT_RECOMBINE_IMM, dictVar, envPtr); - PushLiteral(envPtr, "", 0); } else { /* * Case: Direct dict in LVT with empty body. */ - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr); - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); TclEmitOpcode( INST_DICT_EXPAND, envPtr); TclEmitInstInt4(INST_DICT_RECOMBINE_IMM, dictVar, envPtr); - PushLiteral(envPtr, "", 0); } } else { if (gotPath) { @@ -1992,7 +1928,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); @@ -2001,24 +1937,22 @@ TclCompileDictWithCmd( TclEmitInstInt4(INST_OVER, 1, envPtr); TclEmitOpcode( INST_DICT_EXPAND, envPtr); TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr); - PushLiteral(envPtr, "", 0); } else { /* * Case: Direct dict in non-simple var with empty body. */ - CompileWord(envPtr, varTokenPtr, interp, 0); + CompileWord(envPtr, varTokenPtr, interp, 1); TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_LOAD_STK, envPtr); - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); TclEmitOpcode( INST_DICT_EXPAND, envPtr); - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); TclEmitInstInt4(INST_REVERSE, 2, envPtr); TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr); - PushLiteral(envPtr, "", 0); } } - envPtr->currStackDepth = savedStackDepth + 1; + PushStringLiteral(envPtr, ""); return TCL_OK; } @@ -2031,29 +1965,25 @@ TclCompileDictWithCmd( */ if (dictVar == -1) { - varNameTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr); - } else { - varNameTmp = -1; + varNameTmp = AnonymousLocal(envPtr); } if (gotPath) { - pathTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr); - } else { - pathTmp = -1; + pathTmp = AnonymousLocal(envPtr); } - keysTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr); + keysTmp = AnonymousLocal(envPtr); /* * Issue instructions. First, the part to expand the dictionary. */ - if (varNameTmp > -1) { - CompileWord(envPtr, varTokenPtr, interp, 0); + if (dictVar == -1) { + CompileWord(envPtr, varTokenPtr, interp, 1); Emit14Inst( INST_STORE_SCALAR, varNameTmp, envPtr); } tokenPtr = TokenAfter(varTokenPtr); if (gotPath) { for (i=2 ; i<parsePtr->numWords-1 ; i++) { - CompileWord(envPtr, tokenPtr, interp, i-1); + CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt4( INST_LIST, parsePtr->numWords-3,envPtr); @@ -2068,7 +1998,7 @@ TclCompileDictWithCmd( if (gotPath) { Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr); } else { - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); } TclEmitOpcode( INST_DICT_EXPAND, envPtr); Emit14Inst( INST_STORE_SCALAR, keysTmp, envPtr); @@ -2078,14 +2008,11 @@ TclCompileDictWithCmd( * Now the body of the [dict with]. */ - range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); ExceptionRangeStarts(envPtr, range); - envPtr->currStackDepth++; - SetLineInformation(parsePtr->numWords-1); - CompileBody(envPtr, tokenPtr, interp); - envPtr->currStackDepth = savedStackDepth; + BODY(tokenPtr, parsePtr->numWords - 1); ExceptionRangeEnds(envPtr, range); /* @@ -2093,13 +2020,13 @@ TclCompileDictWithCmd( */ TclEmitOpcode( INST_END_CATCH, envPtr); - if (varNameTmp > -1) { + if (dictVar == -1) { Emit14Inst( INST_LOAD_SCALAR, varNameTmp, envPtr); } if (gotPath) { Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr); } else { - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); } Emit14Inst( INST_LOAD_SCALAR, keysTmp, envPtr); if (dictVar == -1) { @@ -2113,17 +2040,18 @@ TclCompileDictWithCmd( * Now fold the results back into the dictionary in the exception case. */ + TclAdjustStackDepth(-1, envPtr); ExceptionRangeTarget(envPtr, range, catchOffset); TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); TclEmitOpcode( INST_PUSH_RESULT, envPtr); TclEmitOpcode( INST_END_CATCH, envPtr); - if (varNameTmp > -1) { + if (dictVar == -1) { Emit14Inst( INST_LOAD_SCALAR, varNameTmp, envPtr); } if (parsePtr->numWords > 3) { Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr); } else { - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); } Emit14Inst( INST_LOAD_SCALAR, keysTmp, envPtr); if (dictVar == -1) { @@ -2131,13 +2059,12 @@ TclCompileDictWithCmd( } else { TclEmitInstInt4( INST_DICT_RECOMBINE_IMM, dictVar, envPtr); } - TclEmitOpcode( INST_RETURN_STK, envPtr); + TclEmitInvoke(envPtr, INST_RETURN_STK); /* * Prepare for the start of the next command. */ - envPtr->currStackDepth = savedStackDepth + 1; if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d", (int) (CurrentOffset(envPtr) - jumpFixup.codeOffset)); @@ -2234,21 +2161,48 @@ TclCompileErrorCmd( { /* * General syntax: [error message ?errorInfo? ?errorCode?] - * However, we only deal with the case where there is just a message. */ - Tcl_Token *messageTokenPtr; - int savedStackDepth = envPtr->currStackDepth; + + Tcl_Token *tokenPtr; DefineLineInformation; /* TIP #280 */ - if (parsePtr->numWords != 2) { + if (parsePtr->numWords < 2 || parsePtr->numWords > 4) { return TCL_ERROR; } - messageTokenPtr = TokenAfter(parsePtr->tokenPtr); - PushLiteral(envPtr, "-code error -level 0", 20); - CompileWord(envPtr, messageTokenPtr, interp, 1); - TclEmitOpcode(INST_RETURN_STK, envPtr); - envPtr->currStackDepth = savedStackDepth + 1; + /* + * Handle the message. + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + + /* + * Construct the options. Note that -code and -level are not here. + */ + + if (parsePtr->numWords == 2) { + PushStringLiteral(envPtr, ""); + } else { + PushStringLiteral(envPtr, "-errorinfo"); + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 2); + if (parsePtr->numWords == 3) { + TclEmitInstInt4( INST_LIST, 2, envPtr); + } else { + PushStringLiteral(envPtr, "-errorcode"); + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 3); + TclEmitInstInt4( INST_LIST, 4, envPtr); + } + } + + /* + * Issue the error via 'returnImm error 0'. + */ + + TclEmitInstInt4( INST_RETURN_IMM, TCL_ERROR, envPtr); + TclEmitInt4( 0, envPtr); return TCL_OK; } @@ -2326,9 +2280,8 @@ TclCompileForCmd( { Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr; JumpFixup jumpEvalCondFixup; - int testCodeOffset, bodyCodeOffset, nextCodeOffset, jumpDist; + int bodyCodeOffset, nextCodeOffset, jumpDist; int bodyRange, nextRange; - int savedStackDepth = envPtr->currStackDepth; DefineLineInformation; /* TIP #280 */ if (parsePtr->numWords != 5) { @@ -2360,20 +2313,10 @@ TclCompileForCmd( } /* - * Create ExceptionRange records for the body and the "next" command. The - * "next" command's ExceptionRange supports break but not continue (and - * has a -1 continueOffset). - */ - - bodyRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE); - nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); - - /* * Inline compile the initial command. */ - SetLineInformation(1); - CompileBody(envPtr, startTokenPtr, interp); + BODY(startTokenPtr, 1); TclEmitOpcode(INST_POP, envPtr); /* @@ -2394,44 +2337,38 @@ TclCompileForCmd( * Compile the loop body. */ + bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); bodyCodeOffset = ExceptionRangeStarts(envPtr, bodyRange); - SetLineInformation(4); - CompileBody(envPtr, bodyTokenPtr, interp); + BODY(bodyTokenPtr, 4); ExceptionRangeEnds(envPtr, bodyRange); - envPtr->currStackDepth = savedStackDepth + 1; TclEmitOpcode(INST_POP, envPtr); /* - * Compile the "next" subcommand. + * Compile the "next" subcommand. Note that this exception range will not + * have a continueOffset (other than -1) connected to it; it won't trap + * TCL_CONTINUE but rather just TCL_BREAK. */ - envPtr->currStackDepth = savedStackDepth; + nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + envPtr->exceptAuxArrayPtr[nextRange].supportsContinue = 0; nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange); - SetLineInformation(3); - CompileBody(envPtr, nextTokenPtr, interp); + BODY(nextTokenPtr, 3); ExceptionRangeEnds(envPtr, nextRange); - envPtr->currStackDepth = savedStackDepth + 1; TclEmitOpcode(INST_POP, envPtr); - envPtr->currStackDepth = savedStackDepth; /* * Compile the test expression then emit the conditional jump that * terminates the for. */ - testCodeOffset = CurrentOffset(envPtr); - - jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset; - if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) { + if (TclFixupForwardJumpToHere(envPtr, &jumpEvalCondFixup, 127)) { bodyCodeOffset += 3; nextCodeOffset += 3; - testCodeOffset += 3; } SetLineInformation(2); - envPtr->currStackDepth = savedStackDepth; TclCompileExprWords(interp, testTokenPtr, 1, envPtr); - envPtr->currStackDepth = savedStackDepth + 1; + TclClearNumConversion(envPtr); jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; if (jumpDist > 127) { @@ -2452,13 +2389,14 @@ TclCompileForCmd( ExceptionRangeTarget(envPtr, bodyRange, breakOffset); ExceptionRangeTarget(envPtr, nextRange, breakOffset); + TclFinalizeLoopExceptionRange(envPtr, bodyRange); + TclFinalizeLoopExceptionRange(envPtr, nextRange); /* * The for command's result is an empty string. */ - envPtr->currStackDepth = savedStackDepth; - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); return TCL_OK; } @@ -2497,6 +2435,37 @@ TclCompileForeachCmd( /* *---------------------------------------------------------------------- * + * TclCompileLmapCmd -- + * + * Procedure called to compile the "lmap" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "lmap" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLmapCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + return CompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr, + TCL_EACH_COLLECT); +} + +/* + *---------------------------------------------------------------------- + * * CompileEachloopCmd -- * * Procedure called to compile the "foreach" and "lmap" commands. @@ -2527,19 +2496,10 @@ CompileEachloopCmd( ForeachInfo *infoPtr; /* Points to the structure describing this * foreach command. Stored in a AuxData * record in the ByteCode. */ - int firstValueTemp; /* Index of the first temp var in the frame - * used to point to a value list. */ - int loopCtTemp; /* Index of temp var holding the loop's - * iteration count. */ - int collectVar = -1; /* Index of temp var holding the result var - * index. */ - + Tcl_Token *tokenPtr, *bodyTokenPtr; - unsigned char *jumpPc; - JumpFixup jumpFalseFixup; - int jumpBackDist, jumpBackOffset, infoIndex, range, bodyIndex; - int numWords, numLists, numVars, loopIndex, tempVar, i, j, code; - int savedStackDepth = envPtr->currStackDepth; + int jumpBackOffset, infoIndex, range; + int numWords, numLists, numVars, loopIndex, i, j, code; DefineLineInformation; /* TIP #280 */ /* @@ -2578,8 +2538,6 @@ CompileEachloopCmd( return TCL_ERROR; } - bodyIndex = i-1; - /* * Allocate storage for the varcList and varvList arrays if necessary. */ @@ -2618,7 +2576,7 @@ CompileEachloopCmd( Tcl_DStringInit(&varList); TclDStringAppendToken(&varList, &tokenPtr[1]); - code = Tcl_SplitList(interp, Tcl_DStringValue(&varList), + code = Tcl_SplitList(NULL, Tcl_DStringValue(&varList), &varcList[loopIndex], &varvList[loopIndex]); Tcl_DStringFree(&varList); if (code != TCL_OK) { @@ -2649,35 +2607,11 @@ CompileEachloopCmd( loopIndex++; } - if (collect == TCL_EACH_COLLECT) { - collectVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1, - envPtr); - if (collectVar < 0) { - return TCL_ERROR; - } - } - /* - * We will compile the foreach command. Reserve (numLists + 1) temporary - * variables: - * - numLists temps to hold each value list - * - 1 temp for the loop counter (index of next element in each list) - * - * At this time we don't try to reuse temporaries; if there are two - * nonoverlapping foreach loops, they don't share any temps. + * We will compile the foreach command. */ code = TCL_OK; - firstValueTemp = -1; - for (loopIndex = 0; loopIndex < numLists; loopIndex++) { - tempVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0, - /*create*/ 1, envPtr); - if (loopIndex == 0) { - firstValueTemp = tempVar; - } - } - loopCtTemp = TclFindCompiledLocal(NULL, /*nameChars*/ 0, - /*create*/ 1, envPtr); /* * Create and initialize the ForeachInfo and ForeachVarList data @@ -2686,16 +2620,14 @@ CompileEachloopCmd( */ infoPtr = ckalloc(sizeof(ForeachInfo) - + numLists * sizeof(ForeachVarList *)); + + (numLists - 1) * sizeof(ForeachVarList *)); infoPtr->numLists = numLists; - infoPtr->firstValueTemp = firstValueTemp; - infoPtr->loopCtTemp = loopCtTemp; for (loopIndex = 0; loopIndex < numLists; loopIndex++) { ForeachVarList *varListPtr; numVars = varcList[loopIndex]; varListPtr = ckalloc(sizeof(ForeachVarList) - + numVars * sizeof(int)); + + (numVars - 1) * sizeof(int)); varListPtr->numVars = numVars; for (j = 0; j < numVars; j++) { const char *varName = varvList[loopIndex][j]; @@ -2706,135 +2638,77 @@ CompileEachloopCmd( } infoPtr->varLists[loopIndex] = varListPtr; } - infoIndex = TclCreateAuxData(infoPtr, &tclForeachInfoType, envPtr); + infoIndex = TclCreateAuxData(infoPtr, &tclNewForeachInfoType, envPtr); /* - * Create an exception record to handle [break] and [continue]. + * Create the collecting object, unshared. */ - - range = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE); - + + if (collect == TCL_EACH_COLLECT) { + TclEmitInstInt4(INST_LIST, 0, envPtr); + } + /* - * Evaluate then store each value list in the associated temporary. + * Evaluate each value list and leave it on stack. */ - loopIndex = 0; for (i = 0, tokenPtr = parsePtr->tokenPtr; i < numWords-1; i++, tokenPtr = TokenAfter(tokenPtr)) { if ((i%2 == 0) && (i > 0)) { - SetLineInformation(i); - CompileTokens(envPtr, tokenPtr, interp); - tempVar = (firstValueTemp + loopIndex); - Emit14Inst( INST_STORE_SCALAR, tempVar, envPtr); - TclEmitOpcode( INST_POP, envPtr); - loopIndex++; + CompileWord(envPtr, tokenPtr, interp, i); } } - /* - * Create temporary variable to capture return values from loop body. - */ - - if (collect == TCL_EACH_COLLECT) { - PushLiteral(envPtr, "", 0); - Emit14Inst( INST_STORE_SCALAR, collectVar, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - - /* - * Initialize the temporary var that holds the count of loop iterations. - */ - - TclEmitInstInt4( INST_FOREACH_START4, infoIndex, envPtr); - - /* - * Top of loop code: assign each loop variable and check whether - * to terminate the loop. - */ - - ExceptionRangeTarget(envPtr, range, continueOffset); - TclEmitInstInt4( INST_FOREACH_STEP4, infoIndex, envPtr); - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup); - + TclEmitInstInt4(INST_FOREACH_START, infoIndex, envPtr); + /* * Inline compile the loop body. */ - SetLineInformation(bodyIndex); + range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + ExceptionRangeStarts(envPtr, range); - CompileBody(envPtr, bodyTokenPtr, interp); + BODY(bodyTokenPtr, numWords - 1); ExceptionRangeEnds(envPtr, range); - envPtr->currStackDepth = savedStackDepth + 1; - + if (collect == TCL_EACH_COLLECT) { - Emit14Inst( INST_LAPPEND_SCALAR, collectVar,envPtr); - } - TclEmitOpcode( INST_POP, envPtr); - - /* - * Jump back to the test at the top of the loop. Generate a 4 byte jump if - * the distance to the test is > 120 bytes. This is conservative and - * ensures that we won't have to replace this jump if we later need to - * replace the ifFalse jump with a 4 byte jump. - */ - - jumpBackOffset = CurrentOffset(envPtr); - jumpBackDist = jumpBackOffset-envPtr->exceptArrayPtr[range].continueOffset; - if (jumpBackDist > 120) { - TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr); + TclEmitOpcode(INST_LMAP_COLLECT, envPtr); } else { - TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr); + TclEmitOpcode( INST_POP, envPtr); } /* - * Fix the target of the jump after the foreach_step test. + * Bottom of loop code: assign each loop variable and check whether + * to terminate the loop. Set the loop's break target. */ - if (TclFixupForwardJumpToHere(envPtr, &jumpFalseFixup, 127)) { - /* - * Update the loop body's starting PC offset since it moved down. - */ - - envPtr->exceptArrayPtr[range].codeOffset += 3; - - /* - * Update the jump back to the test at the top of the loop since it - * also moved down 3 bytes. - */ - - jumpBackOffset += 3; - jumpPc = (envPtr->codeStart + jumpBackOffset); - jumpBackDist += 3; - if (jumpBackDist > 120) { - TclUpdateInstInt4AtPc(INST_JUMP4, -jumpBackDist, jumpPc); - } else { - TclUpdateInstInt1AtPc(INST_JUMP1, -jumpBackDist, jumpPc); - } - } + ExceptionRangeTarget(envPtr, range, continueOffset); + TclEmitOpcode(INST_FOREACH_STEP, envPtr); + ExceptionRangeTarget(envPtr, range, breakOffset); + TclFinalizeLoopExceptionRange(envPtr, range); + TclEmitOpcode(INST_FOREACH_END, envPtr); + TclAdjustStackDepth(-(numLists+2), envPtr); /* - * Set the loop's break target. + * Set the jumpback distance from INST_FOREACH_STEP to the start of the + * body's code. Misuse loopCtTemp for storing the jump size. */ - - ExceptionRangeTarget(envPtr, range, breakOffset); + + jumpBackOffset = envPtr->exceptArrayPtr[range].continueOffset - + envPtr->exceptArrayPtr[range].codeOffset; + infoPtr->loopCtTemp = -jumpBackOffset; /* - * The command's result is an empty string if not collecting, or the - * list of results from evaluating the loop body. + * The command's result is an empty string if not collecting. If + * collecting, it is automatically left on stack after FOREACH_END. */ - envPtr->currStackDepth = savedStackDepth; - if (collect == TCL_EACH_COLLECT) { - Emit14Inst( INST_LOAD_SCALAR, collectVar, envPtr); - TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( collectVar, envPtr); - } else { - PushLiteral(envPtr, "", 0); + if (collect != TCL_EACH_COLLECT) { + PushStringLiteral(envPtr, ""); } - envPtr->currStackDepth = savedStackDepth + 1; - - done: + + done: for (loopIndex = 0; loopIndex < numLists; loopIndex++) { if (varvList[loopIndex] != NULL) { ckfree(varvList[loopIndex]); @@ -2988,6 +2862,36 @@ PrintForeachInfo( Tcl_AppendToObj(appendObj, "]", -1); } } + +static void +PrintNewForeachInfo( + ClientData clientData, + Tcl_Obj *appendObj, + ByteCode *codePtr, + unsigned int pcOffset) +{ + register ForeachInfo *infoPtr = clientData; + register ForeachVarList *varsPtr; + int i, j; + + Tcl_AppendPrintfToObj(appendObj, "jumpOffset=%+d, vars=", + infoPtr->loopCtTemp); + for (i=0 ; i<infoPtr->numLists ; i++) { + if (i) { + Tcl_AppendToObj(appendObj, ",", -1); + } + Tcl_AppendToObj(appendObj, "[", -1); + varsPtr = infoPtr->varLists[i]; + for (j=0 ; j<varsPtr->numVars ; j++) { + if (j) { + Tcl_AppendToObj(appendObj, ",", -1); + } + Tcl_AppendPrintfToObj(appendObj, "%%v%u", + (unsigned) varsPtr->varIndexes[j]); + } + Tcl_AppendToObj(appendObj, "]", -1); + } +} /* *---------------------------------------------------------------------- @@ -3067,7 +2971,8 @@ TclCompileFormatCmd( ckfree(objv); Tcl_DecrRefCount(formatObj); if (tmpObj == NULL) { - return TCL_ERROR; + TclCompileSyntaxError(interp, envPtr); + return TCL_OK; } /* @@ -3193,7 +3098,7 @@ TclCompileFormatCmd( * Do the concatenation, which produces the result. */ - TclEmitInstInt1(INST_CONCAT1, i, envPtr); + TclEmitInstInt1(INST_STR_CONCAT1, i, envPtr); } else { /* * EVIL HACK! Force there to be a string representation in the case @@ -3202,7 +3107,7 @@ TclCompileFormatCmd( */ TclEmitOpcode(INST_DUP, envPtr); - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); TclEmitOpcode(INST_STR_EQ, envPtr); TclEmitOpcode(INST_POP, envPtr); } @@ -3212,2815 +3117,40 @@ TclCompileFormatCmd( /* *---------------------------------------------------------------------- * - * TclCompileGlobalCmd -- - * - * Procedure called to compile the "global" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "global" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileGlobalCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *varTokenPtr; - int localIndex, numWords, i; - DefineLineInformation; /* TIP #280 */ - - numWords = parsePtr->numWords; - if (numWords < 2) { - return TCL_ERROR; - } - - /* - * 'global' has no effect outside of proc bodies; handle that at runtime - */ - - if (envPtr->procPtr == NULL) { - return TCL_ERROR; - } - - /* - * Push the namespace - */ - - PushLiteral(envPtr, "::", 2); - - /* - * Loop over the variables. - */ - - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - for (i=2; i<=numWords; varTokenPtr = TokenAfter(varTokenPtr),i++) { - localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr); - - if (localIndex < 0) { - return TCL_ERROR; - } - - CompileWord(envPtr, varTokenPtr, interp, 1); - TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr); - } - - /* - * Pop the namespace, and set the result to empty - */ - - TclEmitOpcode( INST_POP, envPtr); - PushLiteral(envPtr, "", 0); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileIfCmd -- - * - * Procedure called to compile the "if" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "if" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileIfCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - JumpFixupArray jumpFalseFixupArray; - /* Used to fix the ifFalse jump after each - * test when its target PC is determined. */ - JumpFixupArray jumpEndFixupArray; - /* Used to fix the jump after each "then" body - * to the end of the "if" when that PC is - * determined. */ - Tcl_Token *tokenPtr, *testTokenPtr; - int jumpIndex = 0; /* Avoid compiler warning. */ - int jumpFalseDist, numWords, wordIdx, numBytes, j, code; - const char *word; - int savedStackDepth = envPtr->currStackDepth; - /* Saved stack depth at the start of the first - * test; the envPtr current depth is restored - * to this value at the start of each test. */ - int realCond = 1; /* Set to 0 for static conditions: - * "if 0 {..}" */ - int boolVal; /* Value of static condition. */ - int compileScripts = 1; - DefineLineInformation; /* TIP #280 */ - - /* - * Only compile the "if" command if all arguments are simple words, in - * order to insure correct substitution [Bug 219166] - */ - - tokenPtr = parsePtr->tokenPtr; - wordIdx = 0; - numWords = parsePtr->numWords; - - for (wordIdx = 0; wordIdx < numWords; wordIdx++) { - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(tokenPtr); - } - - TclInitJumpFixupArray(&jumpFalseFixupArray); - TclInitJumpFixupArray(&jumpEndFixupArray); - code = TCL_OK; - - /* - * Each iteration of this loop compiles one "if expr ?then? body" or - * "elseif expr ?then? body" clause. - */ - - tokenPtr = parsePtr->tokenPtr; - wordIdx = 0; - while (wordIdx < numWords) { - /* - * Stop looping if the token isn't "if" or "elseif". - */ - - word = tokenPtr[1].start; - numBytes = tokenPtr[1].size; - if ((tokenPtr == parsePtr->tokenPtr) - || ((numBytes == 6) && (strncmp(word, "elseif", 6) == 0))) { - tokenPtr = TokenAfter(tokenPtr); - wordIdx++; - } else { - break; - } - if (wordIdx >= numWords) { - code = TCL_ERROR; - goto done; - } - - /* - * Compile the test expression then emit the conditional jump around - * the "then" part. - */ - - envPtr->currStackDepth = savedStackDepth; - testTokenPtr = tokenPtr; - - if (realCond) { - /* - * Find out if the condition is a constant. - */ - - Tcl_Obj *boolObj = Tcl_NewStringObj(testTokenPtr[1].start, - testTokenPtr[1].size); - - Tcl_IncrRefCount(boolObj); - code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal); - TclDecrRefCount(boolObj); - if (code == TCL_OK) { - /* - * A static condition. - */ - - realCond = 0; - if (!boolVal) { - compileScripts = 0; - } - } else { - SetLineInformation(wordIdx); - Tcl_ResetResult(interp); - TclCompileExprWords(interp, testTokenPtr, 1, envPtr); - if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { - TclExpandJumpFixupArray(&jumpFalseFixupArray); - } - jumpIndex = jumpFalseFixupArray.next; - jumpFalseFixupArray.next++; - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, - jumpFalseFixupArray.fixup+jumpIndex); - } - code = TCL_OK; - } - - /* - * Skip over the optional "then" before the then clause. - */ - - tokenPtr = TokenAfter(testTokenPtr); - wordIdx++; - if (wordIdx >= numWords) { - code = TCL_ERROR; - goto done; - } - if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - word = tokenPtr[1].start; - numBytes = tokenPtr[1].size; - if ((numBytes == 4) && (strncmp(word, "then", 4) == 0)) { - tokenPtr = TokenAfter(tokenPtr); - wordIdx++; - if (wordIdx >= numWords) { - code = TCL_ERROR; - goto done; - } - } - } - - /* - * Compile the "then" command body. - */ - - if (compileScripts) { - SetLineInformation(wordIdx); - envPtr->currStackDepth = savedStackDepth; - CompileBody(envPtr, tokenPtr, interp); - } - - if (realCond) { - /* - * Jump to the end of the "if" command. Both jumpFalseFixupArray - * and jumpEndFixupArray are indexed by "jumpIndex". - */ - - if (jumpEndFixupArray.next >= jumpEndFixupArray.end) { - TclExpandJumpFixupArray(&jumpEndFixupArray); - } - jumpEndFixupArray.next++; - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - jumpEndFixupArray.fixup+jumpIndex); - - /* - * Fix the target of the jumpFalse after the test. Generate a 4 - * byte jump if the distance is > 120 bytes. This is conservative, - * and ensures that we won't have to replace this jump if we later - * also need to replace the proceeding jump to the end of the "if" - * with a 4 byte jump. - */ - - if (TclFixupForwardJumpToHere(envPtr, - jumpFalseFixupArray.fixup+jumpIndex, 120)) { - /* - * Adjust the code offset for the proceeding jump to the end - * of the "if" command. - */ - - jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3; - } - } else if (boolVal) { - /* - * We were processing an "if 1 {...}"; stop compiling scripts. - */ - - compileScripts = 0; - } else { - /* - * We were processing an "if 0 {...}"; reset so that the rest - * (elseif, else) is compiled correctly. - */ - - realCond = 1; - compileScripts = 1; - } - - tokenPtr = TokenAfter(tokenPtr); - wordIdx++; - } - - /* - * Restore the current stack depth in the environment; the "else" clause - * (or its default) will add 1 to this. - */ - - envPtr->currStackDepth = savedStackDepth; - - /* - * Check for the optional else clause. Do not compile anything if this was - * an "if 1 {...}" case. - */ - - if ((wordIdx < numWords) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) { - /* - * There is an else clause. Skip over the optional "else" word. - */ - - word = tokenPtr[1].start; - numBytes = tokenPtr[1].size; - if ((numBytes == 4) && (strncmp(word, "else", 4) == 0)) { - tokenPtr = TokenAfter(tokenPtr); - wordIdx++; - if (wordIdx >= numWords) { - code = TCL_ERROR; - goto done; - } - } - - if (compileScripts) { - /* - * Compile the else command body. - */ - - SetLineInformation(wordIdx); - CompileBody(envPtr, tokenPtr, interp); - } - - /* - * Make sure there are no words after the else clause. - */ - - wordIdx++; - if (wordIdx < numWords) { - code = TCL_ERROR; - goto done; - } - } else { - /* - * No else clause: the "if" command's result is an empty string. - */ - - if (compileScripts) { - PushLiteral(envPtr, "", 0); - } - } - - /* - * Fix the unconditional jumps to the end of the "if" command. - */ - - for (j = jumpEndFixupArray.next; j > 0; j--) { - jumpIndex = (j - 1); /* i.e. process the closest jump first. */ - if (TclFixupForwardJumpToHere(envPtr, - jumpEndFixupArray.fixup+jumpIndex, 127)) { - /* - * Adjust the immediately preceeding "ifFalse" jump. We moved it's - * target (just after this jump) down three bytes. - */ - - unsigned char *ifFalsePc = envPtr->codeStart - + jumpFalseFixupArray.fixup[jumpIndex].codeOffset; - unsigned char opCode = *ifFalsePc; - - if (opCode == INST_JUMP_FALSE1) { - jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1); - jumpFalseDist += 3; - TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1)); - } else if (opCode == INST_JUMP_FALSE4) { - jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1); - jumpFalseDist += 3; - TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1)); - } else { - Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", (int) opCode); - } - } - } - - /* - * Free the jumpFixupArray array if malloc'ed storage was used. - */ - - done: - envPtr->currStackDepth = savedStackDepth + 1; - TclFreeJumpFixupArray(&jumpFalseFixupArray); - TclFreeJumpFixupArray(&jumpEndFixupArray); - return code; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileIncrCmd -- - * - * Procedure called to compile the "incr" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "incr" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileIncrCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *varTokenPtr, *incrTokenPtr; - int simpleVarName, isScalar, localIndex, haveImmValue, immValue; - DefineLineInformation; /* TIP #280 */ - - if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) { - return TCL_ERROR; - } - - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - - PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_LARGE_INDEX, - &localIndex, &simpleVarName, &isScalar, 1); - - /* - * If an increment is given, push it, but see first if it's a small - * integer. - */ - - haveImmValue = 0; - immValue = 1; - if (parsePtr->numWords == 3) { - incrTokenPtr = TokenAfter(varTokenPtr); - if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - const char *word = incrTokenPtr[1].start; - int numBytes = incrTokenPtr[1].size; - int code; - Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes); - - Tcl_IncrRefCount(intObj); - code = TclGetIntFromObj(NULL, intObj, &immValue); - TclDecrRefCount(intObj); - if ((code == TCL_OK) && (-127 <= immValue) && (immValue <= 127)) { - haveImmValue = 1; - } - if (!haveImmValue) { - PushLiteral(envPtr, word, numBytes); - } - } else { - SetLineInformation(2); - CompileTokens(envPtr, incrTokenPtr, interp); - } - } else { /* No incr amount given so use 1. */ - haveImmValue = 1; - } - - /* - * Emit the instruction to increment the variable. - */ - - if (!simpleVarName) { - if (haveImmValue) { - TclEmitInstInt1( INST_INCR_STK_IMM, immValue, envPtr); - } else { - TclEmitOpcode( INST_INCR_STK, envPtr); - } - } else if (isScalar) { /* Simple scalar variable. */ - if (localIndex >= 0) { - if (haveImmValue) { - TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, envPtr); - TclEmitInt1(immValue, envPtr); - } else { - TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr); - } - } else { - if (haveImmValue) { - TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immValue, envPtr); - } else { - TclEmitOpcode( INST_INCR_SCALAR_STK, envPtr); - } - } - } else { /* Simple array variable. */ - if (localIndex >= 0) { - if (haveImmValue) { - TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex, envPtr); - TclEmitInt1(immValue, envPtr); - } else { - TclEmitInstInt1(INST_INCR_ARRAY1, localIndex, envPtr); - } - } else { - if (haveImmValue) { - TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue, envPtr); - } else { - TclEmitOpcode( INST_INCR_ARRAY_STK, envPtr); - } - } - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileInfo*Cmd -- - * - * Procedures called to compile "info" subcommands. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "info" subcommand at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileInfoCommandsCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr; - Tcl_Obj *objPtr; - char *bytes; - - /* - * We require one compile-time known argument for the case we can compile. - */ - - if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(parsePtr->tokenPtr); - objPtr = Tcl_NewObj(); - Tcl_IncrRefCount(objPtr); - if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) { - goto notCompilable; - } - bytes = Tcl_GetString(objPtr); - - /* - * We require that the argument start with "::" and not have any of "*\[?" - * in it. (Theoretically, we should look in only the final component, but - * the difference is so slight given current naming practices.) - */ - - if (bytes[0] != ':' || bytes[1] != ':' || !TclMatchIsTrivial(bytes)) { - goto notCompilable; - } - Tcl_DecrRefCount(objPtr); - - /* - * Confirmed as a literal that will not frighten the horses. Compile. Note - * that the result needs to be list-ified. - */ - - CompileWord(envPtr, tokenPtr, interp, 1); - TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr); - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_STR_LEN, envPtr); - TclEmitInstInt1( INST_JUMP_FALSE1, 7, envPtr); - TclEmitInstInt4( INST_LIST, 1, envPtr); - return TCL_OK; - - notCompilable: - Tcl_DecrRefCount(objPtr); - return TCL_ERROR; -} - -int -TclCompileInfoCoroutineCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - /* - * Only compile [info coroutine] without arguments. - */ - - if (parsePtr->numWords != 1) { - return TCL_ERROR; - } - - /* - * Not much to do; we compile to a single instruction... - */ - - TclEmitOpcode( INST_COROUTINE_NAME, envPtr); - return TCL_OK; -} - -int -TclCompileInfoExistsCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr; - int isScalar, simpleVarName, localIndex; - DefineLineInformation; /* TIP #280 */ - - if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - - /* - * Decide if we can use a frame slot for the var/array name or if we need - * to emit code to compute and push the name at runtime. We use a frame - * slot (entry in the array of local vars) if we are compiling a procedure - * body and if the name is simple text that does not include namespace - * qualifiers. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex, - &simpleVarName, &isScalar, 1); - - /* - * Emit instruction to check the variable for existence. - */ - - if (!simpleVarName) { - TclEmitOpcode( INST_EXIST_STK, envPtr); - } else if (isScalar) { - if (localIndex < 0) { - TclEmitOpcode( INST_EXIST_STK, envPtr); - } else { - TclEmitInstInt4( INST_EXIST_SCALAR, localIndex, envPtr); - } - } else { - if (localIndex < 0) { - TclEmitOpcode( INST_EXIST_ARRAY_STK, envPtr); - } else { - TclEmitInstInt4( INST_EXIST_ARRAY, localIndex, envPtr); - } - } - - return TCL_OK; -} - -int -TclCompileInfoLevelCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - /* - * Only compile [info level] without arguments or with a single argument. - */ - - if (parsePtr->numWords == 1) { - /* - * Not much to do; we compile to a single instruction... - */ - - TclEmitOpcode( INST_INFO_LEVEL_NUM, envPtr); - } else if (parsePtr->numWords != 2) { - return TCL_ERROR; - } else { - DefineLineInformation; /* TIP #280 */ - - /* - * Compile the argument, then add the instruction to convert it into a - * list of arguments. - */ - - SetLineInformation(1); - CompileTokens(envPtr, TokenAfter(parsePtr->tokenPtr), interp); - TclEmitOpcode( INST_INFO_LEVEL_ARGS, envPtr); - } - return TCL_OK; -} - -int -TclCompileInfoObjectClassCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - - if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - CompileWord(envPtr, tokenPtr, interp, 1); - TclEmitOpcode( INST_TCLOO_CLASS, envPtr); - return TCL_OK; -} - -int -TclCompileInfoObjectIsACmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - - /* - * We only handle [info object isa object <somevalue>]. The first three - * words are compressed to a single token by the ensemble compilation - * engine. - */ - - if (parsePtr->numWords != 3) { - return TCL_ERROR; - } - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size < 1 - || strncmp(tokenPtr[1].start, "object", tokenPtr[1].size)) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(tokenPtr); - - /* - * Issue the code. - */ - - CompileWord(envPtr, tokenPtr, interp, 2); - TclEmitOpcode( INST_TCLOO_IS_OBJECT, envPtr); - return TCL_OK; -} - -int -TclCompileInfoObjectNamespaceCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) -{ - DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - - if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - CompileWord(envPtr, tokenPtr, interp, 1); - TclEmitOpcode( INST_TCLOO_NS, envPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileLappendCmd -- - * - * Procedure called to compile the "lappend" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "lappend" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileLappendCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *varTokenPtr; - int simpleVarName, isScalar, localIndex, numWords; - DefineLineInformation; /* TIP #280 */ - - /* - * If we're not in a procedure, don't compile. - */ - - if (envPtr->procPtr == NULL) { - return TCL_ERROR; - } - - numWords = parsePtr->numWords; - if (numWords == 1) { - return TCL_ERROR; - } - if (numWords != 3) { - /* - * LAPPEND instructions currently only handle one value appends. - */ - - return TCL_ERROR; - } - - /* - * Decide if we can use a frame slot for the var/array name or if we - * need to emit code to compute and push the name at runtime. We use a - * frame slot (entry in the array of local vars) if we are compiling a - * procedure body and if the name is simple text that does not include - * namespace qualifiers. - */ - - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - - PushVarNameWord(interp, varTokenPtr, envPtr, 0, - &localIndex, &simpleVarName, &isScalar, 1); - - /* - * If we are doing an assignment, push the new value. In the no values - * case, create an empty object. - */ - - if (numWords > 2) { - Tcl_Token *valueTokenPtr = TokenAfter(varTokenPtr); - - CompileWord(envPtr, valueTokenPtr, interp, 2); - } - - /* - * Emit instructions to set/get the variable. - */ - - /* - * The *_STK opcodes should be refactored to make better use of existing - * LOAD/STORE instructions. - */ - - if (!simpleVarName) { - TclEmitOpcode( INST_LAPPEND_STK, envPtr); - } else if (isScalar) { - if (localIndex < 0) { - TclEmitOpcode( INST_LAPPEND_STK, envPtr); - } else { - Emit14Inst( INST_LAPPEND_SCALAR, localIndex, envPtr); - } - } else { - if (localIndex < 0) { - TclEmitOpcode( INST_LAPPEND_ARRAY_STK, envPtr); - } else { - Emit14Inst( INST_LAPPEND_ARRAY, localIndex, envPtr); - } - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileLassignCmd -- - * - * Procedure called to compile the "lassign" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "lassign" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileLassignCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr; - int simpleVarName, isScalar, localIndex, numWords, idx; - DefineLineInformation; /* TIP #280 */ - - numWords = parsePtr->numWords; - - /* - * Check for command syntax error, but we'll punt that to runtime. - */ - - if (numWords < 3) { - return TCL_ERROR; - } - - /* - * Generate code to push list being taken apart by [lassign]. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - - /* - * Generate code to assign values from the list to variables. - */ - - for (idx=0 ; idx<numWords-2 ; idx++) { - tokenPtr = TokenAfter(tokenPtr); - - /* - * Generate the next variable name. - */ - - PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex, - &simpleVarName, &isScalar, idx+2); - - /* - * Emit instructions to get the idx'th item out of the list value on - * the stack and assign it to the variable. - */ - - if (!simpleVarName) { - TclEmitInstInt4( INST_OVER, 1, envPtr); - TclEmitInstInt4( INST_LIST_INDEX_IMM, idx, envPtr); - TclEmitOpcode( INST_STORE_STK, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } else if (isScalar) { - if (localIndex >= 0) { - TclEmitOpcode( INST_DUP, envPtr); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } else { - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - TclEmitOpcode( INST_STORE_SCALAR_STK, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - } else { - if (localIndex >= 0) { - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } else { - TclEmitInstInt4(INST_OVER, 2, envPtr); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - } - } - - /* - * Generate code to leave the rest of the list on the stack. - */ - - TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr); - TclEmitInt4( -2 /* == "end" */, envPtr); - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileLindexCmd -- - * - * Procedure called to compile the "lindex" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "lindex" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileLindexCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *idxTokenPtr, *valTokenPtr; - int i, numWords = parsePtr->numWords; - DefineLineInformation; /* TIP #280 */ - - /* - * Quit if too few args. - */ - - if (numWords <= 1) { - return TCL_ERROR; - } - - valTokenPtr = TokenAfter(parsePtr->tokenPtr); - if (numWords != 3) { - goto emitComplexLindex; - } - - idxTokenPtr = TokenAfter(valTokenPtr); - if (idxTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - Tcl_Obj *tmpObj; - int idx, result; - - tmpObj = Tcl_NewStringObj(idxTokenPtr[1].start, idxTokenPtr[1].size); - result = TclGetIntFromObj(NULL, tmpObj, &idx); - if (result == TCL_OK) { - if (idx < 0) { - result = TCL_ERROR; - } - } else { - result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx); - if (result == TCL_OK && idx > -2) { - result = TCL_ERROR; - } - } - TclDecrRefCount(tmpObj); - - if (result == TCL_OK) { - /* - * All checks have been completed, and we have exactly one of - * these constructs: - * lindex <arbitraryValue> <posInt> - * lindex <arbitraryValue> end-<posInt> - * This is best compiled as a push of the arbitrary value followed - * by an "immediate lindex" which is the most efficient variety. - */ - - CompileWord(envPtr, valTokenPtr, interp, 1); - TclEmitInstInt4( INST_LIST_INDEX_IMM, idx, envPtr); - return TCL_OK; - } - - /* - * If the conversion failed or the value was negative, we just keep on - * going with the more complex compilation. - */ - } - - /* - * Push the operands onto the stack. - */ - - emitComplexLindex: - for (i=1 ; i<numWords ; i++) { - CompileWord(envPtr, valTokenPtr, interp, i); - valTokenPtr = TokenAfter(valTokenPtr); - } - - /* - * Emit INST_LIST_INDEX if objc==3, or INST_LIST_INDEX_MULTI if there are - * multiple index args. - */ - - if (numWords == 3) { - TclEmitOpcode( INST_LIST_INDEX, envPtr); - } else { - TclEmitInstInt4( INST_LIST_INDEX_MULTI, numWords-1, envPtr); - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileListCmd -- - * - * Procedure called to compile the "list" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "list" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileListCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - DefineLineInformation; /* TIP #280 */ - Tcl_Token *valueTokenPtr; - int i, numWords; - - /* - * If we're not in a procedure, don't compile. - */ - - if (envPtr->procPtr == NULL) { - return TCL_ERROR; - } - - if (parsePtr->numWords == 1) { - /* - * [list] without arguments just pushes an empty object. - */ - - PushLiteral(envPtr, "", 0); - } else { - /* - * Push the all values onto the stack. - */ - - numWords = parsePtr->numWords; - valueTokenPtr = TokenAfter(parsePtr->tokenPtr); - for (i = 1; i < numWords; i++) { - CompileWord(envPtr, valueTokenPtr, interp, i); - valueTokenPtr = TokenAfter(valueTokenPtr); - } - TclEmitInstInt4( INST_LIST, numWords - 1, envPtr); - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileLlengthCmd -- - * - * Procedure called to compile the "llength" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "llength" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileLlengthCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *varTokenPtr; - DefineLineInformation; /* TIP #280 */ - - if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - - CompileWord(envPtr, varTokenPtr, interp, 1); - TclEmitOpcode( INST_LIST_LENGTH, envPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileLrangeCmd -- - * - * How to compile the "lrange" command. We only bother because we needed - * the opcode anyway for "lassign". - * - *---------------------------------------------------------------------- - */ - -int -TclCompileLrangeCmd( - Tcl_Interp *interp, /* Tcl interpreter for context. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the - * command. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds the resulting instructions. */ -{ - Tcl_Token *tokenPtr, *listTokenPtr; - DefineLineInformation; /* TIP #280 */ - Tcl_Obj *tmpObj; - int idx1, idx2, result; - - if (parsePtr->numWords != 4) { - return TCL_ERROR; - } - listTokenPtr = TokenAfter(parsePtr->tokenPtr); - - /* - * Parse the first index. Will only compile if it is constant and not an - * _integer_ less than zero (since we reserve negative indices here for - * end-relative indexing). - */ - - tokenPtr = TokenAfter(listTokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size); - result = TclGetIntFromObj(NULL, tmpObj, &idx1); - if (result == TCL_OK) { - if (idx1 < 0) { - result = TCL_ERROR; - } - } else { - result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx1); - if (result == TCL_OK && idx1 > -2) { - result = TCL_ERROR; - } - } - TclDecrRefCount(tmpObj); - if (result != TCL_OK) { - return TCL_ERROR; - } - - /* - * Parse the second index. Will only compile if it is constant and not an - * _integer_ less than zero (since we reserve negative indices here for - * end-relative indexing). - */ - - tokenPtr = TokenAfter(tokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size); - result = TclGetIntFromObj(NULL, tmpObj, &idx2); - if (result == TCL_OK) { - if (idx2 < 0) { - result = TCL_ERROR; - } - } else { - result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx2); - if (result == TCL_OK && idx2 > -2) { - result = TCL_ERROR; - } - } - TclDecrRefCount(tmpObj); - if (result != TCL_OK) { - return TCL_ERROR; - } - - /* - * Issue instructions. It's not safe to skip doing the LIST_RANGE, as - * we've not proved that the 'list' argument is really a list. Not that it - * is worth trying to do that given current knowledge. - */ - - CompileWord(envPtr, listTokenPtr, interp, 1); - TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr); - TclEmitInt4( idx2, envPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileLreplaceCmd -- - * - * How to compile the "lreplace" command. We only bother with the case - * where there are no elements to insert and where both the 'first' and - * 'last' arguments are constant and one can be deterined to be at the - * end of the list. (This is the case that could also be written with - * "lrange".) - * - *---------------------------------------------------------------------- - */ - -int -TclCompileLreplaceCmd( - Tcl_Interp *interp, /* Tcl interpreter for context. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the - * command. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds the resulting instructions. */ -{ - Tcl_Token *tokenPtr, *listTokenPtr; - DefineLineInformation; /* TIP #280 */ - Tcl_Obj *tmpObj; - int idx1, idx2, result, guaranteedDropAll = 0; - - if (parsePtr->numWords != 4) { - return TCL_ERROR; - } - listTokenPtr = TokenAfter(parsePtr->tokenPtr); - - /* - * Parse the first index. Will only compile if it is constant and not an - * _integer_ less than zero (since we reserve negative indices here for - * end-relative indexing). - */ - - tokenPtr = TokenAfter(listTokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size); - result = TclGetIntFromObj(NULL, tmpObj, &idx1); - if (result == TCL_OK) { - if (idx1 < 0) { - result = TCL_ERROR; - } - } else { - result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx1); - if (result == TCL_OK && idx1 > -2) { - result = TCL_ERROR; - } - } - TclDecrRefCount(tmpObj); - if (result != TCL_OK) { - return TCL_ERROR; - } - - /* - * Parse the second index. Will only compile if it is constant and not an - * _integer_ less than zero (since we reserve negative indices here for - * end-relative indexing). - */ - - tokenPtr = TokenAfter(tokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size); - result = TclGetIntFromObj(NULL, tmpObj, &idx2); - if (result == TCL_OK) { - if (idx2 < 0) { - result = TCL_ERROR; - } - } else { - result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx2); - if (result == TCL_OK && idx2 > -2) { - result = TCL_ERROR; - } - } - TclDecrRefCount(tmpObj); - if (result != TCL_OK) { - return TCL_ERROR; - } - - /* - * Sanity check: can only issue when we're removing a range at one or - * other end of the list. If we're at one end or the other, convert the - * indices into the equivalent for an [lrange]. - */ - - if (idx1 == 0) { - if (idx2 == -2) { - guaranteedDropAll = 1; - } - idx1 = idx2 + 1; - idx2 = -2; - } else if (idx2 == -2) { - idx2 = idx1 - 1; - idx1 = 0; - } else { - return TCL_ERROR; - } - - /* - * Issue instructions. It's not safe to skip doing the LIST_RANGE, as - * we've not proved that the 'list' argument is really a list. Not that it - * is worth trying to do that given current knowledge. - */ - - CompileWord(envPtr, listTokenPtr, interp, 1); - if (guaranteedDropAll) { - TclEmitOpcode( INST_LIST_LENGTH, envPtr); - TclEmitOpcode( INST_POP, envPtr); - PushLiteral(envPtr, "", 0); - } else { - TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr); - TclEmitInt4( idx2, envPtr); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileLsetCmd -- - * - * Procedure called to compile the "lset" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "lset" command at - * runtime. - * - * The general template for execution of the "lset" command is: - * (1) Instructions to push the variable name, unless the variable is - * local to the stack frame. - * (2) If the variable is an array element, instructions to push the - * array element name. - * (3) Instructions to push each of zero or more "index" arguments to the - * stack, followed with the "newValue" element. - * (4) Instructions to duplicate the variable name and/or array element - * name onto the top of the stack, if either was pushed at steps (1) - * and (2). - * (5) The appropriate INST_LOAD_* instruction to place the original - * value of the list variable at top of stack. - * (6) At this point, the stack contains: - * varName? arrayElementName? index1 index2 ... newValue oldList - * The compiler emits one of INST_LSET_FLAT or INST_LSET_LIST - * according as whether there is exactly one index element (LIST) or - * either zero or else two or more (FLAT). This instruction removes - * everything from the stack except for the two names and pushes the - * new value of the variable. - * (7) Finally, INST_STORE_* stores the new value in the variable and - * cleans up the stack. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileLsetCmd( - Tcl_Interp *interp, /* Tcl interpreter for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the - * command. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds the resulting instructions. */ -{ - int tempDepth; /* Depth used for emitting one part of the - * code burst. */ - Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the - * parse of the variable name. */ - int localIndex; /* Index of var in local var table. */ - int simpleVarName; /* Flag == 1 if var name is simple. */ - int isScalar; /* Flag == 1 if scalar, 0 if array. */ - int i; - DefineLineInformation; /* TIP #280 */ - - /* - * Check argument count. - */ - - if (parsePtr->numWords < 3) { - /* - * Fail at run time, not in compilation. - */ - - return TCL_ERROR; - } - - /* - * Decide if we can use a frame slot for the var/array name or if we need - * to emit code to compute and push the name at runtime. We use a frame - * slot (entry in the array of local vars) if we are compiling a procedure - * body and if the name is simple text that does not include namespace - * qualifiers. - */ - - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarNameWord(interp, varTokenPtr, envPtr, 0, - &localIndex, &simpleVarName, &isScalar, 1); - - /* - * Push the "index" args and the new element value. - */ - - for (i=2 ; i<parsePtr->numWords ; ++i) { - varTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, varTokenPtr, interp, i); - } - - /* - * Duplicate the variable name if it's been pushed. - */ - - if (!simpleVarName || localIndex < 0) { - if (!simpleVarName || isScalar) { - tempDepth = parsePtr->numWords - 2; - } else { - tempDepth = parsePtr->numWords - 1; - } - TclEmitInstInt4( INST_OVER, tempDepth, envPtr); - } - - /* - * Duplicate an array index if one's been pushed. - */ - - if (simpleVarName && !isScalar) { - if (localIndex < 0) { - tempDepth = parsePtr->numWords - 1; - } else { - tempDepth = parsePtr->numWords - 2; - } - TclEmitInstInt4( INST_OVER, tempDepth, envPtr); - } - - /* - * Emit code to load the variable's value. - */ - - if (!simpleVarName) { - TclEmitOpcode( INST_LOAD_STK, envPtr); - } else if (isScalar) { - if (localIndex < 0) { - TclEmitOpcode( INST_LOAD_SCALAR_STK, envPtr); - } else { - Emit14Inst( INST_LOAD_SCALAR, localIndex, envPtr); - } - } else { - if (localIndex < 0) { - TclEmitOpcode( INST_LOAD_ARRAY_STK, envPtr); - } else { - Emit14Inst( INST_LOAD_ARRAY, localIndex, envPtr); - } - } - - /* - * Emit the correct variety of 'lset' instruction. - */ - - if (parsePtr->numWords == 4) { - TclEmitOpcode( INST_LSET_LIST, envPtr); - } else { - TclEmitInstInt4( INST_LSET_FLAT, parsePtr->numWords-1, envPtr); - } - - /* - * Emit code to put the value back in the variable. - */ - - if (!simpleVarName) { - TclEmitOpcode( INST_STORE_STK, envPtr); - } else if (isScalar) { - if (localIndex < 0) { - TclEmitOpcode( INST_STORE_SCALAR_STK, envPtr); - } else { - Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); - } - } else { - if (localIndex < 0) { - TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr); - } else { - Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); - } - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileLmapCmd -- - * - * Procedure called to compile the "lmap" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "lmap" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileLmapCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - return CompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr, - TCL_EACH_COLLECT); -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileNamespace*Cmd -- - * - * Procedures called to compile the "namespace" command; currently, only - * the subcommands "namespace current" and "namespace upvar" are compiled - * to bytecodes, and the latter only inside a procedure(-like) context. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "namespace upvar" - * command at runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileNamespaceCurrentCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - /* - * Only compile [namespace current] without arguments. - */ - - if (parsePtr->numWords != 1) { - return TCL_ERROR; - } - - /* - * Not much to do; we compile to a single instruction... - */ - - TclEmitOpcode( INST_NS_CURRENT, envPtr); - return TCL_OK; -} - -int -TclCompileNamespaceCodeCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr; - DefineLineInformation; /* TIP #280 */ - - if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(parsePtr->tokenPtr); - - /* - * The specification of [namespace code] is rather shocking, in that it is - * supposed to check if the argument is itself the result of [namespace - * code] and not apply itself in that case. Which is excessively cautious, - * but what the test suite checks for. - */ - - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || (tokenPtr[1].size > 20 - && strncmp(tokenPtr[1].start, "::namespace inscope ", 20) == 0)) { - /* - * Technically, we could just pass a literal '::namespace inscope ' - * term through, but that's something which really shouldn't be - * occurring as something that the user writes so we'll just punt it. - */ - - return TCL_ERROR; - } - - /* - * Now we can compile using the same strategy as [namespace code]'s normal - * implementation does internally. Note that we can't bind the namespace - * name directly here, because TclOO plays complex games with namespaces; - * the value needs to be determined at runtime for safety. - */ - - PushLiteral(envPtr, "::namespace", 11); - PushLiteral(envPtr, "inscope", 7); - TclEmitOpcode( INST_NS_CURRENT, envPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - TclEmitInstInt4( INST_LIST, 4, envPtr); - return TCL_OK; -} - -int -TclCompileNamespaceQualifiersCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - DefineLineInformation; /* TIP #280 */ - int off; - - if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - - CompileWord(envPtr, tokenPtr, interp, 1); - PushLiteral(envPtr, "0", 1); - PushLiteral(envPtr, "::", 2); - TclEmitInstInt4( INST_OVER, 2, envPtr); - TclEmitOpcode( INST_STR_FIND_LAST, envPtr); - off = CurrentOffset(envPtr); - PushLiteral(envPtr, "1", 1); - TclEmitOpcode( INST_SUB, envPtr); - TclEmitInstInt4( INST_OVER, 2, envPtr); - TclEmitInstInt4( INST_OVER, 1, envPtr); - TclEmitOpcode( INST_STR_INDEX, envPtr); - PushLiteral(envPtr, ":", 1); - TclEmitOpcode( INST_STR_EQ, envPtr); - off = off - CurrentOffset(envPtr); - TclEmitInstInt1( INST_JUMP_TRUE1, off, envPtr); - TclEmitOpcode( INST_STR_RANGE, envPtr); - return TCL_OK; -} - -int -TclCompileNamespaceTailCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - DefineLineInformation; /* TIP #280 */ - JumpFixup jumpFixup; - - if (parsePtr->numWords != 2) { - return TCL_ERROR; - } - - /* - * Take care; only add 2 to found index if the string was actually found. - */ - - CompileWord(envPtr, tokenPtr, interp, 1); - PushLiteral(envPtr, "::", 2); - TclEmitInstInt4( INST_OVER, 1, envPtr); - TclEmitOpcode( INST_STR_FIND_LAST, envPtr); - TclEmitOpcode( INST_DUP, envPtr); - PushLiteral(envPtr, "0", 1); - TclEmitOpcode( INST_GE, envPtr); - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFixup); - PushLiteral(envPtr, "2", 1); - TclEmitOpcode( INST_ADD, envPtr); - TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127); - PushLiteral(envPtr, "end", 3); - TclEmitOpcode( INST_STR_RANGE, envPtr); - return TCL_OK; -} - -int -TclCompileNamespaceUpvarCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; - int simpleVarName, isScalar, localIndex, numWords, i; - DefineLineInformation; /* TIP #280 */ - - if (envPtr->procPtr == NULL) { - return TCL_ERROR; - } - - /* - * Only compile [namespace upvar ...]: needs an even number of args, >=4 - */ - - numWords = parsePtr->numWords; - if ((numWords % 2) || (numWords < 4)) { - return TCL_ERROR; - } - - /* - * Push the namespace - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - - /* - * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a - * local variable, return an error so that the non-compiled command will - * be called at runtime. - */ - - localTokenPtr = tokenPtr; - for (i=3; i<=numWords; i+=2) { - otherTokenPtr = TokenAfter(localTokenPtr); - localTokenPtr = TokenAfter(otherTokenPtr); - - CompileWord(envPtr, otherTokenPtr, interp, 1); - PushVarNameWord(interp, localTokenPtr, envPtr, 0, - &localIndex, &simpleVarName, &isScalar, 1); - - if ((localIndex < 0) || !isScalar) { - return TCL_ERROR; - } - TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr); - } - - /* - * Pop the namespace, and set the result to empty - */ - - TclEmitOpcode( INST_POP, envPtr); - PushLiteral(envPtr, "", 0); - return TCL_OK; -} - -int -TclCompileNamespaceWhichCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr, *opt; - int idx; - - if (parsePtr->numWords < 2 || parsePtr->numWords > 3) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(parsePtr->tokenPtr); - idx = 1; - - /* - * If there's an option, check that it's "-command". We don't handle - * "-variable" (currently) and anything else is an error. - */ - - if (parsePtr->numWords == 3) { - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - opt = tokenPtr + 1; - if (opt->size < 2 || opt->size > 8 - || strncmp(opt->start, "-command", opt->size) != 0) { - return TCL_ERROR; - } - tokenPtr = TokenAfter(tokenPtr); - idx++; - } - - /* - * Issue the bytecode. - */ - - CompileWord(envPtr, tokenPtr, interp, idx); - TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileRegexpCmd -- - * - * Procedure called to compile the "regexp" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "regexp" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileRegexpCmd( - Tcl_Interp *interp, /* Tcl interpreter for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the - * command. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds the resulting instructions. */ -{ - Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the - * parse of the RE or string. */ - int i, len, nocase, exact, sawLast, simple; - const char *str; - DefineLineInformation; /* TIP #280 */ - - /* - * We are only interested in compiling simple regexp cases. Currently - * supported compile cases are: - * regexp ?-nocase? ?--? staticString $var - * regexp ?-nocase? ?--? {^staticString$} $var - */ - - if (parsePtr->numWords < 3) { - return TCL_ERROR; - } - - simple = 0; - nocase = 0; - sawLast = 0; - varTokenPtr = parsePtr->tokenPtr; - - /* - * We only look for -nocase and -- as options. Everything else gets pushed - * to runtime execution. This is different than regexp's runtime option - * handling, but satisfies our stricter needs. - */ - - for (i = 1; i < parsePtr->numWords - 2; i++) { - varTokenPtr = TokenAfter(varTokenPtr); - if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - /* - * Not a simple string, so punt to runtime. - */ - - return TCL_ERROR; - } - str = varTokenPtr[1].start; - len = varTokenPtr[1].size; - if ((len == 2) && (str[0] == '-') && (str[1] == '-')) { - sawLast++; - i++; - break; - } else if ((len > 1) && (strncmp(str,"-nocase",(unsigned)len) == 0)) { - nocase = 1; - } else { - /* - * Not an option we recognize. - */ - - return TCL_ERROR; - } - } - - if ((parsePtr->numWords - i) != 2) { - /* - * We don't support capturing to variables. - */ - - return TCL_ERROR; - } - - /* - * Get the regexp string. If it is not a simple string or can't be - * converted to a glob pattern, push the word for the INST_REGEXP. - * Keep changes here in sync with TclCompileSwitchCmd Switch_Regexp. - */ - - varTokenPtr = TokenAfter(varTokenPtr); - - if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - Tcl_DString ds; - - str = varTokenPtr[1].start; - len = varTokenPtr[1].size; - - /* - * If it has a '-', it could be an incorrectly formed regexp command. - */ - - if ((*str == '-') && !sawLast) { - return TCL_ERROR; - } - - if (len == 0) { - /* - * The semantics of regexp are always match on re == "". - */ - - PushLiteral(envPtr, "1", 1); - return TCL_OK; - } - - /* - * Attempt to convert pattern to glob. If successful, push the - * converted pattern as a literal. - */ - - if (TclReToGlob(NULL, varTokenPtr[1].start, len, &ds, &exact) - == TCL_OK) { - simple = 1; - PushLiteral(envPtr, Tcl_DStringValue(&ds),Tcl_DStringLength(&ds)); - Tcl_DStringFree(&ds); - } - } - - if (!simple) { - CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-2); - } - - /* - * Push the string arg. - */ - - varTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-1); - - if (simple) { - if (exact && !nocase) { - TclEmitOpcode( INST_STR_EQ, envPtr); - } else { - TclEmitInstInt1( INST_STR_MATCH, nocase, envPtr); - } - } else { - /* - * Pass correct RE compile flags. We use only Int1 (8-bit), but - * that handles all the flags we want to pass. - * Don't use TCL_REG_NOSUB as we may have backrefs. - */ - - int cflags = TCL_REG_ADVANCED | (nocase ? TCL_REG_NOCASE : 0); - - TclEmitInstInt1( INST_REGEXP, cflags, envPtr); - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileRegsubCmd -- - * - * Procedure called to compile the "regsub" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "regsub" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileRegsubCmd( - Tcl_Interp *interp, /* Tcl interpreter for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the - * command. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds the resulting instructions. */ -{ - /* - * We only compile the case with [regsub -all] where the pattern is both - * known at compile time and simple (i.e., no RE metacharacters). That is, - * the pattern must be translatable into a glob like "*foo*" with no other - * glob metacharacters inside it; there must be some "foo" in there too. - * The substitution string must also be known at compile time and free of - * metacharacters ("\digit" and "&"). Finally, there must not be a - * variable mentioned in the [regsub] to write the result back to (because - * we can't get the count of substitutions that would be the result in - * that case). The key is that these are the conditions under which a - * [string map] could be used instead, in particular a [string map] of the - * form we can compile to bytecode. - * - * In short, we look for: - * - * regsub -all [--] simpleRE string simpleReplacement - * - * The only optional part is the "--", and no other options are handled. - */ - - DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr, *stringTokenPtr; - Tcl_Obj *patternObj = NULL, *replacementObj = NULL; - Tcl_DString pattern; - const char *bytes; - int len, exact, result = TCL_ERROR; - - if (parsePtr->numWords < 5 || parsePtr->numWords > 6) { - return TCL_ERROR; - } - - /* - * Parse the "-all", which must be the first argument (other options not - * supported, non-"-all" substitution we can't compile). - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size != 4 - || strncmp(tokenPtr[1].start, "-all", 4)) { - return TCL_ERROR; - } - - /* - * Get the pattern into patternObj, checking for "--" in the process. - */ - - Tcl_DStringInit(&pattern); - tokenPtr = TokenAfter(tokenPtr); - patternObj = Tcl_NewObj(); - if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) { - goto done; - } - if (Tcl_GetString(patternObj)[0] == '-') { - if (strcmp(Tcl_GetString(patternObj), "--") != 0 - || parsePtr->numWords == 5) { - goto done; - } - tokenPtr = TokenAfter(tokenPtr); - Tcl_DecrRefCount(patternObj); - patternObj = Tcl_NewObj(); - if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) { - goto done; - } - } else if (parsePtr->numWords == 6) { - goto done; - } - - /* - * Identify the code which produces the string to apply the substitution - * to (stringTokenPtr), and the replacement string (into replacementObj). - */ - - stringTokenPtr = TokenAfter(tokenPtr); - tokenPtr = TokenAfter(stringTokenPtr); - replacementObj = Tcl_NewObj(); - if (!TclWordKnownAtCompileTime(tokenPtr, replacementObj)) { - goto done; - } - - /* - * Next, higher-level checks. Is the RE a very simple glob? Is the - * replacement "simple"? - */ - - bytes = Tcl_GetStringFromObj(patternObj, &len); - if (TclReToGlob(NULL, bytes, len, &pattern, &exact) != TCL_OK || exact) { - goto done; - } - bytes = Tcl_DStringValue(&pattern); - if (*bytes++ != '*') { - goto done; - } - while (1) { - switch (*bytes) { - case '*': - if (bytes[1] == '\0') { - /* - * OK, we've proved there are no metacharacters except for the - * '*' at each end. - */ - - len = Tcl_DStringLength(&pattern) - 2; - if (len > 0) { - goto isSimpleGlob; - } - - /* - * The pattern is "**"! I believe that should be impossible, - * but we definitely can't handle that at all. - */ - } - case '\0': case '?': case '[': case '\\': - goto done; - } - bytes++; - } - isSimpleGlob: - for (bytes = Tcl_GetString(replacementObj); *bytes; bytes++) { - switch (*bytes) { - case '\\': case '&': - goto done; - } - } - - /* - * Proved the simplicity constraints! Time to issue the code. - */ - - result = TCL_OK; - bytes = Tcl_DStringValue(&pattern) + 1; - PushLiteral(envPtr, bytes, len); - bytes = Tcl_GetStringFromObj(replacementObj, &len); - PushLiteral(envPtr, bytes, len); - CompileWord(envPtr, stringTokenPtr, interp, parsePtr->numWords-2); - TclEmitOpcode( INST_STR_MAP, envPtr); - - done: - Tcl_DStringFree(&pattern); - if (patternObj) { - Tcl_DecrRefCount(patternObj); - } - if (replacementObj) { - Tcl_DecrRefCount(replacementObj); - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileReturnCmd -- - * - * Procedure called to compile the "return" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "return" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileReturnCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - /* - * General syntax: [return ?-option value ...? ?result?] - * An even number of words means an explicit result argument is present. - */ - int level, code, objc, size, status = TCL_OK; - int numWords = parsePtr->numWords; - int explicitResult = (0 == (numWords % 2)); - int numOptionWords = numWords - 1 - explicitResult; - int savedStackDepth = envPtr->currStackDepth; - Tcl_Obj *returnOpts, **objv; - Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr); - DefineLineInformation; /* TIP #280 */ - - /* - * Check for special case which can always be compiled: - * return -options <opts> <msg> - * Unlike the normal [return] compilation, this version does everything at - * runtime so it can handle arbitrary words and not just literals. Note - * that if INST_RETURN_STK wasn't already needed for something else - * ('finally' clause processing) this piece of code would not be present. - */ - - if ((numWords == 4) && (wordTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) - && (wordTokenPtr[1].size == 8) - && (strncmp(wordTokenPtr[1].start, "-options", 8) == 0)) { - Tcl_Token *optsTokenPtr = TokenAfter(wordTokenPtr); - Tcl_Token *msgTokenPtr = TokenAfter(optsTokenPtr); - - CompileWord(envPtr, optsTokenPtr, interp, 2); - CompileWord(envPtr, msgTokenPtr, interp, 3); - TclEmitOpcode(INST_RETURN_STK, envPtr); - envPtr->currStackDepth = savedStackDepth + 1; - return TCL_OK; - } - - /* - * Allocate some working space. - */ - - objv = TclStackAlloc(interp, numOptionWords * sizeof(Tcl_Obj *)); - - /* - * Scan through the return options. If any are unknown at compile time, - * there is no value in bytecompiling. Save the option values known in an - * objv array for merging into a return options dictionary. - */ - - for (objc = 0; objc < numOptionWords; objc++) { - objv[objc] = Tcl_NewObj(); - Tcl_IncrRefCount(objv[objc]); - if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) { - objc++; - status = TCL_ERROR; - goto cleanup; - } - wordTokenPtr = TokenAfter(wordTokenPtr); - } - status = TclMergeReturnOptions(interp, objc, objv, - &returnOpts, &code, &level); - cleanup: - while (--objc >= 0) { - TclDecrRefCount(objv[objc]); - } - TclStackFree(interp, objv); - if (TCL_ERROR == status) { - /* - * Something was bogus in the return options. Clear the error message, - * and report back to the compiler that this must be interpreted at - * runtime. - */ - - Tcl_ResetResult(interp); - return TCL_ERROR; - } - - /* - * All options are known at compile time, so we're going to bytecompile. - * Emit instructions to push the result on the stack. - */ - - if (explicitResult) { - CompileWord(envPtr, wordTokenPtr, interp, numWords-1); - } else { - /* - * No explict result argument, so default result is empty string. - */ - - PushLiteral(envPtr, "", 0); - } - - /* - * Check for optimization: When [return] is in a proc, and there's no - * enclosing [catch], and there are no return options, then the INST_DONE - * instruction is equivalent, and may be more efficient. - */ - - if (numOptionWords == 0 && envPtr->procPtr != NULL) { - /* - * We have default return options and we're in a proc ... - */ - - int index = envPtr->exceptArrayNext - 1; - int enclosingCatch = 0; - - while (index >= 0) { - ExceptionRange range = envPtr->exceptArrayPtr[index]; - - if ((range.type == CATCH_EXCEPTION_RANGE) - && (range.catchOffset == -1)) { - enclosingCatch = 1; - break; - } - index--; - } - if (!enclosingCatch) { - /* - * ... and there is no enclosing catch. Issue the maximally - * efficient exit instruction. - */ - - Tcl_DecrRefCount(returnOpts); - TclEmitOpcode(INST_DONE, envPtr); - return TCL_OK; - } - } - - /* Optimize [return -level 0 $x]. */ - Tcl_DictObjSize(NULL, returnOpts, &size); - if (size == 0 && level == 0 && code == TCL_OK) { - Tcl_DecrRefCount(returnOpts); - return TCL_OK; - } - - /* - * Could not use the optimization, so we push the return options dict, and - * emit the INST_RETURN_IMM instruction with code and level as operands. - */ - - CompileReturnInternal(envPtr, INST_RETURN_IMM, code, level, returnOpts); - return TCL_OK; -} - -static void -CompileReturnInternal( - CompileEnv *envPtr, - unsigned char op, - int code, - int level, - Tcl_Obj *returnOpts) -{ - TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr); - TclEmitInstInt4(op, code, envPtr); - TclEmitInt4(level, envPtr); -} - -void -TclCompileSyntaxError( - Tcl_Interp *interp, - CompileEnv *envPtr) -{ - Tcl_Obj *msg = Tcl_GetObjResult(interp); - int numBytes; - const char *bytes = TclGetStringFromObj(msg, &numBytes); - - TclErrorStackResetIf(interp, bytes, numBytes); - TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr); - CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0, - TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR))); -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileUpvarCmd -- - * - * Procedure called to compile the "upvar" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "upvar" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileUpvarCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; - int simpleVarName, isScalar, localIndex, numWords, i; - DefineLineInformation; /* TIP #280 */ - Tcl_Obj *objPtr = Tcl_NewObj(); - - if (envPtr->procPtr == NULL) { - Tcl_DecrRefCount(objPtr); - return TCL_ERROR; - } - - numWords = parsePtr->numWords; - if (numWords < 3) { - Tcl_DecrRefCount(objPtr); - return TCL_ERROR; - } - - /* - * Push the frame index if it is known at compile time - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - if (TclWordKnownAtCompileTime(tokenPtr, objPtr)) { - CallFrame *framePtr; - const Tcl_ObjType *newTypePtr, *typePtr = objPtr->typePtr; - - /* - * Attempt to convert to a level reference. Note that TclObjGetFrame - * only changes the obj type when a conversion was successful. - */ - - TclObjGetFrame(interp, objPtr, &framePtr); - newTypePtr = objPtr->typePtr; - Tcl_DecrRefCount(objPtr); - - if (newTypePtr != typePtr) { - if (numWords%2) { - return TCL_ERROR; - } - CompileWord(envPtr, tokenPtr, interp, 1); - otherTokenPtr = TokenAfter(tokenPtr); - i = 4; - } else { - if (!(numWords%2)) { - return TCL_ERROR; - } - PushLiteral(envPtr, "1", 1); - otherTokenPtr = tokenPtr; - i = 3; - } - } else { - Tcl_DecrRefCount(objPtr); - return TCL_ERROR; - } - - /* - * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a - * local variable, return an error so that the non-compiled command will - * be called at runtime. - */ - - for (; i<=numWords; i+=2, otherTokenPtr = TokenAfter(localTokenPtr)) { - localTokenPtr = TokenAfter(otherTokenPtr); - - CompileWord(envPtr, otherTokenPtr, interp, 1); - PushVarNameWord(interp, localTokenPtr, envPtr, 0, - &localIndex, &simpleVarName, &isScalar, 1); - - if ((localIndex < 0) || !isScalar) { - return TCL_ERROR; - } - TclEmitInstInt4( INST_UPVAR, localIndex, envPtr); - } - - /* - * Pop the frame index, and set the result to empty - */ - - TclEmitOpcode( INST_POP, envPtr); - PushLiteral(envPtr, "", 0); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileVariableCmd -- - * - * Procedure called to compile the "variable" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "variable" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileVariableCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *varTokenPtr, *valueTokenPtr; - int localIndex, numWords, i; - DefineLineInformation; /* TIP #280 */ - - numWords = parsePtr->numWords; - if (numWords < 2) { - return TCL_ERROR; - } - - /* - * Bail out if not compiling a proc body - */ - - if (envPtr->procPtr == NULL) { - return TCL_ERROR; - } - - /* - * Loop over the (var, value) pairs. - */ - - valueTokenPtr = parsePtr->tokenPtr; - for (i=1; i<numWords; i+=2) { - varTokenPtr = TokenAfter(valueTokenPtr); - valueTokenPtr = TokenAfter(varTokenPtr); - - localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr); - - if (localIndex < 0) { - return TCL_ERROR; - } - - CompileWord(envPtr, varTokenPtr, interp, i); - TclEmitInstInt4( INST_VARIABLE, localIndex, envPtr); - - if (i+1 < numWords) { - /* - * A value has been given: set the variable, pop the value - */ - - CompileWord(envPtr, valueTokenPtr, interp, i+1); - Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - } - - /* - * Set the result to empty - */ - - PushLiteral(envPtr, "", 0); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * IndexTailVarIfKnown -- - * - * Procedure used in compiling [global] and [variable] commands. It - * inspects the variable name described by varTokenPtr and, if the tail - * is known at compile time, defines a corresponding local variable. - * - * Results: - * Returns the variable's index in the table of compiled locals if the - * tail is known at compile time, or -1 otherwise. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -IndexTailVarIfKnown( - Tcl_Interp *interp, - Tcl_Token *varTokenPtr, /* Token representing the variable name */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Obj *tailPtr; - const char *tailName, *p; - int len, n = varTokenPtr->numComponents; - Tcl_Token *lastTokenPtr; - int full, localIndex; - - /* - * Determine if the tail is (a) known at compile time, and (b) not an - * array element. Should any of these fail, return an error so that the - * non-compiled command will be called at runtime. - * - * In order for the tail to be known at compile time, the last token in - * the word has to be constant and contain "::" if it is not the only one. - */ - - if (!EnvHasLVT(envPtr)) { - return -1; - } - - TclNewObj(tailPtr); - if (TclWordKnownAtCompileTime(varTokenPtr, tailPtr)) { - full = 1; - lastTokenPtr = varTokenPtr; - } else { - full = 0; - lastTokenPtr = varTokenPtr + n; - if (!TclWordKnownAtCompileTime(lastTokenPtr, tailPtr)) { - Tcl_DecrRefCount(tailPtr); - return -1; - } - } - - tailName = TclGetStringFromObj(tailPtr, &len); - - if (len) { - if (*(tailName+len-1) == ')') { - /* - * Possible array: bail out - */ - - Tcl_DecrRefCount(tailPtr); - return -1; - } - - /* - * Get the tail: immediately after the last '::' - */ - - for (p = tailName + len -1; p > tailName; p--) { - if ((*p == ':') && (*(p-1) == ':')) { - p++; - break; - } - } - if (!full && (p == tailName)) { - /* - * No :: in the last component. - */ - - Tcl_DecrRefCount(tailPtr); - return -1; - } - len -= p - tailName; - tailName = p; - } - - localIndex = TclFindCompiledLocal(tailName, len, 1, envPtr); - Tcl_DecrRefCount(tailPtr); - return localIndex; -} - -int -TclCompileObjectSelfCmd( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - /* - * We only handle [self] and [self object] (which is the same operation). - * These are the only very common operations on [self] for which - * bytecoding is at all reasonable. - */ - - if (parsePtr->numWords == 1) { - goto compileSelfObject; - } else if (parsePtr->numWords == 2) { - Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr), *subcmd; - - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size==0) { - return TCL_ERROR; - } - - subcmd = tokenPtr + 1; - if (strncmp(subcmd->start, "object", subcmd->size) == 0) { - goto compileSelfObject; - } else if (strncmp(subcmd->start, "namespace", subcmd->size) == 0) { - goto compileSelfNamespace; - } - } - - /* - * Can't compile; handle with runtime call. - */ - - return TCL_ERROR; - - compileSelfObject: - - /* - * This delegates the entire problem to a single opcode. - */ - - TclEmitOpcode( INST_TCLOO_SELF, envPtr); - return TCL_OK; - - compileSelfNamespace: - - /* - * This is formally only correct with TclOO methods as they are currently - * implemented; it assumes that the current namespace is invariably when a - * TclOO context is present is the object's namespace, and that's - * technically only something that's a matter of current policy. But it - * avoids creating another opcode, so that's all good! - */ - - TclEmitOpcode( INST_TCLOO_SELF, envPtr); - TclEmitOpcode( INST_POP, envPtr); - TclEmitOpcode( INST_NS_CURRENT, envPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * PushVarName -- + * TclPushVarName -- * * Procedure used in the compiling where pushing a variable name is * necessary (append, lappend, set). * * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. + * The values written to *localIndexPtr and *isScalarPtr signal to + * the caller what the instructions emitted by this routine will do: + * + * *isScalarPtr (*localIndexPtr < 0) + * 1 1 Push the varname on the stack. (Stack +1) + * 1 0 *localIndexPtr is the index of the compiled + * local for this varname. No instructions + * emitted. (Stack +0) + * 0 1 Push part1 and part2 names of array element + * on the stack. (Stack +2) + * 0 0 *localIndexPtr is the index of the compiled + * local for this array. Element name is pushed + * on the stack. (Stack +1) * * Side effects: - * Instructions are added to envPtr to execute the "set" command at - * runtime. + * Instructions are added to envPtr. * *---------------------------------------------------------------------- */ -static int -PushVarName( +void +TclPushVarName( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Token *varTokenPtr, /* Points to a variable token. */ CompileEnv *envPtr, /* Holds resulting instructions. */ int flags, /* TCL_NO_LARGE_INDEX | TCL_NO_ELEMENT. */ int *localIndexPtr, /* Must not be NULL. */ - int *simpleVarNamePtr, /* Must not be NULL. */ - int *isScalarPtr, /* Must not be NULL. */ - int line, /* Line the token starts on. */ - int *clNext) /* Reference to offset of next hidden cont. - * line. */ + int *isScalarPtr) /* Must not be NULL. */ { register const char *p; const char *name, *elName; @@ -6180,8 +3310,7 @@ PushVarName( */ if (!hasNsQualifiers) { - localIndex = TclFindCompiledLocal(name, nameChars, - 1, envPtr); + localIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr); if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) { /* * We'll push the name. @@ -6201,12 +3330,10 @@ PushVarName( if (elName != NULL && !(flags & TCL_NO_ELEMENT)) { if (elNameChars) { - envPtr->line = line; - envPtr->clNext = clNext; TclCompileTokens(interp, elemTokenPtr, elemTokenCount, envPtr); } else { - PushLiteral(envPtr, "", 0); + PushStringLiteral(envPtr, ""); } } } else { @@ -6214,8 +3341,6 @@ PushVarName( * The var name isn't simple: compile and push it. */ - envPtr->line = line; - envPtr->clNext = clNext; CompileTokens(envPtr, varTokenPtr, interp); } @@ -6226,9 +3351,7 @@ PushVarName( TclStackFree(interp, elemTokenPtr); } *localIndexPtr = localIndex; - *simpleVarNamePtr = simpleVarName; *isScalarPtr = (elName == NULL); - return TCL_OK; } /* diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c new file mode 100644 index 0000000..b3e273f --- /dev/null +++ b/generic/tclCompCmdsGR.c @@ -0,0 +1,3171 @@ +/* + * tclCompCmdsGR.c -- + * + * This file contains compilation procedures that compile various Tcl + * commands (beginning with the letters 'g' through 'r') into a sequence + * of instructions ("bytecodes"). + * + * Copyright (c) 1997-1998 Sun Microsystems, Inc. + * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. + * Copyright (c) 2002 ActiveState Corporation. + * Copyright (c) 2004-2013 by Donal K. Fellows. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tclInt.h" +#include "tclCompile.h" +#include <assert.h> + +/* + * Prototypes for procedures defined later in this file: + */ + +static void CompileReturnInternal(CompileEnv *envPtr, + unsigned char op, int code, int level, + Tcl_Obj *returnOpts); +static int IndexTailVarIfKnown(Tcl_Interp *interp, + Tcl_Token *varTokenPtr, CompileEnv *envPtr); + +#define INDEX_END (-2) + +/* + *---------------------------------------------------------------------- + * + * GetIndexFromToken -- + * + * Parse a token and get the encoded version of the index (as understood + * by TEBC), assuming it is at all knowable at compile time. Only handles + * indices that are integers or 'end' or 'end-integer'. + * + * Returns: + * TCL_OK if parsing succeeded, and TCL_ERROR if it failed. + * + * Side effects: + * Sets *index to the index value if successful. + * + *---------------------------------------------------------------------- + */ + +static inline int +GetIndexFromToken( + Tcl_Token *tokenPtr, + int *index) +{ + Tcl_Obj *tmpObj = Tcl_NewObj(); + int result, idx; + + if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) { + Tcl_DecrRefCount(tmpObj); + return TCL_ERROR; + } + + result = TclGetIntFromObj(NULL, tmpObj, &idx); + if (result == TCL_OK) { + if (idx < 0) { + result = TCL_ERROR; + } + } else { + result = TclGetIntForIndexM(NULL, tmpObj, INDEX_END, &idx); + if (result == TCL_OK && idx > INDEX_END) { + result = TCL_ERROR; + } + } + Tcl_DecrRefCount(tmpObj); + + if (result == TCL_OK) { + *index = idx; + } + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileGlobalCmd -- + * + * Procedure called to compile the "global" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "global" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileGlobalCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *varTokenPtr; + int localIndex, numWords, i; + DefineLineInformation; /* TIP #280 */ + + /* TODO: Consider support for compiling expanded args. */ + numWords = parsePtr->numWords; + if (numWords < 2) { + return TCL_ERROR; + } + + /* + * 'global' has no effect outside of proc bodies; handle that at runtime + */ + + if (envPtr->procPtr == NULL) { + return TCL_ERROR; + } + + /* + * Push the namespace + */ + + PushStringLiteral(envPtr, "::"); + + /* + * Loop over the variables. + */ + + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + for (i=1; i<numWords; varTokenPtr = TokenAfter(varTokenPtr),i++) { + localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr); + + if (localIndex < 0) { + return TCL_ERROR; + } + + /* TODO: Consider what value can pass throug the + * IndexTailVarIfKnown() screen. Full CompileWord() + * likely does not apply here. Push known value instead. */ + CompileWord(envPtr, varTokenPtr, interp, i); + TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr); + } + + /* + * Pop the namespace, and set the result to empty + */ + + TclEmitOpcode( INST_POP, envPtr); + PushStringLiteral(envPtr, ""); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileIfCmd -- + * + * Procedure called to compile the "if" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "if" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileIfCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + JumpFixupArray jumpFalseFixupArray; + /* Used to fix the ifFalse jump after each + * test when its target PC is determined. */ + JumpFixupArray jumpEndFixupArray; + /* Used to fix the jump after each "then" body + * to the end of the "if" when that PC is + * determined. */ + Tcl_Token *tokenPtr, *testTokenPtr; + int jumpIndex = 0; /* Avoid compiler warning. */ + int jumpFalseDist, numWords, wordIdx, numBytes, j, code; + const char *word; + int realCond = 1; /* Set to 0 for static conditions: + * "if 0 {..}" */ + int boolVal; /* Value of static condition. */ + int compileScripts = 1; + DefineLineInformation; /* TIP #280 */ + + /* + * Only compile the "if" command if all arguments are simple words, in + * order to insure correct substitution [Bug 219166] + */ + + tokenPtr = parsePtr->tokenPtr; + wordIdx = 0; + numWords = parsePtr->numWords; + + for (wordIdx = 0; wordIdx < numWords; wordIdx++) { + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(tokenPtr); + } + + TclInitJumpFixupArray(&jumpFalseFixupArray); + TclInitJumpFixupArray(&jumpEndFixupArray); + code = TCL_OK; + + /* + * Each iteration of this loop compiles one "if expr ?then? body" or + * "elseif expr ?then? body" clause. + */ + + tokenPtr = parsePtr->tokenPtr; + wordIdx = 0; + while (wordIdx < numWords) { + /* + * Stop looping if the token isn't "if" or "elseif". + */ + + word = tokenPtr[1].start; + numBytes = tokenPtr[1].size; + if ((tokenPtr == parsePtr->tokenPtr) + || ((numBytes == 6) && (strncmp(word, "elseif", 6) == 0))) { + tokenPtr = TokenAfter(tokenPtr); + wordIdx++; + } else { + break; + } + if (wordIdx >= numWords) { + code = TCL_ERROR; + goto done; + } + + /* + * Compile the test expression then emit the conditional jump around + * the "then" part. + */ + + testTokenPtr = tokenPtr; + + if (realCond) { + /* + * Find out if the condition is a constant. + */ + + Tcl_Obj *boolObj = Tcl_NewStringObj(testTokenPtr[1].start, + testTokenPtr[1].size); + + Tcl_IncrRefCount(boolObj); + code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal); + TclDecrRefCount(boolObj); + if (code == TCL_OK) { + /* + * A static condition. + */ + + realCond = 0; + if (!boolVal) { + compileScripts = 0; + } + } else { + SetLineInformation(wordIdx); + Tcl_ResetResult(interp); + TclCompileExprWords(interp, testTokenPtr, 1, envPtr); + TclClearNumConversion(envPtr); + if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { + TclExpandJumpFixupArray(&jumpFalseFixupArray); + } + jumpIndex = jumpFalseFixupArray.next; + jumpFalseFixupArray.next++; + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, + jumpFalseFixupArray.fixup+jumpIndex); + } + code = TCL_OK; + } + + /* + * Skip over the optional "then" before the then clause. + */ + + tokenPtr = TokenAfter(testTokenPtr); + wordIdx++; + if (wordIdx >= numWords) { + code = TCL_ERROR; + goto done; + } + if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + word = tokenPtr[1].start; + numBytes = tokenPtr[1].size; + if ((numBytes == 4) && (strncmp(word, "then", 4) == 0)) { + tokenPtr = TokenAfter(tokenPtr); + wordIdx++; + if (wordIdx >= numWords) { + code = TCL_ERROR; + goto done; + } + } + } + + /* + * Compile the "then" command body. + */ + + if (compileScripts) { + BODY(tokenPtr, wordIdx); + } + + if (realCond) { + /* + * Jump to the end of the "if" command. Both jumpFalseFixupArray + * and jumpEndFixupArray are indexed by "jumpIndex". + */ + + if (jumpEndFixupArray.next >= jumpEndFixupArray.end) { + TclExpandJumpFixupArray(&jumpEndFixupArray); + } + jumpEndFixupArray.next++; + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, + jumpEndFixupArray.fixup+jumpIndex); + + /* + * Fix the target of the jumpFalse after the test. Generate a 4 + * byte jump if the distance is > 120 bytes. This is conservative, + * and ensures that we won't have to replace this jump if we later + * also need to replace the proceeding jump to the end of the "if" + * with a 4 byte jump. + */ + + TclAdjustStackDepth(-1, envPtr); + if (TclFixupForwardJumpToHere(envPtr, + jumpFalseFixupArray.fixup+jumpIndex, 120)) { + /* + * Adjust the code offset for the proceeding jump to the end + * of the "if" command. + */ + + jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3; + } + } else if (boolVal) { + /* + * We were processing an "if 1 {...}"; stop compiling scripts. + */ + + compileScripts = 0; + } else { + /* + * We were processing an "if 0 {...}"; reset so that the rest + * (elseif, else) is compiled correctly. + */ + + realCond = 1; + compileScripts = 1; + } + + tokenPtr = TokenAfter(tokenPtr); + wordIdx++; + } + + /* + * Check for the optional else clause. Do not compile anything if this was + * an "if 1 {...}" case. + */ + + if ((wordIdx < numWords) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) { + /* + * There is an else clause. Skip over the optional "else" word. + */ + + word = tokenPtr[1].start; + numBytes = tokenPtr[1].size; + if ((numBytes == 4) && (strncmp(word, "else", 4) == 0)) { + tokenPtr = TokenAfter(tokenPtr); + wordIdx++; + if (wordIdx >= numWords) { + code = TCL_ERROR; + goto done; + } + } + + if (compileScripts) { + /* + * Compile the else command body. + */ + + BODY(tokenPtr, wordIdx); + } + + /* + * Make sure there are no words after the else clause. + */ + + wordIdx++; + if (wordIdx < numWords) { + code = TCL_ERROR; + goto done; + } + } else { + /* + * No else clause: the "if" command's result is an empty string. + */ + + if (compileScripts) { + PushStringLiteral(envPtr, ""); + } + } + + /* + * Fix the unconditional jumps to the end of the "if" command. + */ + + for (j = jumpEndFixupArray.next; j > 0; j--) { + jumpIndex = (j - 1); /* i.e. process the closest jump first. */ + if (TclFixupForwardJumpToHere(envPtr, + jumpEndFixupArray.fixup+jumpIndex, 127)) { + /* + * Adjust the immediately preceeding "ifFalse" jump. We moved it's + * target (just after this jump) down three bytes. + */ + + unsigned char *ifFalsePc = envPtr->codeStart + + jumpFalseFixupArray.fixup[jumpIndex].codeOffset; + unsigned char opCode = *ifFalsePc; + + if (opCode == INST_JUMP_FALSE1) { + jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1); + jumpFalseDist += 3; + TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1)); + } else if (opCode == INST_JUMP_FALSE4) { + jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1); + jumpFalseDist += 3; + TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1)); + } else { + Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", (int) opCode); + } + } + } + + /* + * Free the jumpFixupArray array if malloc'ed storage was used. + */ + + done: + TclFreeJumpFixupArray(&jumpFalseFixupArray); + TclFreeJumpFixupArray(&jumpEndFixupArray); + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileIncrCmd -- + * + * Procedure called to compile the "incr" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "incr" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileIncrCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *varTokenPtr, *incrTokenPtr; + int isScalar, localIndex, haveImmValue, immValue; + DefineLineInformation; /* TIP #280 */ + + if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) { + return TCL_ERROR; + } + + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + + PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_LARGE_INDEX, + &localIndex, &isScalar, 1); + + /* + * If an increment is given, push it, but see first if it's a small + * integer. + */ + + haveImmValue = 0; + immValue = 1; + if (parsePtr->numWords == 3) { + incrTokenPtr = TokenAfter(varTokenPtr); + if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + const char *word = incrTokenPtr[1].start; + int numBytes = incrTokenPtr[1].size; + int code; + Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes); + + Tcl_IncrRefCount(intObj); + code = TclGetIntFromObj(NULL, intObj, &immValue); + TclDecrRefCount(intObj); + if ((code == TCL_OK) && (-127 <= immValue) && (immValue <= 127)) { + haveImmValue = 1; + } + if (!haveImmValue) { + PushLiteral(envPtr, word, numBytes); + } + } else { + SetLineInformation(2); + CompileTokens(envPtr, incrTokenPtr, interp); + TclClearNumConversion(envPtr); + } + } else { /* No incr amount given so use 1. */ + haveImmValue = 1; + } + + /* + * Emit the instruction to increment the variable. + */ + + if (isScalar) { /* Simple scalar variable. */ + if (localIndex >= 0) { + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, envPtr); + TclEmitInt1(immValue, envPtr); + } else { + TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr); + } + } else { + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_STK_IMM, immValue, envPtr); + } else { + TclEmitOpcode( INST_INCR_STK, envPtr); + } + } + } else { /* Simple array variable. */ + if (localIndex >= 0) { + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex, envPtr); + TclEmitInt1(immValue, envPtr); + } else { + TclEmitInstInt1(INST_INCR_ARRAY1, localIndex, envPtr); + } + } else { + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue, envPtr); + } else { + TclEmitOpcode( INST_INCR_ARRAY_STK, envPtr); + } + } + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileInfo*Cmd -- + * + * Procedures called to compile "info" subcommands. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "info" subcommand at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileInfoCommandsCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr; + Tcl_Obj *objPtr; + char *bytes; + + /* + * We require one compile-time known argument for the case we can compile. + */ + + if (parsePtr->numWords == 1) { + return TclCompileBasic0ArgCmd(interp, parsePtr, cmdPtr, envPtr); + } else if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(parsePtr->tokenPtr); + objPtr = Tcl_NewObj(); + Tcl_IncrRefCount(objPtr); + if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) { + goto notCompilable; + } + bytes = Tcl_GetString(objPtr); + + /* + * We require that the argument start with "::" and not have any of "*\[?" + * in it. (Theoretically, we should look in only the final component, but + * the difference is so slight given current naming practices.) + */ + + if (bytes[0] != ':' || bytes[1] != ':' || !TclMatchIsTrivial(bytes)) { + goto notCompilable; + } + Tcl_DecrRefCount(objPtr); + + /* + * Confirmed as a literal that will not frighten the horses. Compile. Note + * that the result needs to be list-ified. + */ + + /* TODO: Just push the known value */ + CompileWord(envPtr, tokenPtr, interp, 1); + TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr); + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_STR_LEN, envPtr); + TclEmitInstInt1( INST_JUMP_FALSE1, 7, envPtr); + TclEmitInstInt4( INST_LIST, 1, envPtr); + return TCL_OK; + + notCompilable: + Tcl_DecrRefCount(objPtr); + return TclCompileBasic1ArgCmd(interp, parsePtr, cmdPtr, envPtr); +} + +int +TclCompileInfoCoroutineCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * Only compile [info coroutine] without arguments. + */ + + if (parsePtr->numWords != 1) { + return TCL_ERROR; + } + + /* + * Not much to do; we compile to a single instruction... + */ + + TclEmitOpcode( INST_COROUTINE_NAME, envPtr); + return TCL_OK; +} + +int +TclCompileInfoExistsCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr; + int isScalar, localIndex; + DefineLineInformation; /* TIP #280 */ + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + + /* + * Decide if we can use a frame slot for the var/array name or if we need + * to emit code to compute and push the name at runtime. We use a frame + * slot (entry in the array of local vars) if we are compiling a procedure + * body and if the name is simple text that does not include namespace + * qualifiers. + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex, &isScalar, 1); + + /* + * Emit instruction to check the variable for existence. + */ + + if (isScalar) { + if (localIndex < 0) { + TclEmitOpcode( INST_EXIST_STK, envPtr); + } else { + TclEmitInstInt4( INST_EXIST_SCALAR, localIndex, envPtr); + } + } else { + if (localIndex < 0) { + TclEmitOpcode( INST_EXIST_ARRAY_STK, envPtr); + } else { + TclEmitInstInt4( INST_EXIST_ARRAY, localIndex, envPtr); + } + } + + return TCL_OK; +} + +int +TclCompileInfoLevelCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * Only compile [info level] without arguments or with a single argument. + */ + + if (parsePtr->numWords == 1) { + /* + * Not much to do; we compile to a single instruction... + */ + + TclEmitOpcode( INST_INFO_LEVEL_NUM, envPtr); + } else if (parsePtr->numWords != 2) { + return TCL_ERROR; + } else { + DefineLineInformation; /* TIP #280 */ + + /* + * Compile the argument, then add the instruction to convert it into a + * list of arguments. + */ + + CompileWord(envPtr, TokenAfter(parsePtr->tokenPtr), interp, 1); + TclEmitOpcode( INST_INFO_LEVEL_ARGS, envPtr); + } + return TCL_OK; +} + +int +TclCompileInfoObjectClassCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + CompileWord(envPtr, tokenPtr, interp, 1); + TclEmitOpcode( INST_TCLOO_CLASS, envPtr); + return TCL_OK; +} + +int +TclCompileInfoObjectIsACmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); + + /* + * We only handle [info object isa object <somevalue>]. The first three + * words are compressed to a single token by the ensemble compilation + * engine. + */ + + if (parsePtr->numWords != 3) { + return TCL_ERROR; + } + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size < 1 + || strncmp(tokenPtr[1].start, "object", tokenPtr[1].size)) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(tokenPtr); + + /* + * Issue the code. + */ + + CompileWord(envPtr, tokenPtr, interp, 2); + TclEmitOpcode( INST_TCLOO_IS_OBJECT, envPtr); + return TCL_OK; +} + +int +TclCompileInfoObjectNamespaceCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + CompileWord(envPtr, tokenPtr, interp, 1); + TclEmitOpcode( INST_TCLOO_NS, envPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileLappendCmd -- + * + * Procedure called to compile the "lappend" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "lappend" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLappendCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *varTokenPtr, *valueTokenPtr; + int isScalar, localIndex, numWords, i, fwd, offsetFwd; + DefineLineInformation; /* TIP #280 */ + + /* + * If we're not in a procedure, don't compile. + */ + + if (envPtr->procPtr == NULL) { + return TCL_ERROR; + } + + /* TODO: Consider support for compiling expanded args. */ + numWords = parsePtr->numWords; + if (numWords == 1) { + return TCL_ERROR; + } + if (numWords != 3) { + /* + * LAPPEND instructions currently only handle one value, but we can + * handle some multi-value cases by stringing them together. + */ + + goto lappendMultiple; + } + + /* + * Decide if we can use a frame slot for the var/array name or if we + * need to emit code to compute and push the name at runtime. We use a + * frame slot (entry in the array of local vars) if we are compiling a + * procedure body and if the name is simple text that does not include + * namespace qualifiers. + */ + + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + + PushVarNameWord(interp, varTokenPtr, envPtr, 0, + &localIndex, &isScalar, 1); + + /* + * If we are doing an assignment, push the new value. In the no values + * case, create an empty object. + */ + + if (numWords > 2) { + Tcl_Token *valueTokenPtr = TokenAfter(varTokenPtr); + + CompileWord(envPtr, valueTokenPtr, interp, 2); + } + + /* + * Emit instructions to set/get the variable. + */ + + /* + * The *_STK opcodes should be refactored to make better use of existing + * LOAD/STORE instructions. + */ + + if (isScalar) { + if (localIndex < 0) { + TclEmitOpcode( INST_LAPPEND_STK, envPtr); + } else { + Emit14Inst( INST_LAPPEND_SCALAR, localIndex, envPtr); + } + } else { + if (localIndex < 0) { + TclEmitOpcode( INST_LAPPEND_ARRAY_STK, envPtr); + } else { + Emit14Inst( INST_LAPPEND_ARRAY, localIndex, envPtr); + } + } + + return TCL_OK; + + lappendMultiple: + /* + * Can only handle the case where we are appending to a local scalar when + * there are multiple values to append. Fortunately, this is common. + */ + + if (envPtr->procPtr == NULL) { + return TCL_ERROR; + } + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT, + &localIndex, &isScalar, 1); + if (!isScalar || localIndex < 0) { + return TCL_ERROR; + } + + /* + * Definitely appending to a local scalar; generate the words and append + * them. + */ + + valueTokenPtr = TokenAfter(varTokenPtr); + for (i = 2 ; i < numWords ; i++) { + CompileWord(envPtr, valueTokenPtr, interp, i); + valueTokenPtr = TokenAfter(valueTokenPtr); + } + TclEmitInstInt4( INST_LIST, numWords-2, envPtr); + TclEmitInstInt4( INST_EXIST_SCALAR, localIndex, envPtr); + offsetFwd = CurrentOffset(envPtr); + TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr); + Emit14Inst( INST_LOAD_SCALAR, localIndex, envPtr); + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + fwd = CurrentOffset(envPtr) - offsetFwd; + TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); + Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileLassignCmd -- + * + * Procedure called to compile the "lassign" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "lassign" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLassignCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr; + int isScalar, localIndex, numWords, idx; + DefineLineInformation; /* TIP #280 */ + + numWords = parsePtr->numWords; + + /* + * Check for command syntax error, but we'll punt that to runtime. + */ + + if (numWords < 3) { + return TCL_ERROR; + } + + /* + * Generate code to push list being taken apart by [lassign]. + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + + /* + * Generate code to assign values from the list to variables. + */ + + for (idx=0 ; idx<numWords-2 ; idx++) { + tokenPtr = TokenAfter(tokenPtr); + + /* + * Generate the next variable name. + */ + + PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex, + &isScalar, idx+2); + + /* + * Emit instructions to get the idx'th item out of the list value on + * the stack and assign it to the variable. + */ + + if (isScalar) { + if (localIndex >= 0) { + TclEmitOpcode( INST_DUP, envPtr); + TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); + Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); + } else { + TclEmitInstInt4(INST_OVER, 1, envPtr); + TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); + TclEmitOpcode( INST_STORE_STK, envPtr); + TclEmitOpcode( INST_POP, envPtr); + } + } else { + if (localIndex >= 0) { + TclEmitInstInt4(INST_OVER, 1, envPtr); + TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); + Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); + } else { + TclEmitInstInt4(INST_OVER, 2, envPtr); + TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); + TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr); + TclEmitOpcode( INST_POP, envPtr); + } + } + } + + /* + * Generate code to leave the rest of the list on the stack. + */ + + TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr); + TclEmitInt4( INDEX_END, envPtr); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileLindexCmd -- + * + * Procedure called to compile the "lindex" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "lindex" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLindexCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *idxTokenPtr, *valTokenPtr; + int i, idx, numWords = parsePtr->numWords; + DefineLineInformation; /* TIP #280 */ + + /* + * Quit if too few args. + */ + + /* TODO: Consider support for compiling expanded args. */ + if (numWords <= 1) { + return TCL_ERROR; + } + + valTokenPtr = TokenAfter(parsePtr->tokenPtr); + if (numWords != 3) { + goto emitComplexLindex; + } + + idxTokenPtr = TokenAfter(valTokenPtr); + if (GetIndexFromToken(idxTokenPtr, &idx) == TCL_OK) { + /* + * All checks have been completed, and we have exactly one of these + * constructs: + * lindex <arbitraryValue> <posInt> + * lindex <arbitraryValue> end-<posInt> + * This is best compiled as a push of the arbitrary value followed by + * an "immediate lindex" which is the most efficient variety. + */ + + CompileWord(envPtr, valTokenPtr, interp, 1); + TclEmitInstInt4( INST_LIST_INDEX_IMM, idx, envPtr); + return TCL_OK; + } + + /* + * If the value was not known at compile time, the conversion failed or + * the value was negative, we just keep on going with the more complex + * compilation. + */ + + /* + * Push the operands onto the stack. + */ + + emitComplexLindex: + for (i=1 ; i<numWords ; i++) { + CompileWord(envPtr, valTokenPtr, interp, i); + valTokenPtr = TokenAfter(valTokenPtr); + } + + /* + * Emit INST_LIST_INDEX if objc==3, or INST_LIST_INDEX_MULTI if there are + * multiple index args. + */ + + if (numWords == 3) { + TclEmitOpcode( INST_LIST_INDEX, envPtr); + } else { + TclEmitInstInt4( INST_LIST_INDEX_MULTI, numWords-1, envPtr); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileListCmd -- + * + * Procedure called to compile the "list" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "list" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileListCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *valueTokenPtr; + int i, numWords, concat, build; + Tcl_Obj *listObj, *objPtr; + + if (parsePtr->numWords == 1) { + /* + * [list] without arguments just pushes an empty object. + */ + + PushStringLiteral(envPtr, ""); + return TCL_OK; + } + + /* + * Test if all arguments are compile-time known. If they are, we can + * implement with a simple push. + */ + + numWords = parsePtr->numWords; + valueTokenPtr = TokenAfter(parsePtr->tokenPtr); + listObj = Tcl_NewObj(); + for (i = 1; i < numWords && listObj != NULL; i++) { + objPtr = Tcl_NewObj(); + if (TclWordKnownAtCompileTime(valueTokenPtr, objPtr)) { + (void) Tcl_ListObjAppendElement(NULL, listObj, objPtr); + } else { + Tcl_DecrRefCount(objPtr); + Tcl_DecrRefCount(listObj); + listObj = NULL; + } + valueTokenPtr = TokenAfter(valueTokenPtr); + } + if (listObj != NULL) { + int len; + const char *bytes = Tcl_GetStringFromObj(listObj, &len); + + PushLiteral(envPtr, bytes, len); + Tcl_DecrRefCount(listObj); + if (len > 0) { + /* + * Force list interpretation! + */ + + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_LIST_LENGTH, envPtr); + TclEmitOpcode( INST_POP, envPtr); + } + return TCL_OK; + } + + /* + * Push the all values onto the stack. + */ + + numWords = parsePtr->numWords; + valueTokenPtr = TokenAfter(parsePtr->tokenPtr); + concat = build = 0; + for (i = 1; i < numWords; i++) { + if (valueTokenPtr->type == TCL_TOKEN_EXPAND_WORD && build > 0) { + TclEmitInstInt4( INST_LIST, build, envPtr); + if (concat) { + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + } + build = 0; + concat = 1; + } + CompileWord(envPtr, valueTokenPtr, interp, i); + if (valueTokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + if (concat) { + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + } else { + concat = 1; + } + } else { + build++; + } + valueTokenPtr = TokenAfter(valueTokenPtr); + } + if (build > 0) { + TclEmitInstInt4( INST_LIST, build, envPtr); + if (concat) { + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + } + } + + /* + * If there was just one expanded word, we must ensure that it is a list + * at this point. We use an [lrange ... 0 end] for this (instead of + * [llength], as with literals) as we must drop any string representation + * that might be hanging around. + */ + + if (concat && numWords == 2) { + TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); + TclEmitInt4( INDEX_END, envPtr); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileLlengthCmd -- + * + * Procedure called to compile the "llength" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "llength" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLlengthCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *varTokenPtr; + DefineLineInformation; /* TIP #280 */ + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + + CompileWord(envPtr, varTokenPtr, interp, 1); + TclEmitOpcode( INST_LIST_LENGTH, envPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileLrangeCmd -- + * + * How to compile the "lrange" command. We only bother because we needed + * the opcode anyway for "lassign". + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLrangeCmd( + Tcl_Interp *interp, /* Tcl interpreter for context. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the + * command. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds the resulting instructions. */ +{ + Tcl_Token *tokenPtr, *listTokenPtr; + DefineLineInformation; /* TIP #280 */ + int idx1, idx2; + + if (parsePtr->numWords != 4) { + return TCL_ERROR; + } + listTokenPtr = TokenAfter(parsePtr->tokenPtr); + + /* + * Parse the indices. Will only compile if both are constants and not an + * _integer_ less than zero (since we reserve negative indices here for + * end-relative indexing) or an end-based index greater than 'end' itself. + */ + + tokenPtr = TokenAfter(listTokenPtr); + if (GetIndexFromToken(tokenPtr, &idx1) != TCL_OK) { + return TCL_ERROR; + } + + tokenPtr = TokenAfter(tokenPtr); + if (GetIndexFromToken(tokenPtr, &idx2) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Issue instructions. It's not safe to skip doing the LIST_RANGE, as + * we've not proved that the 'list' argument is really a list. Not that it + * is worth trying to do that given current knowledge. + */ + + CompileWord(envPtr, listTokenPtr, interp, 1); + TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr); + TclEmitInt4( idx2, envPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileLinsertCmd -- + * + * How to compile the "linsert" command. We only bother with the case + * where the index is constant. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLinsertCmd( + Tcl_Interp *interp, /* Tcl interpreter for context. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the + * command. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds the resulting instructions. */ +{ + Tcl_Token *tokenPtr, *listTokenPtr; + DefineLineInformation; /* TIP #280 */ + int idx, i; + + if (parsePtr->numWords < 3) { + return TCL_ERROR; + } + listTokenPtr = TokenAfter(parsePtr->tokenPtr); + + /* + * Parse the index. Will only compile if it is constant and not an + * _integer_ less than zero (since we reserve negative indices here for + * end-relative indexing) or an end-based index greater than 'end' itself. + */ + + tokenPtr = TokenAfter(listTokenPtr); + if (GetIndexFromToken(tokenPtr, &idx) != TCL_OK) { + return TCL_ERROR; + } + + /* + * There are four main cases. If there are no values to insert, this is + * just a confirm-listiness check. If the index is '0', this is a prepend. + * If the index is 'end' (== INDEX_END), this is an append. Otherwise, + * this is a splice (== split, insert values as list, concat-3). + */ + + CompileWord(envPtr, listTokenPtr, interp, 1); + if (parsePtr->numWords == 3) { + TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); + TclEmitInt4( INDEX_END, envPtr); + return TCL_OK; + } + + for (i=3 ; i<parsePtr->numWords ; i++) { + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, i); + } + TclEmitInstInt4( INST_LIST, i-3, envPtr); + + if (idx == 0 /*start*/) { + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + } else if (idx == INDEX_END /*end*/) { + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + } else { + if (idx < 0) { + idx++; + } + TclEmitInstInt4( INST_OVER, 1, envPtr); + TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); + TclEmitInt4( idx-1, envPtr); + TclEmitInstInt4( INST_REVERSE, 3, envPtr); + TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr); + TclEmitInt4( INDEX_END, envPtr); + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileLreplaceCmd -- + * + * How to compile the "lreplace" command. We only bother with the case + * where the indices are constant. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLreplaceCmd( + Tcl_Interp *interp, /* Tcl interpreter for context. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the + * command. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds the resulting instructions. */ +{ + Tcl_Token *tokenPtr, *listTokenPtr; + DefineLineInformation; /* TIP #280 */ + Tcl_Obj *tmpObj; + int idx1, idx2, i, offset; + + if (parsePtr->numWords < 4) { + return TCL_ERROR; + } + listTokenPtr = TokenAfter(parsePtr->tokenPtr); + + /* + * Parse the indices. Will only compile if both are constants and not an + * _integer_ less than zero (since we reserve negative indices here for + * end-relative indexing) or an end-based index greater than 'end' itself. + */ + + tokenPtr = TokenAfter(listTokenPtr); + if (GetIndexFromToken(tokenPtr, &idx1) != TCL_OK) { + return TCL_ERROR; + } + + tokenPtr = TokenAfter(tokenPtr); + if (GetIndexFromToken(tokenPtr, &idx2) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Work out what this [lreplace] is actually doing. + */ + + tmpObj = NULL; + CompileWord(envPtr, listTokenPtr, interp, 1); + if (parsePtr->numWords == 4) { + if (idx1 == 0) { + if (idx2 == INDEX_END) { + goto dropAll; + } + idx1 = idx2 + 1; + idx2 = INDEX_END; + goto dropEnd; + } else if (idx2 == INDEX_END) { + idx2 = idx1 - 1; + idx1 = 0; + goto dropEnd; + } else { + if (idx1 > 0) { + tmpObj = Tcl_NewIntObj(idx1); + Tcl_IncrRefCount(tmpObj); + } + goto dropRange; + } + } + + tokenPtr = TokenAfter(tokenPtr); + for (i=4 ; i<parsePtr->numWords ; i++) { + CompileWord(envPtr, tokenPtr, interp, i); + tokenPtr = TokenAfter(tokenPtr); + } + TclEmitInstInt4( INST_LIST, i - 4, envPtr); + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + if (idx1 == 0) { + if (idx2 == INDEX_END) { + goto replaceAll; + } + idx1 = idx2 + 1; + idx2 = INDEX_END; + goto replaceHead; + } else if (idx2 == INDEX_END) { + idx2 = idx1 - 1; + idx1 = 0; + goto replaceTail; + } else { + if (idx1 > 0 && idx2 > 0 && idx2 < idx1) { + idx2 = idx1 - 1; + } else if (idx1 < 0 && idx2 < 0 && idx2 < idx1) { + idx2 = idx1 - 1; + } + if (idx1 > 0) { + tmpObj = Tcl_NewIntObj(idx1); + Tcl_IncrRefCount(tmpObj); + } + goto replaceRange; + } + + /* + * Issue instructions to perform the operations relating to configurations + * that just drop. The only argument pushed on the stack is the list to + * operate on. + */ + + dropAll: + TclEmitOpcode( INST_LIST_LENGTH, envPtr); + TclEmitOpcode( INST_POP, envPtr); + PushStringLiteral(envPtr, ""); + goto done; + + dropEnd: + TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr); + TclEmitInt4( idx2, envPtr); + goto done; + + dropRange: + if (tmpObj != NULL) { + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_LIST_LENGTH, envPtr); + TclEmitPush(TclAddLiteralObj(envPtr, tmpObj, NULL), envPtr); + TclEmitOpcode( INST_GT, envPtr); + offset = CurrentOffset(envPtr); + TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr); + TclEmitPush(TclAddLiteralObj(envPtr, Tcl_ObjPrintf( + "list doesn't contain element %d", idx1), NULL), envPtr); + CompileReturnInternal(envPtr, INST_RETURN_IMM, TCL_ERROR, 0, + Tcl_ObjPrintf("-errorcode {TCL OPERATION LREPLACE BADIDX}")); + TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset, + envPtr->codeStart + offset + 1); + TclAdjustStackDepth(-1, envPtr); + } + TclEmitOpcode( INST_DUP, envPtr); + TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); + TclEmitInt4( idx1 - 1, envPtr); + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitInstInt4( INST_LIST_RANGE_IMM, idx2 + 1, envPtr); + TclEmitInt4( INDEX_END, envPtr); + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + goto done; + + /* + * Issue instructions to perform the operations relating to configurations + * that do real replacement. All arguments are pushed and assembled into a + * pair: the list of values to replace with, and the list to do the + * surgery on. + */ + + replaceAll: + TclEmitOpcode( INST_LIST_LENGTH, envPtr); + TclEmitOpcode( INST_POP, envPtr); + goto done; + + replaceHead: + TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr); + TclEmitInt4( idx2, envPtr); + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + goto done; + + replaceTail: + TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr); + TclEmitInt4( idx2, envPtr); + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + goto done; + + replaceRange: + if (tmpObj != NULL) { + TclEmitOpcode( INST_DUP, envPtr); + TclEmitOpcode( INST_LIST_LENGTH, envPtr); + TclEmitPush(TclAddLiteralObj(envPtr, tmpObj, NULL), envPtr); + TclEmitOpcode( INST_GT, envPtr); + offset = CurrentOffset(envPtr); + TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr); + TclEmitPush(TclAddLiteralObj(envPtr, Tcl_ObjPrintf( + "list doesn't contain element %d", idx1), NULL), envPtr); + CompileReturnInternal(envPtr, INST_RETURN_IMM, TCL_ERROR, 0, + Tcl_ObjPrintf("-errorcode {TCL OPERATION LREPLACE BADIDX}")); + TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset, + envPtr->codeStart + offset + 1); + TclAdjustStackDepth(-1, envPtr); + } + TclEmitOpcode( INST_DUP, envPtr); + TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); + TclEmitInt4( idx1 - 1, envPtr); + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitInstInt4( INST_LIST_RANGE_IMM, idx2 + 1, envPtr); + TclEmitInt4( INDEX_END, envPtr); + TclEmitInstInt4( INST_REVERSE, 3, envPtr); + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitOpcode( INST_LIST_CONCAT, envPtr); + goto done; + + /* + * Clean up the allocated memory. + */ + + done: + if (tmpObj != NULL) { + Tcl_DecrRefCount(tmpObj); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileLsetCmd -- + * + * Procedure called to compile the "lset" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "lset" command at + * runtime. + * + * The general template for execution of the "lset" command is: + * (1) Instructions to push the variable name, unless the variable is + * local to the stack frame. + * (2) If the variable is an array element, instructions to push the + * array element name. + * (3) Instructions to push each of zero or more "index" arguments to the + * stack, followed with the "newValue" element. + * (4) Instructions to duplicate the variable name and/or array element + * name onto the top of the stack, if either was pushed at steps (1) + * and (2). + * (5) The appropriate INST_LOAD_* instruction to place the original + * value of the list variable at top of stack. + * (6) At this point, the stack contains: + * varName? arrayElementName? index1 index2 ... newValue oldList + * The compiler emits one of INST_LSET_FLAT or INST_LSET_LIST + * according as whether there is exactly one index element (LIST) or + * either zero or else two or more (FLAT). This instruction removes + * everything from the stack except for the two names and pushes the + * new value of the variable. + * (7) Finally, INST_STORE_* stores the new value in the variable and + * cleans up the stack. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLsetCmd( + Tcl_Interp *interp, /* Tcl interpreter for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the + * command. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds the resulting instructions. */ +{ + int tempDepth; /* Depth used for emitting one part of the + * code burst. */ + Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the + * parse of the variable name. */ + int localIndex; /* Index of var in local var table. */ + int isScalar; /* Flag == 1 if scalar, 0 if array. */ + int i; + DefineLineInformation; /* TIP #280 */ + + /* + * Check argument count. + */ + + /* TODO: Consider support for compiling expanded args. */ + if (parsePtr->numWords < 3) { + /* + * Fail at run time, not in compilation. + */ + + return TCL_ERROR; + } + + /* + * Decide if we can use a frame slot for the var/array name or if we need + * to emit code to compute and push the name at runtime. We use a frame + * slot (entry in the array of local vars) if we are compiling a procedure + * body and if the name is simple text that does not include namespace + * qualifiers. + */ + + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + PushVarNameWord(interp, varTokenPtr, envPtr, 0, + &localIndex, &isScalar, 1); + + /* + * Push the "index" args and the new element value. + */ + + for (i=2 ; i<parsePtr->numWords ; ++i) { + varTokenPtr = TokenAfter(varTokenPtr); + CompileWord(envPtr, varTokenPtr, interp, i); + } + + /* + * Duplicate the variable name if it's been pushed. + */ + + if (localIndex < 0) { + if (isScalar) { + tempDepth = parsePtr->numWords - 2; + } else { + tempDepth = parsePtr->numWords - 1; + } + TclEmitInstInt4( INST_OVER, tempDepth, envPtr); + } + + /* + * Duplicate an array index if one's been pushed. + */ + + if (!isScalar) { + if (localIndex < 0) { + tempDepth = parsePtr->numWords - 1; + } else { + tempDepth = parsePtr->numWords - 2; + } + TclEmitInstInt4( INST_OVER, tempDepth, envPtr); + } + + /* + * Emit code to load the variable's value. + */ + + if (isScalar) { + if (localIndex < 0) { + TclEmitOpcode( INST_LOAD_STK, envPtr); + } else { + Emit14Inst( INST_LOAD_SCALAR, localIndex, envPtr); + } + } else { + if (localIndex < 0) { + TclEmitOpcode( INST_LOAD_ARRAY_STK, envPtr); + } else { + Emit14Inst( INST_LOAD_ARRAY, localIndex, envPtr); + } + } + + /* + * Emit the correct variety of 'lset' instruction. + */ + + if (parsePtr->numWords == 4) { + TclEmitOpcode( INST_LSET_LIST, envPtr); + } else { + TclEmitInstInt4( INST_LSET_FLAT, parsePtr->numWords-1, envPtr); + } + + /* + * Emit code to put the value back in the variable. + */ + + if (isScalar) { + if (localIndex < 0) { + TclEmitOpcode( INST_STORE_STK, envPtr); + } else { + Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); + } + } else { + if (localIndex < 0) { + TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr); + } else { + Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); + } + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileNamespace*Cmd -- + * + * Procedures called to compile the "namespace" command; currently, only + * the subcommands "namespace current" and "namespace upvar" are compiled + * to bytecodes, and the latter only inside a procedure(-like) context. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "namespace upvar" + * command at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileNamespaceCurrentCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * Only compile [namespace current] without arguments. + */ + + if (parsePtr->numWords != 1) { + return TCL_ERROR; + } + + /* + * Not much to do; we compile to a single instruction... + */ + + TclEmitOpcode( INST_NS_CURRENT, envPtr); + return TCL_OK; +} + +int +TclCompileNamespaceCodeCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(parsePtr->tokenPtr); + + /* + * The specification of [namespace code] is rather shocking, in that it is + * supposed to check if the argument is itself the result of [namespace + * code] and not apply itself in that case. Which is excessively cautious, + * but what the test suite checks for. + */ + + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || (tokenPtr[1].size > 20 + && strncmp(tokenPtr[1].start, "::namespace inscope ", 20) == 0)) { + /* + * Technically, we could just pass a literal '::namespace inscope ' + * term through, but that's something which really shouldn't be + * occurring as something that the user writes so we'll just punt it. + */ + + return TCL_ERROR; + } + + /* + * Now we can compile using the same strategy as [namespace code]'s normal + * implementation does internally. Note that we can't bind the namespace + * name directly here, because TclOO plays complex games with namespaces; + * the value needs to be determined at runtime for safety. + */ + + PushStringLiteral(envPtr, "::namespace"); + PushStringLiteral(envPtr, "inscope"); + TclEmitOpcode( INST_NS_CURRENT, envPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + TclEmitInstInt4( INST_LIST, 4, envPtr); + return TCL_OK; +} + +int +TclCompileNamespaceOriginCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(parsePtr->tokenPtr); + + CompileWord(envPtr, tokenPtr, interp, 1); + TclEmitOpcode( INST_ORIGIN_COMMAND, envPtr); + return TCL_OK; +} + +int +TclCompileNamespaceQualifiersCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); + DefineLineInformation; /* TIP #280 */ + int off; + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + + CompileWord(envPtr, tokenPtr, interp, 1); + PushStringLiteral(envPtr, "0"); + PushStringLiteral(envPtr, "::"); + TclEmitInstInt4( INST_OVER, 2, envPtr); + TclEmitOpcode( INST_STR_FIND_LAST, envPtr); + off = CurrentOffset(envPtr); + PushStringLiteral(envPtr, "1"); + TclEmitOpcode( INST_SUB, envPtr); + TclEmitInstInt4( INST_OVER, 2, envPtr); + TclEmitInstInt4( INST_OVER, 1, envPtr); + TclEmitOpcode( INST_STR_INDEX, envPtr); + PushStringLiteral(envPtr, ":"); + TclEmitOpcode( INST_STR_EQ, envPtr); + off = off - CurrentOffset(envPtr); + TclEmitInstInt1( INST_JUMP_TRUE1, off, envPtr); + TclEmitOpcode( INST_STR_RANGE, envPtr); + return TCL_OK; +} + +int +TclCompileNamespaceTailCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); + DefineLineInformation; /* TIP #280 */ + JumpFixup jumpFixup; + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + + /* + * Take care; only add 2 to found index if the string was actually found. + */ + + CompileWord(envPtr, tokenPtr, interp, 1); + PushStringLiteral(envPtr, "::"); + TclEmitInstInt4( INST_OVER, 1, envPtr); + TclEmitOpcode( INST_STR_FIND_LAST, envPtr); + TclEmitOpcode( INST_DUP, envPtr); + PushStringLiteral(envPtr, "0"); + TclEmitOpcode( INST_GE, envPtr); + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFixup); + PushStringLiteral(envPtr, "2"); + TclEmitOpcode( INST_ADD, envPtr); + TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127); + PushStringLiteral(envPtr, "end"); + TclEmitOpcode( INST_STR_RANGE, envPtr); + return TCL_OK; +} + +int +TclCompileNamespaceUpvarCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; + int isScalar, localIndex, numWords, i; + DefineLineInformation; /* TIP #280 */ + + if (envPtr->procPtr == NULL) { + return TCL_ERROR; + } + + /* + * Only compile [namespace upvar ...]: needs an even number of args, >=4 + */ + + numWords = parsePtr->numWords; + if ((numWords % 2) || (numWords < 4)) { + return TCL_ERROR; + } + + /* + * Push the namespace + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + + /* + * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a + * local variable, return an error so that the non-compiled command will + * be called at runtime. + */ + + localTokenPtr = tokenPtr; + for (i=2; i<numWords; i+=2) { + otherTokenPtr = TokenAfter(localTokenPtr); + localTokenPtr = TokenAfter(otherTokenPtr); + + CompileWord(envPtr, otherTokenPtr, interp, i); + PushVarNameWord(interp, localTokenPtr, envPtr, 0, + &localIndex, &isScalar, i+1); + + if ((localIndex < 0) || !isScalar) { + return TCL_ERROR; + } + TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr); + } + + /* + * Pop the namespace, and set the result to empty + */ + + TclEmitOpcode( INST_POP, envPtr); + PushStringLiteral(envPtr, ""); + return TCL_OK; +} + +int +TclCompileNamespaceWhichCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr, *opt; + int idx; + + if (parsePtr->numWords < 2 || parsePtr->numWords > 3) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(parsePtr->tokenPtr); + idx = 1; + + /* + * If there's an option, check that it's "-command". We don't handle + * "-variable" (currently) and anything else is an error. + */ + + if (parsePtr->numWords == 3) { + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } + opt = tokenPtr + 1; + if (opt->size < 2 || opt->size > 8 + || strncmp(opt->start, "-command", opt->size) != 0) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(tokenPtr); + idx++; + } + + /* + * Issue the bytecode. + */ + + CompileWord(envPtr, tokenPtr, interp, idx); + TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileRegexpCmd -- + * + * Procedure called to compile the "regexp" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "regexp" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileRegexpCmd( + Tcl_Interp *interp, /* Tcl interpreter for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the + * command. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds the resulting instructions. */ +{ + Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the + * parse of the RE or string. */ + int i, len, nocase, exact, sawLast, simple; + const char *str; + DefineLineInformation; /* TIP #280 */ + + /* + * We are only interested in compiling simple regexp cases. Currently + * supported compile cases are: + * regexp ?-nocase? ?--? staticString $var + * regexp ?-nocase? ?--? {^staticString$} $var + */ + + if (parsePtr->numWords < 3) { + return TCL_ERROR; + } + + simple = 0; + nocase = 0; + sawLast = 0; + varTokenPtr = parsePtr->tokenPtr; + + /* + * We only look for -nocase and -- as options. Everything else gets pushed + * to runtime execution. This is different than regexp's runtime option + * handling, but satisfies our stricter needs. + */ + + for (i = 1; i < parsePtr->numWords - 2; i++) { + varTokenPtr = TokenAfter(varTokenPtr); + if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + /* + * Not a simple string, so punt to runtime. + */ + + return TCL_ERROR; + } + str = varTokenPtr[1].start; + len = varTokenPtr[1].size; + if ((len == 2) && (str[0] == '-') && (str[1] == '-')) { + sawLast++; + i++; + break; + } else if ((len > 1) && (strncmp(str,"-nocase",(unsigned)len) == 0)) { + nocase = 1; + } else { + /* + * Not an option we recognize. + */ + + return TCL_ERROR; + } + } + + if ((parsePtr->numWords - i) != 2) { + /* + * We don't support capturing to variables. + */ + + return TCL_ERROR; + } + + /* + * Get the regexp string. If it is not a simple string or can't be + * converted to a glob pattern, push the word for the INST_REGEXP. + * Keep changes here in sync with TclCompileSwitchCmd Switch_Regexp. + */ + + varTokenPtr = TokenAfter(varTokenPtr); + + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + Tcl_DString ds; + + str = varTokenPtr[1].start; + len = varTokenPtr[1].size; + + /* + * If it has a '-', it could be an incorrectly formed regexp command. + */ + + if ((*str == '-') && !sawLast) { + return TCL_ERROR; + } + + if (len == 0) { + /* + * The semantics of regexp are always match on re == "". + */ + + PushStringLiteral(envPtr, "1"); + return TCL_OK; + } + + /* + * Attempt to convert pattern to glob. If successful, push the + * converted pattern as a literal. + */ + + if (TclReToGlob(NULL, varTokenPtr[1].start, len, &ds, &exact) + == TCL_OK) { + simple = 1; + PushLiteral(envPtr, Tcl_DStringValue(&ds),Tcl_DStringLength(&ds)); + Tcl_DStringFree(&ds); + } + } + + if (!simple) { + CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-2); + } + + /* + * Push the string arg. + */ + + varTokenPtr = TokenAfter(varTokenPtr); + CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-1); + + if (simple) { + if (exact && !nocase) { + TclEmitOpcode( INST_STR_EQ, envPtr); + } else { + TclEmitInstInt1( INST_STR_MATCH, nocase, envPtr); + } + } else { + /* + * Pass correct RE compile flags. We use only Int1 (8-bit), but + * that handles all the flags we want to pass. + * Don't use TCL_REG_NOSUB as we may have backrefs. + */ + + int cflags = TCL_REG_ADVANCED | (nocase ? TCL_REG_NOCASE : 0); + + TclEmitInstInt1( INST_REGEXP, cflags, envPtr); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileRegsubCmd -- + * + * Procedure called to compile the "regsub" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "regsub" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileRegsubCmd( + Tcl_Interp *interp, /* Tcl interpreter for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the + * command. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds the resulting instructions. */ +{ + /* + * We only compile the case with [regsub -all] where the pattern is both + * known at compile time and simple (i.e., no RE metacharacters). That is, + * the pattern must be translatable into a glob like "*foo*" with no other + * glob metacharacters inside it; there must be some "foo" in there too. + * The substitution string must also be known at compile time and free of + * metacharacters ("\digit" and "&"). Finally, there must not be a + * variable mentioned in the [regsub] to write the result back to (because + * we can't get the count of substitutions that would be the result in + * that case). The key is that these are the conditions under which a + * [string map] could be used instead, in particular a [string map] of the + * form we can compile to bytecode. + * + * In short, we look for: + * + * regsub -all [--] simpleRE string simpleReplacement + * + * The only optional part is the "--", and no other options are handled. + */ + + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr, *stringTokenPtr; + Tcl_Obj *patternObj = NULL, *replacementObj = NULL; + Tcl_DString pattern; + const char *bytes; + int len, exact, result = TCL_ERROR; + + if (parsePtr->numWords < 5 || parsePtr->numWords > 6) { + return TCL_ERROR; + } + + /* + * Parse the "-all", which must be the first argument (other options not + * supported, non-"-all" substitution we can't compile). + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size != 4 + || strncmp(tokenPtr[1].start, "-all", 4)) { + return TCL_ERROR; + } + + /* + * Get the pattern into patternObj, checking for "--" in the process. + */ + + Tcl_DStringInit(&pattern); + tokenPtr = TokenAfter(tokenPtr); + patternObj = Tcl_NewObj(); + if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) { + goto done; + } + if (Tcl_GetString(patternObj)[0] == '-') { + if (strcmp(Tcl_GetString(patternObj), "--") != 0 + || parsePtr->numWords == 5) { + goto done; + } + tokenPtr = TokenAfter(tokenPtr); + Tcl_DecrRefCount(patternObj); + patternObj = Tcl_NewObj(); + if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) { + goto done; + } + } else if (parsePtr->numWords == 6) { + goto done; + } + + /* + * Identify the code which produces the string to apply the substitution + * to (stringTokenPtr), and the replacement string (into replacementObj). + */ + + stringTokenPtr = TokenAfter(tokenPtr); + tokenPtr = TokenAfter(stringTokenPtr); + replacementObj = Tcl_NewObj(); + if (!TclWordKnownAtCompileTime(tokenPtr, replacementObj)) { + goto done; + } + + /* + * Next, higher-level checks. Is the RE a very simple glob? Is the + * replacement "simple"? + */ + + bytes = Tcl_GetStringFromObj(patternObj, &len); + if (TclReToGlob(NULL, bytes, len, &pattern, &exact) != TCL_OK || exact) { + goto done; + } + bytes = Tcl_DStringValue(&pattern); + if (*bytes++ != '*') { + goto done; + } + while (1) { + switch (*bytes) { + case '*': + if (bytes[1] == '\0') { + /* + * OK, we've proved there are no metacharacters except for the + * '*' at each end. + */ + + len = Tcl_DStringLength(&pattern) - 2; + if (len > 0) { + goto isSimpleGlob; + } + + /* + * The pattern is "**"! I believe that should be impossible, + * but we definitely can't handle that at all. + */ + } + case '\0': case '?': case '[': case '\\': + goto done; + } + bytes++; + } + isSimpleGlob: + for (bytes = Tcl_GetString(replacementObj); *bytes; bytes++) { + switch (*bytes) { + case '\\': case '&': + goto done; + } + } + + /* + * Proved the simplicity constraints! Time to issue the code. + */ + + result = TCL_OK; + bytes = Tcl_DStringValue(&pattern) + 1; + PushLiteral(envPtr, bytes, len); + bytes = Tcl_GetStringFromObj(replacementObj, &len); + PushLiteral(envPtr, bytes, len); + CompileWord(envPtr, stringTokenPtr, interp, parsePtr->numWords-2); + TclEmitOpcode( INST_STR_MAP, envPtr); + + done: + Tcl_DStringFree(&pattern); + if (patternObj) { + Tcl_DecrRefCount(patternObj); + } + if (replacementObj) { + Tcl_DecrRefCount(replacementObj); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileReturnCmd -- + * + * Procedure called to compile the "return" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "return" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileReturnCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * General syntax: [return ?-option value ...? ?result?] + * An even number of words means an explicit result argument is present. + */ + int level, code, objc, size, status = TCL_OK; + int numWords = parsePtr->numWords; + int explicitResult = (0 == (numWords % 2)); + int numOptionWords = numWords - 1 - explicitResult; + Tcl_Obj *returnOpts, **objv; + Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr); + DefineLineInformation; /* TIP #280 */ + + /* + * Check for special case which can always be compiled: + * return -options <opts> <msg> + * Unlike the normal [return] compilation, this version does everything at + * runtime so it can handle arbitrary words and not just literals. Note + * that if INST_RETURN_STK wasn't already needed for something else + * ('finally' clause processing) this piece of code would not be present. + */ + + if ((numWords == 4) && (wordTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) + && (wordTokenPtr[1].size == 8) + && (strncmp(wordTokenPtr[1].start, "-options", 8) == 0)) { + Tcl_Token *optsTokenPtr = TokenAfter(wordTokenPtr); + Tcl_Token *msgTokenPtr = TokenAfter(optsTokenPtr); + + CompileWord(envPtr, optsTokenPtr, interp, 2); + CompileWord(envPtr, msgTokenPtr, interp, 3); + TclEmitInvoke(envPtr, INST_RETURN_STK); + return TCL_OK; + } + + /* + * Allocate some working space. + */ + + objv = TclStackAlloc(interp, numOptionWords * sizeof(Tcl_Obj *)); + + /* + * Scan through the return options. If any are unknown at compile time, + * there is no value in bytecompiling. Save the option values known in an + * objv array for merging into a return options dictionary. + * + * TODO: There is potential for improvement if all option keys are known + * at compile time and all option values relating to '-code' and '-level' + * are known at compile time. + */ + + for (objc = 0; objc < numOptionWords; objc++) { + objv[objc] = Tcl_NewObj(); + Tcl_IncrRefCount(objv[objc]); + if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) { + /* + * Non-literal, so punt to run-time assembly of the dictionary. + */ + + for (; objc>=0 ; objc--) { + TclDecrRefCount(objv[objc]); + } + TclStackFree(interp, objv); + goto issueRuntimeReturn; + } + wordTokenPtr = TokenAfter(wordTokenPtr); + } + status = TclMergeReturnOptions(interp, objc, objv, + &returnOpts, &code, &level); + while (--objc >= 0) { + TclDecrRefCount(objv[objc]); + } + TclStackFree(interp, objv); + if (TCL_ERROR == status) { + /* + * Something was bogus in the return options. Clear the error message, + * and report back to the compiler that this must be interpreted at + * runtime. + */ + + Tcl_ResetResult(interp); + return TCL_ERROR; + } + + /* + * All options are known at compile time, so we're going to bytecompile. + * Emit instructions to push the result on the stack. + */ + + if (explicitResult) { + CompileWord(envPtr, wordTokenPtr, interp, numWords-1); + } else { + /* + * No explict result argument, so default result is empty string. + */ + + PushStringLiteral(envPtr, ""); + } + + /* + * Check for optimization: When [return] is in a proc, and there's no + * enclosing [catch], and there are no return options, then the INST_DONE + * instruction is equivalent, and may be more efficient. + */ + + if (numOptionWords == 0 && envPtr->procPtr != NULL) { + /* + * We have default return options and we're in a proc ... + */ + + int index = envPtr->exceptArrayNext - 1; + int enclosingCatch = 0; + + while (index >= 0) { + ExceptionRange range = envPtr->exceptArrayPtr[index]; + + if ((range.type == CATCH_EXCEPTION_RANGE) + && (range.catchOffset == -1)) { + enclosingCatch = 1; + break; + } + index--; + } + if (!enclosingCatch) { + /* + * ... and there is no enclosing catch. Issue the maximally + * efficient exit instruction. + */ + + Tcl_DecrRefCount(returnOpts); + TclEmitOpcode(INST_DONE, envPtr); + TclAdjustStackDepth(1, envPtr); + return TCL_OK; + } + } + + /* Optimize [return -level 0 $x]. */ + Tcl_DictObjSize(NULL, returnOpts, &size); + if (size == 0 && level == 0 && code == TCL_OK) { + Tcl_DecrRefCount(returnOpts); + return TCL_OK; + } + + /* + * Could not use the optimization, so we push the return options dict, and + * emit the INST_RETURN_IMM instruction with code and level as operands. + */ + + CompileReturnInternal(envPtr, INST_RETURN_IMM, code, level, returnOpts); + return TCL_OK; + + issueRuntimeReturn: + /* + * Assemble the option dictionary (as a list as that's good enough). + */ + + wordTokenPtr = TokenAfter(parsePtr->tokenPtr); + for (objc=1 ; objc<=numOptionWords ; objc++) { + CompileWord(envPtr, wordTokenPtr, interp, objc); + wordTokenPtr = TokenAfter(wordTokenPtr); + } + TclEmitInstInt4(INST_LIST, numOptionWords, envPtr); + + /* + * Push the result. + */ + + if (explicitResult) { + CompileWord(envPtr, wordTokenPtr, interp, numWords-1); + } else { + PushStringLiteral(envPtr, ""); + } + + /* + * Issue the RETURN itself. + */ + + TclEmitInvoke(envPtr, INST_RETURN_STK); + return TCL_OK; +} + +static void +CompileReturnInternal( + CompileEnv *envPtr, + unsigned char op, + int code, + int level, + Tcl_Obj *returnOpts) +{ + if (level == 0 && (code == TCL_BREAK || code == TCL_CONTINUE)) { + ExceptionRange *rangePtr; + ExceptionAux *exceptAux; + + rangePtr = TclGetInnermostExceptionRange(envPtr, code, &exceptAux); + if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) { + TclCleanupStackForBreakContinue(envPtr, exceptAux); + if (code == TCL_BREAK) { + TclAddLoopBreakFixup(envPtr, exceptAux); + } else { + TclAddLoopContinueFixup(envPtr, exceptAux); + } + Tcl_DecrRefCount(returnOpts); + return; + } + } + + TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr); + TclEmitInstInt4(op, code, envPtr); + TclEmitInt4(level, envPtr); +} + +void +TclCompileSyntaxError( + Tcl_Interp *interp, + CompileEnv *envPtr) +{ + Tcl_Obj *msg = Tcl_GetObjResult(interp); + int numBytes; + const char *bytes = TclGetStringFromObj(msg, &numBytes); + + TclErrorStackResetIf(interp, bytes, numBytes); + TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr); + CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0, + TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR))); + Tcl_ResetResult(interp); +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileUpvarCmd -- + * + * Procedure called to compile the "upvar" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "upvar" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileUpvarCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; + int isScalar, localIndex, numWords, i; + DefineLineInformation; /* TIP #280 */ + Tcl_Obj *objPtr; + + if (envPtr->procPtr == NULL) { + return TCL_ERROR; + } + + numWords = parsePtr->numWords; + if (numWords < 3) { + return TCL_ERROR; + } + + /* + * Push the frame index if it is known at compile time + */ + + objPtr = Tcl_NewObj(); + tokenPtr = TokenAfter(parsePtr->tokenPtr); + if (TclWordKnownAtCompileTime(tokenPtr, objPtr)) { + CallFrame *framePtr; + const Tcl_ObjType *newTypePtr, *typePtr = objPtr->typePtr; + + /* + * Attempt to convert to a level reference. Note that TclObjGetFrame + * only changes the obj type when a conversion was successful. + */ + + TclObjGetFrame(interp, objPtr, &framePtr); + newTypePtr = objPtr->typePtr; + Tcl_DecrRefCount(objPtr); + + if (newTypePtr != typePtr) { + if (numWords%2) { + return TCL_ERROR; + } + /* TODO: Push the known value instead? */ + CompileWord(envPtr, tokenPtr, interp, 1); + otherTokenPtr = TokenAfter(tokenPtr); + i = 2; + } else { + if (!(numWords%2)) { + return TCL_ERROR; + } + PushStringLiteral(envPtr, "1"); + otherTokenPtr = tokenPtr; + i = 1; + } + } else { + Tcl_DecrRefCount(objPtr); + return TCL_ERROR; + } + + /* + * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a + * local variable, return an error so that the non-compiled command will + * be called at runtime. + */ + + for (; i<numWords; i+=2, otherTokenPtr = TokenAfter(localTokenPtr)) { + localTokenPtr = TokenAfter(otherTokenPtr); + + CompileWord(envPtr, otherTokenPtr, interp, i); + PushVarNameWord(interp, localTokenPtr, envPtr, 0, + &localIndex, &isScalar, i+1); + + if ((localIndex < 0) || !isScalar) { + return TCL_ERROR; + } + TclEmitInstInt4( INST_UPVAR, localIndex, envPtr); + } + + /* + * Pop the frame index, and set the result to empty + */ + + TclEmitOpcode( INST_POP, envPtr); + PushStringLiteral(envPtr, ""); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileVariableCmd -- + * + * Procedure called to compile the "variable" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "variable" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileVariableCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *varTokenPtr, *valueTokenPtr; + int localIndex, numWords, i; + DefineLineInformation; /* TIP #280 */ + + numWords = parsePtr->numWords; + if (numWords < 2) { + return TCL_ERROR; + } + + /* + * Bail out if not compiling a proc body + */ + + if (envPtr->procPtr == NULL) { + return TCL_ERROR; + } + + /* + * Loop over the (var, value) pairs. + */ + + valueTokenPtr = parsePtr->tokenPtr; + for (i=1; i<numWords; i+=2) { + varTokenPtr = TokenAfter(valueTokenPtr); + valueTokenPtr = TokenAfter(varTokenPtr); + + localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr); + + if (localIndex < 0) { + return TCL_ERROR; + } + + /* TODO: Consider what value can pass throug the + * IndexTailVarIfKnown() screen. Full CompileWord() + * likely does not apply here. Push known value instead. */ + CompileWord(envPtr, varTokenPtr, interp, i); + TclEmitInstInt4( INST_VARIABLE, localIndex, envPtr); + + if (i+1 < numWords) { + /* + * A value has been given: set the variable, pop the value + */ + + CompileWord(envPtr, valueTokenPtr, interp, i+1); + Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); + } + } + + /* + * Set the result to empty + */ + + PushStringLiteral(envPtr, ""); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * IndexTailVarIfKnown -- + * + * Procedure used in compiling [global] and [variable] commands. It + * inspects the variable name described by varTokenPtr and, if the tail + * is known at compile time, defines a corresponding local variable. + * + * Results: + * Returns the variable's index in the table of compiled locals if the + * tail is known at compile time, or -1 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +IndexTailVarIfKnown( + Tcl_Interp *interp, + Tcl_Token *varTokenPtr, /* Token representing the variable name */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Obj *tailPtr; + const char *tailName, *p; + int len, n = varTokenPtr->numComponents; + Tcl_Token *lastTokenPtr; + int full, localIndex; + + /* + * Determine if the tail is (a) known at compile time, and (b) not an + * array element. Should any of these fail, return an error so that the + * non-compiled command will be called at runtime. + * + * In order for the tail to be known at compile time, the last token in + * the word has to be constant and contain "::" if it is not the only one. + */ + + if (!EnvHasLVT(envPtr)) { + return -1; + } + + TclNewObj(tailPtr); + if (TclWordKnownAtCompileTime(varTokenPtr, tailPtr)) { + full = 1; + lastTokenPtr = varTokenPtr; + } else { + full = 0; + lastTokenPtr = varTokenPtr + n; + if (!TclWordKnownAtCompileTime(lastTokenPtr, tailPtr)) { + Tcl_DecrRefCount(tailPtr); + return -1; + } + } + + tailName = TclGetStringFromObj(tailPtr, &len); + + if (len) { + if (*(tailName+len-1) == ')') { + /* + * Possible array: bail out + */ + + Tcl_DecrRefCount(tailPtr); + return -1; + } + + /* + * Get the tail: immediately after the last '::' + */ + + for (p = tailName + len -1; p > tailName; p--) { + if ((*p == ':') && (*(p-1) == ':')) { + p++; + break; + } + } + if (!full && (p == tailName)) { + /* + * No :: in the last component. + */ + + Tcl_DecrRefCount(tailPtr); + return -1; + } + len -= p - tailName; + tailName = p; + } + + localIndex = TclFindCompiledLocal(tailName, len, 1, envPtr); + Tcl_DecrRefCount(tailPtr); + return localIndex; +} + +/* + * ---------------------------------------------------------------------- + * + * 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. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * We only handle [self] and [self object] (which is the same operation). + * These are the only very common operations on [self] for which + * bytecoding is at all reasonable. + */ + + if (parsePtr->numWords == 1) { + goto compileSelfObject; + } else if (parsePtr->numWords == 2) { + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr), *subcmd; + + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size==0) { + return TCL_ERROR; + } + + subcmd = tokenPtr + 1; + if (strncmp(subcmd->start, "object", subcmd->size) == 0) { + goto compileSelfObject; + } else if (strncmp(subcmd->start, "namespace", subcmd->size) == 0) { + goto compileSelfNamespace; + } + } + + /* + * Can't compile; handle with runtime call. + */ + + return TCL_ERROR; + + compileSelfObject: + + /* + * This delegates the entire problem to a single opcode. + */ + + TclEmitOpcode( INST_TCLOO_SELF, envPtr); + return TCL_OK; + + compileSelfNamespace: + + /* + * This is formally only correct with TclOO methods as they are currently + * implemented; it assumes that the current namespace is invariably when a + * TclOO context is present is the object's namespace, and that's + * technically only something that's a matter of current policy. But it + * avoids creating another opcode, so that's all good! + */ + + TclEmitOpcode( INST_TCLOO_SELF, envPtr); + TclEmitOpcode( INST_POP, envPtr); + TclEmitOpcode( INST_NS_CURRENT, envPtr); + return TCL_OK; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 6e31481..e6ec0a6 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,11 +28,6 @@ static void FreeJumptableInfo(ClientData clientData); static void PrintJumptableInfo(ClientData clientData, Tcl_Obj *appendObj, ByteCode *codePtr, unsigned int pcOffset); -static int PushVarName(Tcl_Interp *interp, - Tcl_Token *varTokenPtr, CompileEnv *envPtr, - int flags, int *localIndexPtr, - int *simpleVarNamePtr, int *isScalarPtr, - int line, int *clNext); static int CompileAssociativeBinaryOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, const char *identity, int instruction, CompileEnv *envPtr); @@ -45,75 +41,28 @@ static int CompileUnaryOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, int instruction, CompileEnv *envPtr); static void IssueSwitchChainedTests(Tcl_Interp *interp, - CompileEnv *envPtr, ExtCmdLoc *mapPtr, - int eclIndex, int mode, int noCase, - int valueIndex, Tcl_Token *valueTokenPtr, - int numWords, Tcl_Token **bodyToken, - int *bodyLines, int **bodyNext); -static void IssueSwitchJumpTable(Tcl_Interp *interp, - CompileEnv *envPtr, ExtCmdLoc *mapPtr, - int eclIndex, int valueIndex, - Tcl_Token *valueTokenPtr, int numWords, + CompileEnv *envPtr, int mode, int noCase, + int valueIndex, int numWords, Tcl_Token **bodyToken, int *bodyLines, - int **bodyContLines); -static int IssueTryFinallyInstructions(Tcl_Interp *interp, + int **bodyNext); +static void IssueSwitchJumpTable(Tcl_Interp *interp, + CompileEnv *envPtr, int valueIndex, + int numWords, Tcl_Token **bodyToken, + int *bodyLines, int **bodyContLines); +static int IssueTryClausesInstructions(Tcl_Interp *interp, CompileEnv *envPtr, Tcl_Token *bodyToken, int numHandlers, int *matchCodes, Tcl_Obj **matchClauses, int *resultVarIndices, - int *optionVarIndices, Tcl_Token **handlerTokens, - Tcl_Token *finallyToken); -static int IssueTryInstructions(Tcl_Interp *interp, + int *optionVarIndices, Tcl_Token **handlerTokens); +static int IssueTryClausesFinallyInstructions(Tcl_Interp *interp, CompileEnv *envPtr, Tcl_Token *bodyToken, int numHandlers, int *matchCodes, Tcl_Obj **matchClauses, int *resultVarIndices, - int *optionVarIndices, Tcl_Token **handlerTokens); - -/* - * Macro that encapsulates an efficiency trick that avoids a function call for - * the simplest of compiles. The ANSI C "prototype" for this macro is: - * - * static void CompileWord(CompileEnv *envPtr, Tcl_Token *tokenPtr, - * Tcl_Interp *interp, int word); - */ - -#define CompileWord(envPtr, tokenPtr, interp, word) \ - if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) { \ - TclEmitPush(TclRegisterNewLiteral((envPtr), (tokenPtr)[1].start, \ - (tokenPtr)[1].size), (envPtr)); \ - } else { \ - envPtr->line = mapPtr->loc[eclIndex].line[word]; \ - envPtr->clNext = mapPtr->loc[eclIndex].next[word]; \ - TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ - (envPtr)); \ - } - -/* - * TIP #280: Remember the per-word line information of the current command. An - * index is used instead of a pointer as recursive compilation may reallocate, - * i.e. move, the array. This is also the reason to save the nuloc now, it may - * change during the course of the function. - * - * Macro to encapsulate the variable definition and setup. - */ - -#define DefineLineInformation \ - ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ - int eclIndex = mapPtr->nuloc - 1 - -#define SetLineInformation(word) \ - envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ - envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] - -#define PushVarNameWord(i,v,e,f,l,s,sc,word) \ - PushVarName(i,v,e,f,l,s,sc, \ - mapPtr->loc[eclIndex].line[(word)], \ - mapPtr->loc[eclIndex].next[(word)]) - -/* - * Flags bits used by PushVarName. - */ - -#define TCL_NO_LARGE_INDEX 1 /* Do not return localIndex value > 255 */ + int *optionVarIndices, Tcl_Token **handlerTokens, + Tcl_Token *finallyToken); +static int IssueTryFinallyInstructions(Tcl_Interp *interp, + CompileEnv *envPtr, Tcl_Token *bodyToken, + Tcl_Token *finallyToken); /* * The structures below define the AuxData types defined in this file. @@ -137,18 +86,75 @@ const AuxDataType tclJumptableInfoType = { TclEmitInstInt1(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr) #define OP44(name,val1,val2) \ TclEmitInstInt4(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr) -#define BODY(token,index) \ - SetLineInformation((index));CompileBody(envPtr,(token),interp) #define PUSH(str) \ - PushLiteral(envPtr,(str),strlen(str)) -#define JUMP(var,name) \ - (var) = CurrentOffset(envPtr);TclEmitInstInt4(INST_##name,0,envPtr) -#define FIXJUMP(var) \ + PushStringLiteral(envPtr, str) +#define JUMP4(name,var) \ + (var) = CurrentOffset(envPtr);TclEmitInstInt4(INST_##name##4,0,envPtr) +#define FIXJUMP4(var) \ TclStoreInt4AtPtr(CurrentOffset(envPtr)-(var),envPtr->codeStart+(var)+1) +#define JUMP1(name,var) \ + (var) = CurrentOffset(envPtr);TclEmitInstInt1(INST_##name##1,0,envPtr) +#define FIXJUMP1(var) \ + TclStoreInt1AtPtr(CurrentOffset(envPtr)-(var),envPtr->codeStart+(var)+1) #define LOAD(idx) \ if ((idx)<256) {OP1(LOAD_SCALAR1,(idx));} else {OP4(LOAD_SCALAR4,(idx));} #define STORE(idx) \ if ((idx)<256) {OP1(STORE_SCALAR1,(idx));} else {OP4(STORE_SCALAR4,(idx));} +#define INVOKE(name) \ + TclEmitInvoke(envPtr,INST_##name) + +#define INDEX_END (-2) + +/* + *---------------------------------------------------------------------- + * + * GetIndexFromToken -- + * + * Parse a token and get the encoded version of the index (as understood + * by TEBC), assuming it is at all knowable at compile time. Only handles + * indices that are integers or 'end' or 'end-integer'. + * + * Returns: + * TCL_OK if parsing succeeded, and TCL_ERROR if it failed. + * + * Side effects: + * Sets *index to the index value if successful. + * + *---------------------------------------------------------------------- + */ + +static inline int +GetIndexFromToken( + Tcl_Token *tokenPtr, + int *index) +{ + Tcl_Obj *tmpObj = Tcl_NewObj(); + int result, idx; + + if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) { + Tcl_DecrRefCount(tmpObj); + return TCL_ERROR; + } + + result = TclGetIntFromObj(NULL, tmpObj, &idx); + if (result == TCL_OK) { + if (idx < 0) { + result = TCL_ERROR; + } + } else { + result = TclGetIntForIndexM(NULL, tmpObj, INDEX_END, &idx); + if (result == TCL_OK && idx > INDEX_END) { + result = TCL_ERROR; + } + } + Tcl_DecrRefCount(tmpObj); + + if (result == TCL_OK) { + *index = idx; + } + + return result; +} /* *---------------------------------------------------------------------- @@ -178,7 +184,7 @@ TclCompileSetCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr, *valueTokenPtr; - int isAssignment, isScalar, simpleVarName, localIndex, numWords; + int isAssignment, isScalar, localIndex, numWords; DefineLineInformation; /* TIP #280 */ numWords = parsePtr->numWords; @@ -197,7 +203,7 @@ TclCompileSetCmd( varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarNameWord(interp, varTokenPtr, envPtr, 0, - &localIndex, &simpleVarName, &isScalar, 1); + &localIndex, &isScalar, 1); /* * If we are doing an assignment, push the new value. @@ -212,12 +218,10 @@ TclCompileSetCmd( * Emit instructions to set/get the variable. */ - if (simpleVarName) { if (isScalar) { if (localIndex < 0) { TclEmitOpcode((isAssignment? - INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK), - envPtr); + INST_STORE_STK : INST_LOAD_STK), envPtr); } else if (localIndex <= 255) { TclEmitInstInt1((isAssignment? INST_STORE_SCALAR1 : INST_LOAD_SCALAR1), @@ -241,9 +245,6 @@ TclCompileSetCmd( localIndex, envPtr); } } - } else { - TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), envPtr); - } return TCL_OK; } @@ -424,6 +425,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 @@ -448,7 +727,7 @@ TclCompileStringMatchCmd( if (parsePtr->numWords == 4) { if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; + return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } str = tokenPtr[1].start; length = tokenPtr[1].size; @@ -457,7 +736,7 @@ TclCompileStringMatchCmd( * Fail at run time, not in compilation. */ - return TCL_ERROR; + return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } nocase = 1; tokenPtr = TokenAfter(tokenPtr); @@ -578,13 +857,13 @@ TclCompileStringMapCmd( Tcl_IncrRefCount(mapObj); if (!TclWordKnownAtCompileTime(mapTokenPtr, mapObj)) { Tcl_DecrRefCount(mapObj); - return TCL_ERROR; + return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } else if (Tcl_ListObjGetElements(NULL, mapObj, &len, &objv) != TCL_OK) { Tcl_DecrRefCount(mapObj); - return TCL_ERROR; + return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } else if (len != 2) { Tcl_DecrRefCount(mapObj); - return TCL_ERROR; + return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } /* @@ -618,8 +897,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; @@ -629,50 +907,13 @@ TclCompileStringRangeCmd( toTokenPtr = TokenAfter(fromTokenPtr); /* - * Parse the first index. Will only compile if it is constant and not an - * _integer_ less than zero (since we reserve negative indices here for - * end-relative indexing). + * Parse the two indices. */ - tmpObj = Tcl_NewObj(); - result = TCL_ERROR; - if (TclWordKnownAtCompileTime(fromTokenPtr, tmpObj)) { - if (TclGetIntFromObj(NULL, tmpObj, &idx1) == TCL_OK) { - if (idx1 >= 0) { - result = TCL_OK; - } - } else if (TclGetIntForIndexM(NULL, tmpObj, -2, &idx1) == TCL_OK) { - if (idx1 <= -2) { - result = TCL_OK; - } - } - } - TclDecrRefCount(tmpObj); - if (result != TCL_OK) { + if (GetIndexFromToken(fromTokenPtr, &idx1) != TCL_OK) { goto nonConstantIndices; } - - /* - * Parse the second index. Will only compile if it is constant and not an - * _integer_ less than zero (since we reserve negative indices here for - * end-relative indexing). - */ - - tmpObj = Tcl_NewObj(); - result = TCL_ERROR; - if (TclWordKnownAtCompileTime(toTokenPtr, tmpObj)) { - if (TclGetIntFromObj(NULL, tmpObj, &idx2) == TCL_OK) { - if (idx2 >= 0) { - result = TCL_OK; - } - } else if (TclGetIntForIndexM(NULL, tmpObj, -2, &idx2) == TCL_OK) { - if (idx2 <= -2) { - result = TCL_OK; - } - } - } - TclDecrRefCount(tmpObj); - if (result != TCL_OK) { + if (GetIndexFromToken(toTokenPtr, &idx2) != TCL_OK) { goto nonConstantIndices; } @@ -695,6 +936,320 @@ TclCompileStringRangeCmd( OP( STR_RANGE); return TCL_OK; } + +int +TclCompileStringReplaceCmd( + Tcl_Interp *interp, /* Tcl interpreter for context. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the + * command. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds the resulting instructions. */ +{ + Tcl_Token *tokenPtr, *valueTokenPtr, *replacementTokenPtr = NULL; + DefineLineInformation; /* TIP #280 */ + int idx1, idx2; + + if (parsePtr->numWords < 4 || parsePtr->numWords > 5) { + return TCL_ERROR; + } + valueTokenPtr = TokenAfter(parsePtr->tokenPtr); + if (parsePtr->numWords == 5) { + tokenPtr = TokenAfter(valueTokenPtr); + tokenPtr = TokenAfter(tokenPtr); + replacementTokenPtr = TokenAfter(tokenPtr); + } + + /* + * Parse the indices. Will only compile special cases if both are + * constants and not an _integer_ less than zero (since we reserve + * negative indices here for end-relative indexing) or an end-based index + * greater than 'end' itself. + */ + + tokenPtr = TokenAfter(valueTokenPtr); + if (GetIndexFromToken(tokenPtr, &idx1) != TCL_OK) { + goto genericReplace; + } + + tokenPtr = TokenAfter(tokenPtr); + if (GetIndexFromToken(tokenPtr, &idx2) != TCL_OK) { + goto genericReplace; + } + + /* + * We handle these replacements specially: first character (where + * idx1=idx2=0) and last character (where idx1=idx2=INDEX_END). Anything + * else and the semantics get rather screwy. + */ + + if (idx1 == 0 && idx2 == 0) { + int notEq, end; + + /* + * Just working with the first character. + */ + + CompileWord(envPtr, valueTokenPtr, interp, 1); + if (replacementTokenPtr == NULL) { + /* Drop first */ + OP44( STR_RANGE_IMM, 1, INDEX_END); + return TCL_OK; + } + /* Replace first */ + CompileWord(envPtr, replacementTokenPtr, interp, 4); + OP4( OVER, 1); + PUSH( ""); + OP( STR_EQ); + JUMP1( JUMP_FALSE, notEq); + OP( POP); + JUMP1( JUMP, end); + FIXJUMP1(notEq); + TclAdjustStackDepth(1, envPtr); + OP4( REVERSE, 2); + OP44( STR_RANGE_IMM, 1, INDEX_END); + OP1( STR_CONCAT1, 2); + FIXJUMP1(end); + return TCL_OK; + + } else if (idx1 == INDEX_END && idx2 == INDEX_END) { + int notEq, end; + + /* + * Just working with the last character. + */ + + CompileWord(envPtr, valueTokenPtr, interp, 1); + if (replacementTokenPtr == NULL) { + /* Drop last */ + OP44( STR_RANGE_IMM, 0, INDEX_END-1); + return TCL_OK; + } + /* Replace last */ + CompileWord(envPtr, replacementTokenPtr, interp, 4); + OP4( OVER, 1); + PUSH( ""); + OP( STR_EQ); + JUMP1( JUMP_FALSE, notEq); + OP( POP); + JUMP1( JUMP, end); + FIXJUMP1(notEq); + TclAdjustStackDepth(1, envPtr); + OP4( REVERSE, 2); + OP44( STR_RANGE_IMM, 0, INDEX_END-1); + OP4( REVERSE, 2); + OP1( STR_CONCAT1, 2); + FIXJUMP1(end); + return TCL_OK; + + } else { + /* + * Need to process indices at runtime. This could be because the + * indices are not constants, or because we need to resolve them to + * absolute indices to work out if a replacement is going to happen. + * In any case, to runtime it is. + */ + + genericReplace: + CompileWord(envPtr, valueTokenPtr, interp, 1); + tokenPtr = TokenAfter(valueTokenPtr); + CompileWord(envPtr, tokenPtr, interp, 2); + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 3); + if (replacementTokenPtr != NULL) { + CompileWord(envPtr, replacementTokenPtr, interp, 4); + } else { + PUSH( ""); + } + OP( STR_REPLACE); + return TCL_OK; + } +} + +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} +}; /* *---------------------------------------------------------------------- @@ -798,18 +1353,21 @@ TclSubstCompile( Tcl_InterpState state = NULL; TclSubstParse(interp, bytes, numBytes, flags, &parse, &state); + if (state != NULL) { + Tcl_ResetResult(interp); + } /* * Tricky point! If the first token does not result in a *guaranteed* push * of a Tcl_Obj on the stack, we must push an empty object. Otherwise it - * is possible to get to an INST_CONCAT1 or INST_DONE without enough + * is possible to get to an INST_STR_CONCAT1 or INST_DONE without enough * values on the stack, resulting in a crash. Thanks to Joe Mistachkin for * identifying a script that could trigger this case. */ tokenPtr = parse.tokenPtr; if (tokenPtr->type != TCL_TOKEN_TEXT && tokenPtr->type != TCL_TOKEN_BS) { - PushLiteral(envPtr, "", 0); + PUSH(""); count++; } @@ -867,11 +1425,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; } @@ -891,7 +1449,7 @@ TclSubstCompile( } envPtr->line = bline; - catchRange = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); + catchRange = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); OP4( BEGIN_CATCH4, catchRange); ExceptionRangeStarts(envPtr, catchRange); @@ -915,6 +1473,7 @@ TclSubstCompile( /* Substitution produced TCL_OK */ OP( END_CATCH); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &okFixup); + TclAdjustStackDepth(-1, envPtr); /* Exceptional return codes processed here */ ExceptionRangeTarget(envPtr, catchRange, catchOffset); @@ -924,7 +1483,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); @@ -940,6 +1499,7 @@ TclSubstCompile( /* OTHER */ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &otherFixup); + TclAdjustStackDepth(1, envPtr); /* BREAK destination */ if (TclFixupForwardJumpToHere(envPtr, &breakFixup, 127)) { Tcl_Panic("TclCompileSubstCmd: bad break jump distance %d", @@ -955,6 +1515,7 @@ TclSubstCompile( OP1(JUMP1, -breakJump); } + TclAdjustStackDepth(2, envPtr); /* CONTINUE destination */ if (TclFixupForwardJumpToHere(envPtr, &continueFixup, 127)) { Tcl_Panic("TclCompileSubstCmd: bad continue jump distance %d", @@ -964,6 +1525,7 @@ TclSubstCompile( OP( POP); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &endFixup); + TclAdjustStackDepth(2, envPtr); /* RETURN + other destination */ if (TclFixupForwardJumpToHere(envPtr, &returnFixup, 127)) { Tcl_Panic("TclCompileSubstCmd: bad return jump distance %d", @@ -981,24 +1543,13 @@ TclSubstCompile( OP4( REVERSE, 2); OP( POP); - /* - * We've emitted several POP instructions, and the automatic - * computations for stack depth requirements have been decrementing - * for every one. However, we know that every branch actually taken - * only encounters some of those instructions. No branch passes - * through them all. So, we now have a stack requirements estimate - * that is too low. Here we manually fix that up. - */ - - TclAdjustStackDepth(5, envPtr); - /* OK destination */ if (TclFixupForwardJumpToHere(envPtr, &okFixup, 127)) { Tcl_Panic("TclCompileSubstCmd: bad ok jump distance %d", (int) (CurrentOffset(envPtr) - okFixup.codeOffset)); } if (count > 1) { - OP1(CONCAT1, count); + OP1(STR_CONCAT1, count); count = 1; } @@ -1011,11 +1562,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); @@ -1050,9 +1601,6 @@ TclSubstCompile( * Instructions are added to envPtr to execute the "switch" command at * runtime. * - * FIXME: - * Stack depths are probably not calculated correctly. - * *---------------------------------------------------------------------- */ @@ -1343,13 +1891,15 @@ TclCompileSwitchCmd( * but it handles the most common case well enough. */ + /* Both methods push the value to match against onto the stack. */ + CompileWord(envPtr, valueTokenPtr, interp, valueIndex); + if (mode == Switch_Exact) { - IssueSwitchJumpTable(interp, envPtr, mapPtr, eclIndex, valueIndex, - valueTokenPtr, numWords, bodyToken, bodyLines, bodyContLines); + IssueSwitchJumpTable(interp, envPtr, valueIndex, numWords, bodyToken, + bodyLines, bodyContLines); } else { - IssueSwitchChainedTests(interp, envPtr, mapPtr, eclIndex, mode,noCase, - valueIndex, valueTokenPtr, numWords, bodyToken, bodyLines, - bodyContLines); + IssueSwitchChainedTests(interp, envPtr, mode, noCase, valueIndex, + numWords, bodyToken, bodyLines, bodyContLines); } result = TCL_OK; @@ -1387,13 +1937,9 @@ static void IssueSwitchChainedTests( Tcl_Interp *interp, /* Context for compiling script bodies. */ CompileEnv *envPtr, /* Holds resulting instructions. */ - ExtCmdLoc *mapPtr, /* For mapping tokens to their source code - * location. */ - int eclIndex, int mode, /* Exact, Glob or Regexp */ int noCase, /* Case-insensitivity flag. */ int valueIndex, /* The value to match against. */ - Tcl_Token *valueTokenPtr, int numBodyTokens, /* Number of tokens describing things the * switch can match against and bodies to * execute when the match succeeds. */ @@ -1403,7 +1949,6 @@ IssueSwitchChainedTests( int **bodyContLines) /* Array of continuation line info. */ { enum {Switch_Exact, Switch_Glob, Switch_Regexp}; - int savedStackDepth = envPtr->currStackDepth; int foundDefault; /* Flag to indicate whether a "default" clause * is present. */ JumpFixup *fixupArray; /* Array of forward-jump fixup records. */ @@ -1419,13 +1964,6 @@ IssueSwitchChainedTests( int i; /* - * First, we push the value we're matching against on the stack. - */ - - SetLineInformation(valueIndex); - CompileTokens(envPtr, valueTokenPtr, interp); - - /* * Generate a test for each arm. */ @@ -1438,7 +1976,6 @@ IssueSwitchChainedTests( foundDefault = 0; for (i=0 ; i<numBodyTokens ; i+=2) { nextArmFixupIndex = -1; - envPtr->currStackDepth = savedStackDepth + 1; if (i!=numBodyTokens-2 || bodyToken[numBodyTokens-2]->size != 7 || memcmp(bodyToken[numBodyTokens-2]->start, "default", 7)) { /* @@ -1472,7 +2009,7 @@ IssueSwitchChainedTests( * when the RE == "". */ - PushLiteral(envPtr, "1", 1); + PUSH("1"); break; } @@ -1569,13 +2106,12 @@ IssueSwitchChainedTests( } /* - * Now do the actual compilation. Note that we do not use CompileBody + * Now do the actual compilation. Note that we do not use BODY() * because we may have synthesized the tokens in a non-standard * pattern. */ OP( POP); - envPtr->currStackDepth = savedStackDepth + 1; envPtr->line = bodyLines[i+1]; /* TIP #280 */ envPtr->clNext = bodyContLines[i+1]; /* TIP #280 */ TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr); @@ -1597,7 +2133,7 @@ IssueSwitchChainedTests( if (!foundDefault) { OP( POP); - PushLiteral(envPtr, "", 0); + PUSH(""); } /* @@ -1633,8 +2169,6 @@ IssueSwitchChainedTests( } TclStackFree(interp, fixupTargetArray); TclStackFree(interp, fixupArray); - - envPtr->currStackDepth = savedStackDepth + 1; } /* @@ -1654,11 +2188,7 @@ static void IssueSwitchJumpTable( Tcl_Interp *interp, /* Context for compiling script bodies. */ CompileEnv *envPtr, /* Holds resulting instructions. */ - ExtCmdLoc *mapPtr, /* For mapping tokens to their source code - * location. */ - int eclIndex, int valueIndex, /* The value to match against. */ - Tcl_Token *valueTokenPtr, int numBodyTokens, /* Number of tokens describing things the * switch can match against and bodies to * execute when the match succeeds. */ @@ -1668,20 +2198,12 @@ IssueSwitchJumpTable( int **bodyContLines) /* Array of continuation line info. */ { JumptableInfo *jtPtr; - int savedStackDepth = envPtr->currStackDepth; int infoIndex, isNew, *finalFixups, numRealBodies = 0, jumpLocation; int mustGenerate, foundDefault, jumpToDefault, i; Tcl_DString buffer; Tcl_HashEntry *hPtr; /* - * First, we push the value we're matching against on the stack. - */ - - SetLineInformation(valueIndex); - CompileTokens(envPtr, valueTokenPtr, interp); - - /* * Compile the switch by using a jump table, which is basically a * hashtable that maps from literal values to match against to the offset * (relative to the INST_JUMP_TABLE instruction) to jump to. The jump @@ -1781,7 +2303,6 @@ IssueSwitchJumpTable( * Compile the body of the arm. */ - envPtr->currStackDepth = savedStackDepth; envPtr->line = bodyLines[i+1]; /* TIP #280 */ envPtr->clNext = bodyContLines[i+1]; /* TIP #280 */ TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr); @@ -1803,6 +2324,7 @@ IssueSwitchJumpTable( */ OP4( JUMP4, 0); + TclAdjustStackDepth(-1, envPtr); } } @@ -1813,10 +2335,9 @@ IssueSwitchJumpTable( */ if (!foundDefault) { - envPtr->currStackDepth = savedStackDepth; TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault, envPtr->codeStart+jumpToDefault+1); - PushLiteral(envPtr, "", 0); + PUSH(""); } /* @@ -1834,7 +2355,6 @@ IssueSwitchJumpTable( */ TclStackFree(interp, finalFixups); - envPtr->currStackDepth = savedStackDepth + 1; } /* @@ -1954,6 +2474,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); @@ -1992,9 +2513,9 @@ TclCompileThrowCmd( { DefineLineInformation; /* TIP #280 */ int numWords = parsePtr->numWords; - int savedStackDepth = envPtr->currStackDepth; Tcl_Token *codeToken, *msgToken; Tcl_Obj *objPtr; + int codeKnown, codeIsList, codeIsValid, len; if (numWords != 3) { return TCL_ERROR; @@ -2004,77 +2525,66 @@ TclCompileThrowCmd( TclNewObj(objPtr); Tcl_IncrRefCount(objPtr); - if (TclWordKnownAtCompileTime(codeToken, objPtr)) { - Tcl_Obj *errPtr, *dictPtr; - const char *string; - int len; - /* - * The code is known at compilation time. This allows us to issue a - * very efficient sequence of instructions. - */ + codeKnown = TclWordKnownAtCompileTime(codeToken, objPtr); - if (Tcl_ListObjLength(interp, objPtr, &len) != TCL_OK) { - /* - * Must still do this; might generate an error when getting this - * "ignored" value prepared as an argument. - */ + /* + * First we must emit the code to substitute the arguments. This + * must come first in case substitution raises errors. + */ + if (!codeKnown) { + CompileWord(envPtr, codeToken, interp, 1); + PUSH( "-errorcode"); + } + CompileWord(envPtr, msgToken, interp, 2); - CompileWord(envPtr, msgToken, interp, 2); - TclCompileSyntaxError(interp, envPtr); - Tcl_DecrRefCount(objPtr); - envPtr->currStackDepth = savedStackDepth + 1; - return TCL_OK; - } - if (len == 0) { - /* - * Must still do this; might generate an error when getting this - * "ignored" value prepared as an argument. - */ + codeIsList = codeKnown && (TCL_OK == + Tcl_ListObjLength(interp, objPtr, &len)); + codeIsValid = codeIsList && (len != 0); + + if (codeIsValid) { + Tcl_Obj *errPtr, *dictPtr; - CompileWord(envPtr, msgToken, interp, 2); - goto issueErrorForEmptyCode; - } TclNewLiteralStringObj(errPtr, "-errorcode"); TclNewObj(dictPtr); Tcl_DictObjPut(NULL, dictPtr, errPtr, objPtr); - Tcl_IncrRefCount(dictPtr); - string = Tcl_GetStringFromObj(dictPtr, &len); - CompileWord(envPtr, msgToken, interp, 2); - PushLiteral(envPtr, string, len); - TclDecrRefCount(dictPtr); - OP44( RETURN_IMM, 1, 0); - envPtr->currStackDepth = savedStackDepth + 1; - } else { - /* - * When the code token is not known at compilation time, we need to do - * a little bit more work. The main tricky bit here is that the error - * code has to be a list (a [throw] restriction) so we must emit extra - * instructions to enforce that condition. - */ + TclEmitPush(TclAddLiteralObj(envPtr, dictPtr, NULL), envPtr); + } + TclDecrRefCount(objPtr); - CompileWord(envPtr, codeToken, interp, 1); - PUSH( "-errorcode"); - CompileWord(envPtr, msgToken, interp, 2); - OP4( REVERSE, 3); - OP( DUP); - OP( LIST_LENGTH); - OP1( JUMP_FALSE1, 16); - OP4( LIST, 2); - OP44( RETURN_IMM, 1, 0); + /* + * Simpler bytecodes when we detect invalid arguments at compile time. + */ + if (codeKnown && !codeIsValid) { + OP( POP); + if (codeIsList) { + /* Must be an empty list */ + goto issueErrorForEmptyCode; + } + TclCompileSyntaxError(interp, envPtr); + return TCL_OK; + } + if (!codeKnown) { /* - * Generate an error for being an empty list. Can't leverage anything - * else to do this for us. + * Argument validity checking has to be done by bytecode at + * run time. */ - + OP4( REVERSE, 3); + OP( DUP); + OP( LIST_LENGTH); + OP1( JUMP_FALSE1, 16); + OP4( LIST, 2); + OP44( RETURN_IMM, TCL_ERROR, 0); + TclAdjustStackDepth(2, envPtr); + OP( POP); + OP( POP); + OP( POP); issueErrorForEmptyCode: - PUSH( "type must be non-empty list"); - PUSH( ""); - OP44( RETURN_IMM, 1, 0); + PUSH( "type must be non-empty list"); + PUSH( "-errorcode {TCL OPERATION THROW BADEXCEPTION}"); } - envPtr->currStackDepth = savedStackDepth + 1; - TclDecrRefCount(objPtr); + OP44( RETURN_IMM, TCL_ERROR, 0); return TCL_OK; } @@ -2124,8 +2634,7 @@ TclCompileTryCmd( */ DefineLineInformation; /* TIP #280 */ - SetLineInformation(1); - CompileBody(envPtr, bodyToken, interp); + BODY(bodyToken, 1); return TCL_OK; } @@ -2216,12 +2725,11 @@ TclCompileTryCmd( int len; const char *varname = Tcl_GetStringFromObj(objv[0], &len); - if (!TclIsLocalScalar(varname, len)) { + resultVarIndices[i] = LocalScalar(varname, len, envPtr); + if (resultVarIndices[i] < 0) { TclDecrRefCount(tmpObj); goto failedToCompile; } - resultVarIndices[i] = - TclFindCompiledLocal(varname, len, 1, envPtr); } else { resultVarIndices[i] = -1; } @@ -2229,12 +2737,11 @@ TclCompileTryCmd( int len; const char *varname = Tcl_GetStringFromObj(objv[1], &len); - if (!TclIsLocalScalar(varname, len)) { + optionVarIndices[i] = LocalScalar(varname, len, envPtr); + if (optionVarIndices[i] < 0) { TclDecrRefCount(tmpObj); goto failedToCompile; } - optionVarIndices[i] = - TclFindCompiledLocal(varname, len, 1, envPtr); } else { optionVarIndices[i] = -1; } @@ -2282,14 +2789,17 @@ TclCompileTryCmd( * Issue the bytecode. */ - if (finallyToken) { + if (!finallyToken) { + result = IssueTryClausesInstructions(interp, envPtr, bodyToken, + numHandlers, matchCodes, matchClauses, resultVarIndices, + optionVarIndices, handlerTokens); + } else if (numHandlers == 0) { result = IssueTryFinallyInstructions(interp, envPtr, bodyToken, + finallyToken); + } else { + result = IssueTryClausesFinallyInstructions(interp, envPtr, bodyToken, numHandlers, matchCodes, matchClauses, resultVarIndices, optionVarIndices, handlerTokens, finallyToken); - } else { - result = IssueTryInstructions(interp, envPtr, bodyToken, numHandlers, - matchCodes, matchClauses, resultVarIndices, optionVarIndices, - handlerTokens); } /* @@ -2315,12 +2825,13 @@ TclCompileTryCmd( /* *---------------------------------------------------------------------- * - * IssueTryInstructions, IssueTryFinallyInstructions -- + * IssueTryClausesInstructions, IssueTryClausesFinallyInstructions, + * IssueTryFinallyInstructions -- * * The code generators for [try]. Split from the parsing engine for - * reasons of developer sanity, and also split between no-finally and - * with-finally cases because so many of the details of generation vary - * between the two. + * reasons of developer sanity, and also split between no-finally, + * just-finally and with-finally cases because so many of the details of + * generation vary between the three. * * The macros below make the instruction issuing easier to follow. * @@ -2328,7 +2839,7 @@ TclCompileTryCmd( */ static int -IssueTryInstructions( +IssueTryClausesInstructions( Tcl_Interp *interp, CompileEnv *envPtr, Tcl_Token *bodyToken, @@ -2341,32 +2852,51 @@ IssueTryInstructions( { DefineLineInformation; /* TIP #280 */ int range, resultVar, optionsVar; - int savedStackDepth = envPtr->currStackDepth; - int i, j, len, forwardsNeedFixing = 0; + int i, j, len, forwardsNeedFixing = 0, trapZero = 0, afterBody = 0; int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource; + int *noError; char buf[TCL_INTEGER_SPACE]; - resultVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); - optionsVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); + resultVar = AnonymousLocal(envPtr); + optionsVar = AnonymousLocal(envPtr); if (resultVar < 0 || optionsVar < 0) { return TCL_ERROR; } /* + * Check if we're supposed to trap a normal TCL_OK completion of the body. + * If not, we can handle that case much more efficiently. + */ + + for (i=0 ; i<numHandlers ; i++) { + if (matchCodes[i] == 0) { + trapZero = 1; + break; + } + } + + /* * Compile the body, trapping any error in it so that we can trap on it * and/or run a finally clause. Note that there must be at least one * on/trap clause; when none is present, this whole function is not called * (and it's never called when there's a finally clause). */ - range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); OP4( BEGIN_CATCH4, range); ExceptionRangeStarts(envPtr, range); BODY( bodyToken, 1); ExceptionRangeEnds(envPtr, range); - PUSH( "0"); - OP4( REVERSE, 2); - OP1( JUMP1, 4); + if (!trapZero) { + OP( END_CATCH); + JUMP4( JUMP, afterBody); + TclAdjustStackDepth(-1, envPtr); + } else { + PUSH( "0"); + OP4( REVERSE, 2); + OP1( JUMP1, 4); + TclAdjustStackDepth(-2, envPtr); + } ExceptionRangeTarget(envPtr, range, catchOffset); OP( PUSH_RETURN_CODE); OP( PUSH_RESULT); @@ -2386,14 +2916,17 @@ IssueTryInstructions( addrsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers); forwardsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers); + noError = TclStackAlloc(interp, sizeof(int)*numHandlers); for (i=0 ; i<numHandlers ; i++) { + noError[i] = -1; sprintf(buf, "%d", matchCodes[i]); OP( DUP); - PUSH( buf); + PushLiteral(envPtr, buf, strlen(buf)); OP( EQ); - JUMP(notCodeJumpSource, JUMP_FALSE4); + JUMP4( JUMP_FALSE, notCodeJumpSource); if (matchClauses[i]) { + const char *p; Tcl_ListObjLength(NULL, matchClauses[i], &len); /* @@ -2405,9 +2938,10 @@ IssueTryInstructions( OP4( DICT_GET, 1); TclAdjustStackDepth(-1, envPtr); OP44( LIST_RANGE_IMM, 0, len-1); - PUSH( TclGetString(matchClauses[i])); + p = Tcl_GetStringFromObj(matchClauses[i], &len); + PushLiteral(envPtr, p, len); OP( STR_EQ); - JUMP(notECJumpSource, JUMP_FALSE4); + JUMP4( JUMP_FALSE, notECJumpSource); } else { notECJumpSource = -1; /* LINT */ } @@ -2431,8 +2965,10 @@ IssueTryInstructions( } if (!handlerTokens[i]) { forwardsNeedFixing = 1; - JUMP(forwardsToFix[i], JUMP4); + JUMP4( JUMP, forwardsToFix[i]); } else { + int dontChangeOptions; + forwardsToFix[i] = -1; if (forwardsNeedFixing) { forwardsNeedFixing = 0; @@ -2440,19 +2976,44 @@ IssueTryInstructions( if (forwardsToFix[j] == -1) { continue; } - FIXJUMP(forwardsToFix[j]); + FIXJUMP4(forwardsToFix[j]); forwardsToFix[j] = -1; } } - envPtr->currStackDepth = savedStackDepth; + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); + OP4( BEGIN_CATCH4, range); + ExceptionRangeStarts(envPtr, range); BODY( handlerTokens[i], 5+i*4); + ExceptionRangeEnds(envPtr, range); + OP( END_CATCH); + JUMP4( JUMP, noError[i]); + ExceptionRangeTarget(envPtr, range, catchOffset); + TclAdjustStackDepth(-1, envPtr); + OP( PUSH_RESULT); + OP( PUSH_RETURN_OPTIONS); + OP( PUSH_RETURN_CODE); + OP( END_CATCH); + PUSH( "1"); + OP( EQ); + JUMP1( JUMP_FALSE, dontChangeOptions); + LOAD( optionsVar); + OP4( REVERSE, 2); + STORE( optionsVar); + OP( POP); + PUSH( "-during"); + OP4( REVERSE, 2); + OP44( DICT_SET, 1, optionsVar); + TclAdjustStackDepth(-1, envPtr); + FIXJUMP1( dontChangeOptions); + OP4( REVERSE, 2); + INVOKE( RETURN_STK); } - JUMP(addrsToFix[i], JUMP4); + JUMP4( JUMP, addrsToFix[i]); if (matchClauses[i]) { - FIXJUMP(notECJumpSource); + FIXJUMP4( notECJumpSource); } - FIXJUMP(notCodeJumpSource); + FIXJUMP4( notCodeJumpSource); } /* @@ -2464,24 +3025,30 @@ IssueTryInstructions( OP( POP); LOAD( optionsVar); LOAD( resultVar); - OP( RETURN_STK); + INVOKE( RETURN_STK); /* * Fix all the jumps from taken clauses to here (which is the end of the * [try]). */ + if (!trapZero) { + FIXJUMP4(afterBody); + } for (i=0 ; i<numHandlers ; i++) { - FIXJUMP(addrsToFix[i]); + FIXJUMP4(addrsToFix[i]); + if (noError[i] != -1) { + FIXJUMP4(noError[i]); + } } + TclStackFree(interp, noError); TclStackFree(interp, forwardsToFix); TclStackFree(interp, addrsToFix); - envPtr->currStackDepth = savedStackDepth + 1; return TCL_OK; } static int -IssueTryFinallyInstructions( +IssueTryClausesFinallyInstructions( Tcl_Interp *interp, CompileEnv *envPtr, Tcl_Token *bodyToken, @@ -2494,31 +3061,53 @@ IssueTryFinallyInstructions( Tcl_Token *finallyToken) /* Not NULL */ { DefineLineInformation; /* TIP #280 */ - int savedStackDepth = envPtr->currStackDepth; int range, resultVar, optionsVar, i, j, len, forwardsNeedFixing = 0; + int trapZero = 0, afterBody = 0, finalOK, finalError, noFinalError; int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource; char buf[TCL_INTEGER_SPACE]; - resultVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); - optionsVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); + resultVar = AnonymousLocal(envPtr); + optionsVar = AnonymousLocal(envPtr); if (resultVar < 0 || optionsVar < 0) { return TCL_ERROR; } /* + * Check if we're supposed to trap a normal TCL_OK completion of the body. + * If not, we can handle that case much more efficiently. + */ + + for (i=0 ; i<numHandlers ; i++) { + if (matchCodes[i] == 0) { + trapZero = 1; + break; + } + } + + /* * Compile the body, trapping any error in it so that we can trap on it * (if any trap matches) and run a finally clause. */ - range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); OP4( BEGIN_CATCH4, range); ExceptionRangeStarts(envPtr, range); - envPtr->currStackDepth = savedStackDepth; BODY( bodyToken, 1); ExceptionRangeEnds(envPtr, range); - PUSH( "0"); - OP4( REVERSE, 2); - OP1( JUMP1, 4); + if (!trapZero) { + OP( END_CATCH); + STORE( resultVar); + OP( POP); + PUSH( "-level 0 -code 0"); + STORE( optionsVar); + OP( POP); + JUMP4( JUMP, afterBody); + } else { + PUSH( "0"); + OP4( REVERSE, 2); + OP1( JUMP1, 4); + TclAdjustStackDepth(-2, envPtr); + } ExceptionRangeTarget(envPtr, range, catchOffset); OP( PUSH_RETURN_CODE); OP( PUSH_RESULT); @@ -2528,161 +3117,176 @@ IssueTryFinallyInstructions( OP( POP); STORE( resultVar); OP( POP); - envPtr->currStackDepth = savedStackDepth + 1; /* * Now we handle all the registered 'on' and 'trap' handlers in order. + * + * Slight overallocation, but reduces size of this function. */ - if (numHandlers) { - /* - * Slight overallocation, but reduces size of this function. - */ - - addrsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers); - forwardsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers); - - for (i=0 ; i<numHandlers ; i++) { - sprintf(buf, "%d", matchCodes[i]); - OP( DUP); - PUSH( buf); - OP( EQ); - JUMP(notCodeJumpSource, JUMP_FALSE4); - if (matchClauses[i]) { - Tcl_ListObjLength(NULL, matchClauses[i], &len); + addrsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers); + forwardsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers); - /* - * Match the errorcode according to try/trap rules. - */ + for (i=0 ; i<numHandlers ; i++) { + int noTrapError, trapError; + const char *p; - LOAD( optionsVar); - PUSH( "-errorcode"); - OP4( DICT_GET, 1); - TclAdjustStackDepth(-1, envPtr); - OP44( LIST_RANGE_IMM, 0, len-1); - PUSH( TclGetString(matchClauses[i])); - OP( STR_EQ); - JUMP(notECJumpSource, JUMP_FALSE4); - } else { - notECJumpSource = -1; /* LINT */ - } + sprintf(buf, "%d", matchCodes[i]); + OP( DUP); + PushLiteral(envPtr, buf, strlen(buf)); + OP( EQ); + JUMP4( JUMP_FALSE, notCodeJumpSource); + if (matchClauses[i]) { + Tcl_ListObjLength(NULL, matchClauses[i], &len); /* - * There is a finally clause, so we need a fairly complex sequence - * of instructions to deal with an on/trap handler because we must - * call the finally handler *and* we need to substitute the result - * from a failed trap for the result from the main script. + * Match the errorcode according to try/trap rules. */ - if (resultVars[i] >= 0 || handlerTokens[i]) { - range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE); - OP4( BEGIN_CATCH4, range); - ExceptionRangeStarts(envPtr, range); - } - if (resultVars[i] >= 0) { - LOAD( resultVar); - STORE( resultVars[i]); - OP( POP); - if (optionVars[i] >= 0) { - LOAD( optionsVar); - STORE( optionVars[i]); - OP( POP); - } + LOAD( optionsVar); + PUSH( "-errorcode"); + OP4( DICT_GET, 1); + TclAdjustStackDepth(-1, envPtr); + OP44( LIST_RANGE_IMM, 0, len-1); + p = Tcl_GetStringFromObj(matchClauses[i], &len); + PushLiteral(envPtr, p, len); + OP( STR_EQ); + JUMP4( JUMP_FALSE, notECJumpSource); + } else { + notECJumpSource = -1; /* LINT */ + } + OP( POP); - if (!handlerTokens[i]) { - /* - * No handler. Will not be the last handler (that is a - * condition that is checked by the caller). Chain to the - * next one. - */ + /* + * There is a finally clause, so we need a fairly complex sequence of + * instructions to deal with an on/trap handler because we must call + * the finally handler *and* we need to substitute the result from a + * failed trap for the result from the main script. + */ - ExceptionRangeEnds(envPtr, range); - OP( END_CATCH); - forwardsNeedFixing = 1; - JUMP(forwardsToFix[i], JUMP4); - goto finishTrapCatchHandling; - } - } else if (!handlerTokens[i]) { + if (resultVars[i] >= 0 || handlerTokens[i]) { + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); + OP4( BEGIN_CATCH4, range); + ExceptionRangeStarts(envPtr, range); + } + if (resultVars[i] >= 0) { + LOAD( resultVar); + STORE( resultVars[i]); + OP( POP); + if (optionVars[i] >= 0) { + LOAD( optionsVar); + STORE( optionVars[i]); + OP( POP); + } + + if (!handlerTokens[i]) { /* - * No handler. Will not be the last handler (that condition is - * checked by the caller). Chain to the next one. + * No handler. Will not be the last handler (that is a + * condition that is checked by the caller). Chain to the next + * one. */ + ExceptionRangeEnds(envPtr, range); + OP( END_CATCH); forwardsNeedFixing = 1; - JUMP(forwardsToFix[i], JUMP4); - goto endOfThisArm; + JUMP4( JUMP, forwardsToFix[i]); + goto finishTrapCatchHandling; } - + } else if (!handlerTokens[i]) { /* - * Got a handler. Make sure that any pending patch-up actions from - * previous unprocessed handlers are dealt with now that we know - * where they are to jump to. + * No handler. Will not be the last handler (that condition is + * checked by the caller). Chain to the next one. */ - if (forwardsNeedFixing) { - forwardsNeedFixing = 0; - OP1( JUMP1, 7); - for (j=0 ; j<i ; j++) { - if (forwardsToFix[j] == -1) { - continue; - } - FIXJUMP(forwardsToFix[j]); - forwardsToFix[j] = -1; - } - OP4( BEGIN_CATCH4, range); - } - envPtr->currStackDepth = savedStackDepth; - BODY( handlerTokens[i], 5+i*4); - ExceptionRangeEnds(envPtr, range); - OP( PUSH_RETURN_OPTIONS); - OP4( REVERSE, 2); - OP1( JUMP1, 4); - forwardsToFix[i] = -1; - - /* - * Error in handler or setting of variables; replace the stored - * exception with the new one. Note that we only push this if we - * have either a body or some variable setting here. Otherwise - * this code is unreachable. - */ + forwardsNeedFixing = 1; + JUMP4( JUMP, forwardsToFix[i]); + goto endOfThisArm; + } - finishTrapCatchHandling: - ExceptionRangeTarget(envPtr, range, catchOffset); - OP( PUSH_RETURN_OPTIONS); - OP( PUSH_RESULT); - OP( END_CATCH); - STORE( resultVar); - OP( POP); - STORE( optionsVar); - OP( POP); + /* + * Got a handler. Make sure that any pending patch-up actions from + * previous unprocessed handlers are dealt with now that we know where + * they are to jump to. + */ - endOfThisArm: - if (i+1 < numHandlers) { - JUMP(addrsToFix[i], JUMP4); - } - if (matchClauses[i]) { - FIXJUMP(notECJumpSource); + if (forwardsNeedFixing) { + forwardsNeedFixing = 0; + OP1( JUMP1, 7); + for (j=0 ; j<i ; j++) { + if (forwardsToFix[j] == -1) { + continue; + } + FIXJUMP4( forwardsToFix[j]); + forwardsToFix[j] = -1; } - FIXJUMP(notCodeJumpSource); + OP4( BEGIN_CATCH4, range); } + BODY( handlerTokens[i], 5+i*4); + ExceptionRangeEnds(envPtr, range); + PUSH( "0"); + OP( PUSH_RETURN_OPTIONS); + OP4( REVERSE, 3); + OP1( JUMP1, 5); + TclAdjustStackDepth(-3, envPtr); + forwardsToFix[i] = -1; /* - * Fix all the jumps from taken clauses to here (the start of the - * finally clause). + * Error in handler or setting of variables; replace the stored + * exception with the new one. Note that we only push this if we have + * either a body or some variable setting here. Otherwise this code is + * unreachable. */ - for (i=0 ; i<numHandlers-1 ; i++) { - FIXJUMP(addrsToFix[i]); + finishTrapCatchHandling: + ExceptionRangeTarget(envPtr, range, catchOffset); + OP( PUSH_RETURN_OPTIONS); + OP( PUSH_RETURN_CODE); + OP( PUSH_RESULT); + OP( END_CATCH); + STORE( resultVar); + OP( POP); + PUSH( "1"); + OP( EQ); + JUMP1( JUMP_FALSE, noTrapError); + LOAD( optionsVar); + PUSH( "-during"); + OP4( REVERSE, 3); + STORE( optionsVar); + OP( POP); + OP44( DICT_SET, 1, optionsVar); + TclAdjustStackDepth(-1, envPtr); + JUMP1( JUMP, trapError); + FIXJUMP1( noTrapError); + STORE( optionsVar); + FIXJUMP1( trapError); + /* Skip POP at end; can clean up with subsequent POP */ + if (i+1 < numHandlers) { + OP( POP); } - TclStackFree(interp, forwardsToFix); - TclStackFree(interp, addrsToFix); + + endOfThisArm: + if (i+1 < numHandlers) { + JUMP4( JUMP, addrsToFix[i]); + TclAdjustStackDepth(1, envPtr); + } + if (matchClauses[i]) { + FIXJUMP4( notECJumpSource); + } + FIXJUMP4( notCodeJumpSource); } /* - * Drop the result code. + * Drop the result code, and fix all the jumps from taken clauses - which + * drop the result code as their first action - to point straight after + * (i.e., to the start of the finally clause). */ OP( POP); + for (i=0 ; i<numHandlers-1 ; i++) { + FIXJUMP4( addrsToFix[i]); + } + TclStackFree(interp, forwardsToFix); + TclStackFree(interp, addrsToFix); /* * Process the finally clause (at last!) Note that we do not wrap this in @@ -2692,16 +3296,106 @@ IssueTryFinallyInstructions( * next command (or some inter-command manipulation). */ - envPtr->currStackDepth = savedStackDepth; + if (!trapZero) { + FIXJUMP4( afterBody); + } + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); + OP4( BEGIN_CATCH4, range); + ExceptionRangeStarts(envPtr, range); BODY( finallyToken, 3 + 4*numHandlers); + ExceptionRangeEnds(envPtr, range); + OP( END_CATCH); + OP( POP); + JUMP1( JUMP, finalOK); + ExceptionRangeTarget(envPtr, range, catchOffset); + OP( PUSH_RESULT); + OP( PUSH_RETURN_OPTIONS); + OP( PUSH_RETURN_CODE); + OP( END_CATCH); + PUSH( "1"); + OP( EQ); + JUMP1( JUMP_FALSE, noFinalError); + LOAD( optionsVar); + PUSH( "-during"); + OP4( REVERSE, 3); + STORE( optionsVar); + OP( POP); + OP44( DICT_SET, 1, optionsVar); + TclAdjustStackDepth(-1, envPtr); + OP( POP); + JUMP1( JUMP, finalError); + TclAdjustStackDepth(1, envPtr); + FIXJUMP1( noFinalError); + STORE( optionsVar); + OP( POP); + FIXJUMP1( finalError); + STORE( resultVar); OP( POP); + FIXJUMP1( finalOK); LOAD( optionsVar); LOAD( resultVar); - OP( RETURN_STK); - envPtr->currStackDepth = savedStackDepth + 1; + INVOKE( RETURN_STK); return TCL_OK; } + +static int +IssueTryFinallyInstructions( + Tcl_Interp *interp, + CompileEnv *envPtr, + Tcl_Token *bodyToken, + Tcl_Token *finallyToken) +{ + DefineLineInformation; /* TIP #280 */ + int range, jumpOK, jumpSplice; + + /* + * Note that this one is simple enough that we can issue it without + * needing a local variable table, making it a universal compilation. + */ + + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); + OP4( BEGIN_CATCH4, range); + ExceptionRangeStarts(envPtr, range); + BODY( bodyToken, 1); + ExceptionRangeEnds(envPtr, range); + OP1( JUMP1, 3); + TclAdjustStackDepth(-1, envPtr); + ExceptionRangeTarget(envPtr, range, catchOffset); + OP( PUSH_RESULT); + OP( PUSH_RETURN_OPTIONS); + OP( END_CATCH); + + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); + OP4( BEGIN_CATCH4, range); + ExceptionRangeStarts(envPtr, range); + BODY( finallyToken, 3); + ExceptionRangeEnds(envPtr, range); + OP( END_CATCH); + OP( POP); + JUMP1( JUMP, jumpOK); + ExceptionRangeTarget(envPtr, range, catchOffset); + OP( PUSH_RESULT); + OP( PUSH_RETURN_OPTIONS); + OP( PUSH_RETURN_CODE); + OP( END_CATCH); + PUSH( "1"); + OP( EQ); + JUMP1( JUMP_FALSE, jumpSplice); + PUSH( "-during"); + OP4( OVER, 3); + OP4( LIST, 2); + OP( LIST_CONCAT); + FIXJUMP1( jumpSplice); + OP4( REVERSE, 4); + OP( POP); + OP( POP); + OP1( JUMP1, 7); + FIXJUMP1( jumpOK); + OP4( REVERSE, 2); + INVOKE( RETURN_STK); + return TCL_OK; +} /* *---------------------------------------------------------------------- @@ -2731,38 +3425,81 @@ TclCompileUnsetCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr; - int isScalar, simpleVarName, localIndex, numWords, flags, i; - Tcl_Obj *leadingWord; + int isScalar, localIndex, flags = 1, i, varCount = 0, haveFlags = 0; DefineLineInformation; /* TIP #280 */ - numWords = parsePtr->numWords-1; - flags = 1; - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - leadingWord = Tcl_NewObj(); - if (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. - */ + /* TODO: Consider support for compiling expanded args. */ + + /* + * Verify that all words - except the first non-option one - are known at + * compile time so that we can handle them without needing to do a nasty + * push/rotate. [Bug 3970f54c4e] + */ + + for (i=1,varTokenPtr=parsePtr->tokenPtr ; i<parsePtr->numWords ; i++) { + Tcl_Obj *leadingWord = Tcl_NewObj(); + + varTokenPtr = TokenAfter(varTokenPtr); + if (!TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) { + TclDecrRefCount(leadingWord); + + /* + * We can tolerate non-trivial substitutions in the first variable + * to be unset. If a '--' or '-nocomplain' was present, anything + * goes in that one place! (All subsequent variable names must be + * constants since we don't want to have to push them all first.) + */ + if (varCount == 0) { + if (haveFlags) { + continue; + } + + /* + * In fact, we're OK as long as we're the first argument *and* + * we provably don't start with a '-'. If that is true, then + * even if everything else is varying, we still can't be a + * flag. Otherwise we'll spill to runtime to place a limit on + * the trickiness. + */ + + if (varTokenPtr->type == TCL_TOKEN_WORD + && varTokenPtr[1].type == TCL_TOKEN_TEXT + && varTokenPtr[1].size > 0 + && varTokenPtr[1].start[0] != '-') { + continue; + } + } + return TCL_ERROR; + } + if (i == 1) { + const char *bytes; + int len; + + bytes = Tcl_GetStringFromObj(leadingWord, &len); + if (len == 11 && !strncmp("-nocomplain", bytes, 11)) { + flags = 0; + haveFlags = 1; + } else if (len == 2 && !strncmp("--", bytes, 2)) { + haveFlags = 1; + } else { + varCount++; + } + } else { + varCount++; + } TclDecrRefCount(leadingWord); - return TCL_ERROR; } - TclDecrRefCount(leadingWord); - for (i=0 ; i<numWords ; i++) { + /* + * Issue instructions to unset each of the named variables. + */ + + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + if (haveFlags) { + varTokenPtr = TokenAfter(varTokenPtr); + } + for (i=1+haveFlags ; i<parsePtr->numWords ; i++) { /* * Decide if we can use a frame slot for the var/array name or if we * need to emit code to compute and push the name at runtime. We use a @@ -2772,15 +3509,13 @@ TclCompileUnsetCmd( */ PushVarNameWord(interp, varTokenPtr, envPtr, 0, - &localIndex, &simpleVarName, &isScalar, 1); + &localIndex, &isScalar, i); /* * Emit instructions to unset the variable. */ - if (!simpleVarName) { - OP1( UNSET_STK, flags); - } else if (isScalar) { + if (isScalar) { if (localIndex < 0) { OP1( UNSET_STK, flags); } else { @@ -2796,7 +3531,7 @@ TclCompileUnsetCmd( varTokenPtr = TokenAfter(varTokenPtr); } - PushLiteral(envPtr, "", 0); + PUSH(""); return TCL_OK; } @@ -2830,7 +3565,6 @@ TclCompileWhileCmd( Tcl_Token *testTokenPtr, *bodyTokenPtr; JumpFixup jumpEvalCondFixup; int testCodeOffset, bodyCodeOffset, jumpDist, range, code, boolVal; - int savedStackDepth = envPtr->currStackDepth; int loopMayEnd = 1; /* This is set to 0 if it is recognized as an * infinite loop. */ Tcl_Obj *boolObj; @@ -2888,7 +3622,7 @@ TclCompileWhileCmd( * implement break and continue. */ - range = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE); + range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); /* * Jump to the evaluation of the condition. This code uses the "loop @@ -2914,7 +3648,7 @@ TclCompileWhileCmd( * INST_START_CMD, and hence counted properly. [Bug 1752146] */ - envPtr->atCmdStart = 0; + envPtr->atCmdStart &= ~1; testCodeOffset = CurrentOffset(envPtr); } @@ -2922,11 +3656,13 @@ TclCompileWhileCmd( * Compile the loop body. */ - SetLineInformation(2); bodyCodeOffset = ExceptionRangeStarts(envPtr, range); - CompileBody(envPtr, bodyTokenPtr, interp); + if (!loopMayEnd) { + envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset; + envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset; + } + BODY(bodyTokenPtr, 2); ExceptionRangeEnds(envPtr, range); - envPtr->currStackDepth = savedStackDepth + 1; OP( POP); /* @@ -2941,10 +3677,9 @@ TclCompileWhileCmd( bodyCodeOffset += 3; testCodeOffset += 3; } - envPtr->currStackDepth = savedStackDepth; SetLineInformation(1); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); - envPtr->currStackDepth = savedStackDepth + 1; + TclClearNumConversion(envPtr); jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; if (jumpDist > 127) { @@ -2968,14 +3703,14 @@ TclCompileWhileCmd( envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset; envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset; ExceptionRangeTarget(envPtr, range, breakOffset); + TclFinalizeLoopExceptionRange(envPtr, range); /* * The while command's result is an empty string. */ pushResult: - envPtr->currStackDepth = savedStackDepth; - PushLiteral(envPtr, "", 0); + PUSH(""); return TCL_OK; } @@ -3011,7 +3746,7 @@ TclCompileYieldCmd( } if (parsePtr->numWords == 1) { - PushLiteral(envPtr, "", 0); + PUSH(""); } else { DefineLineInformation; /* TIP #280 */ Tcl_Token *valueTokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -3025,240 +3760,45 @@ TclCompileYieldCmd( /* *---------------------------------------------------------------------- * - * PushVarName -- + * TclCompileYieldToCmd -- * - * Procedure used in the compiling where pushing a variable name is - * necessary (append, lappend, set). + * 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 "set" command at + * Instructions are added to envPtr to execute the "yieldto" command at * runtime. * *---------------------------------------------------------------------- */ -static int -PushVarName( +int +TclCompileYieldToCmd( Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Token *varTokenPtr, /* Points to a variable token. */ - CompileEnv *envPtr, /* Holds resulting instructions. */ - int flags, /* TCL_NO_LARGE_INDEX. */ - int *localIndexPtr, /* Must not be NULL. */ - int *simpleVarNamePtr, /* Must not be NULL. */ - int *isScalarPtr, /* Must not be NULL. */ - int line, /* Line the token starts on. */ - int *clNext) /* Reference to offset of next hidden cont. - * line. */ -{ - register const char *p; - const char *name, *elName; - register int i, n; - Tcl_Token *elemTokenPtr = NULL; - int nameChars, elNameChars, simpleVarName, localIndex; - int elemTokenCount = 0, allocedTokens = 0, removedParen = 0; - - /* - * Decide if we can use a frame slot for the var/array name or if we need - * to emit code to compute and push the name at runtime. We use a frame - * slot (entry in the array of local vars) if we are compiling a procedure - * body and if the name is simple text that does not include namespace - * qualifiers. - */ - - simpleVarName = 0; - name = elName = NULL; - nameChars = elNameChars = 0; - localIndex = -1; - - /* - * Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether - * curly braces surround the variable name. This really matters for array - * elements to handle things like - * set {x($foo)} 5 - * which raises an undefined var error if we are not careful here. - */ - - if ((varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) && - (varTokenPtr->start[0] != '{')) { - /* - * A simple variable name. Divide it up into "name" and "elName" - * strings. If it is not a local variable, look it up at runtime. - */ - - simpleVarName = 1; - - name = varTokenPtr[1].start; - nameChars = varTokenPtr[1].size; - if (name[nameChars-1] == ')') { - /* - * last char is ')' => potential array reference. - */ - - for (i=0,p=name ; i<nameChars ; i++,p++) { - if (*p == '(') { - elName = p + 1; - elNameChars = nameChars - i - 2; - nameChars = i; - break; - } - } - - if ((elName != NULL) && elNameChars) { - /* - * An array element, the element name is a simple string: - * assemble the corresponding token. - */ - - elemTokenPtr = TclStackAlloc(interp, sizeof(Tcl_Token)); - allocedTokens = 1; - elemTokenPtr->type = TCL_TOKEN_TEXT; - elemTokenPtr->start = elName; - elemTokenPtr->size = elNameChars; - elemTokenPtr->numComponents = 0; - elemTokenCount = 1; - } - } - } else if (((n = varTokenPtr->numComponents) > 1) - && (varTokenPtr[1].type == TCL_TOKEN_TEXT) - && (varTokenPtr[n].type == TCL_TOKEN_TEXT) - && (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) { - /* - * Check for parentheses inside first token. - */ - - simpleVarName = 0; - for (i = 0, p = varTokenPtr[1].start; - i < varTokenPtr[1].size; i++, p++) { - if (*p == '(') { - simpleVarName = 1; - break; - } - } - if (simpleVarName) { - int remainingChars; - - /* - * Check the last token: if it is just ')', do not count it. - * Otherwise, remove the ')' and flag so that it is restored at - * the end. - */ - - if (varTokenPtr[n].size == 1) { - n--; - } else { - varTokenPtr[n].size--; - removedParen = n; - } - - name = varTokenPtr[1].start; - nameChars = p - varTokenPtr[1].start; - elName = p + 1; - remainingChars = (varTokenPtr[2].start - p) - 1; - elNameChars = (varTokenPtr[n].start-p) + varTokenPtr[n].size - 2; - - if (remainingChars) { - /* - * Make a first token with the extra characters in the first - * token. - */ - - elemTokenPtr = TclStackAlloc(interp, n * sizeof(Tcl_Token)); - allocedTokens = 1; - elemTokenPtr->type = TCL_TOKEN_TEXT; - elemTokenPtr->start = elName; - elemTokenPtr->size = remainingChars; - elemTokenPtr->numComponents = 0; - elemTokenCount = n; - - /* - * Copy the remaining tokens. - */ - - memcpy(elemTokenPtr+1, varTokenPtr+2, - (n-1) * sizeof(Tcl_Token)); - } else { - /* - * Use the already available tokens. - */ - - elemTokenPtr = &varTokenPtr[2]; - elemTokenCount = n - 1; - } - } - } - - if (simpleVarName) { - /* - * See whether name has any namespace separators (::'s). - */ - - int hasNsQualifiers = 0; - - for (i = 0, p = name; i < nameChars; i++, p++) { - if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) { - hasNsQualifiers = 1; - break; - } - } - - /* - * Look up the var name's index in the array of local vars in the proc - * frame. If retrieving the var's value and it doesn't already exist, - * push its name and look it up at runtime. - */ - - if (!hasNsQualifiers) { - localIndex = TclFindCompiledLocal(name, nameChars, - 1, envPtr); - if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) { - /* - * We'll push the name. - */ - - localIndex = -1; - } - } - if (localIndex < 0) { - PushLiteral(envPtr, name, nameChars); - } - - /* - * Compile the element script, if any. - */ - - if (elName != NULL) { - if (elNameChars) { - envPtr->line = line; - envPtr->clNext = clNext; - TclCompileTokens(interp, elemTokenPtr, elemTokenCount, - envPtr); - } else { - PushLiteral(envPtr, "", 0); - } - } - } else { - /* - * The var name isn't simple: compile and push it. - */ + 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; - envPtr->line = line; - envPtr->clNext = clNext; - CompileTokens(envPtr, varTokenPtr, interp); + if (parsePtr->numWords < 2) { + return TCL_ERROR; } - if (removedParen) { - varTokenPtr[removedParen].size++; - } - if (allocedTokens) { - TclStackFree(interp, elemTokenPtr); + OP( NS_CURRENT); + for (i = 1 ; i < parsePtr->numWords ; i++) { + CompileWord(envPtr, tokenPtr, interp, i); + tokenPtr = TokenAfter(tokenPtr); } - *localIndexPtr = localIndex; - *simpleVarNamePtr = simpleVarName; - *isScalarPtr = (elName == NULL); + OP4( LIST, i); + OP( YIELD_TO_INVOKE); return TCL_OK; } @@ -3333,6 +3873,7 @@ CompileAssociativeBinaryOpCmd( DefineLineInformation; /* TIP #280 */ int words; + /* TODO: Consider support for compiling expanded args. */ for (words=1 ; words<parsePtr->numWords ; words++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, words); @@ -3416,8 +3957,9 @@ CompileComparisonOpCmd( Tcl_Token *tokenPtr; DefineLineInformation; /* TIP #280 */ + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords < 3) { - PushLiteral(envPtr, "1", 1); + PUSH("1"); } else if (parsePtr->numWords == 3) { tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); @@ -3431,7 +3973,7 @@ CompileComparisonOpCmd( return TCL_ERROR; } else { - int tmpIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr); + int tmpIndex = AnonymousLocal(envPtr); int words; tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -3588,7 +4130,7 @@ TclCompilePowOpCmd( CompileWord(envPtr, tokenPtr, interp, words); } if (parsePtr->numWords <= 2) { - PushLiteral(envPtr, "1", 1); + PUSH("1"); words++; } while (--words > 1) { @@ -3753,6 +4295,7 @@ TclCompileMinusOpCmd( DefineLineInformation; /* TIP #280 */ int words; + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords == 1) { /* * Fallback to direct eval to report syntax error. @@ -3798,6 +4341,7 @@ TclCompileDivOpCmd( DefineLineInformation; /* TIP #280 */ int words; + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords == 1) { /* * Fallback to direct eval to report syntax error. @@ -3806,7 +4350,7 @@ TclCompileDivOpCmd( return TCL_ERROR; } if (parsePtr->numWords == 2) { - PushLiteral(envPtr, "1.0", 3); + PUSH("1.0"); } for (words=1 ; words<parsePtr->numWords ; words++) { tokenPtr = TokenAfter(tokenPtr); diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 890d518..94c1bd6 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -490,13 +490,6 @@ typedef struct JumpList { JumpFixup jump; /* Pass this argument to matching calls of * TclEmitForwardJump() and * TclFixupForwardJump(). */ - int depth; /* Remember the currStackDepth of the - * CompileEnv here. */ - int offset; /* Data used to compute jump lengths to pass - * to TclFixupForwardJump() */ - int convert; /* Temporary storage used to compute whether - * numeric conversion will be needed following - * the operator we're compiling. */ struct JumpList *next; /* Point to next item on the stack */ } JumpList; @@ -2207,7 +2200,7 @@ ExecConstantExprTree( TclInitByteCodeObj(byteCodeObj, envPtr); TclFreeCompileEnv(envPtr); TclStackFree(interp, envPtr); - byteCodePtr = byteCodeObj->internalRep.otherValuePtr; + byteCodePtr = byteCodeObj->internalRep.twoPtrValue.ptr1; TclNRExecuteByteCode(interp, byteCodePtr); code = TclNRRunCallbacks(interp, TCL_OK, rootPtr); Tcl_DecrRefCount(byteCodeObj); @@ -2261,30 +2254,8 @@ CompileExprTree( if (nodePtr->mark == MARK_LEFT) { next = nodePtr->left; - switch (nodePtr->lexeme) { - case QUESTION: - newJump = TclStackAlloc(interp, sizeof(JumpList)); - newJump->next = jumpPtr; - jumpPtr = newJump; - newJump = TclStackAlloc(interp, sizeof(JumpList)); - newJump->next = jumpPtr; - jumpPtr = newJump; - jumpPtr->depth = envPtr->currStackDepth; + if (nodePtr->lexeme == QUESTION) { convert = 1; - break; - case AND: - case OR: - newJump = TclStackAlloc(interp, sizeof(JumpList)); - newJump->next = jumpPtr; - jumpPtr = newJump; - newJump = TclStackAlloc(interp, sizeof(JumpList)); - newJump->next = jumpPtr; - jumpPtr = newJump; - newJump = TclStackAlloc(interp, sizeof(JumpList)); - newJump->next = jumpPtr; - jumpPtr = newJump; - jumpPtr->depth = envPtr->currStackDepth; - break; } } else if (nodePtr->mark == MARK_RIGHT) { next = nodePtr->right; @@ -2317,25 +2288,35 @@ CompileExprTree( break; } case QUESTION: + newJump = TclStackAlloc(interp, sizeof(JumpList)); + newJump->next = jumpPtr; + jumpPtr = newJump; TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpPtr->jump); break; case COLON: - CLANG_ASSERT(jumpPtr); + newJump = TclStackAlloc(interp, sizeof(JumpList)); + newJump->next = jumpPtr; + jumpPtr = newJump; TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &jumpPtr->next->jump); - envPtr->currStackDepth = jumpPtr->depth; - jumpPtr->offset = (envPtr->codeNext - envPtr->codeStart); - jumpPtr->convert = convert; + &jumpPtr->jump); + TclAdjustStackDepth(-1, envPtr); + if (convert) { + jumpPtr->jump.jumpType = TCL_TRUE_JUMP; + } convert = 1; break; case AND: - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpPtr->jump); - break; case OR: - TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &jumpPtr->jump); + newJump = TclStackAlloc(interp, sizeof(JumpList)); + newJump->next = jumpPtr; + jumpPtr = newJump; + TclEmitForwardJump(envPtr, (nodePtr->lexeme == AND) + ? TCL_FALSE_JUMP : TCL_TRUE_JUMP, &jumpPtr->jump); break; } } else { + int pc1, pc2, target; + switch (nodePtr->lexeme) { case START: case QUESTION: @@ -2354,9 +2335,9 @@ CompileExprTree( */ if (numWords < 255) { - TclEmitInstInt1(INST_INVOKE_STK1, numWords, envPtr); + TclEmitInvoke(envPtr, INST_INVOKE_STK1, numWords); } else { - TclEmitInstInt4(INST_INVOKE_STK4, numWords, envPtr); + TclEmitInvoke(envPtr, INST_INVOKE_STK4, numWords); } /* @@ -2375,18 +2356,20 @@ CompileExprTree( break; case COLON: CLANG_ASSERT(jumpPtr); - if (TclFixupForwardJump(envPtr, &jumpPtr->next->jump, - (envPtr->codeNext - envPtr->codeStart) - - jumpPtr->next->jump.codeOffset, 127)) { - jumpPtr->offset += 3; + if (jumpPtr->jump.jumpType == TCL_TRUE_JUMP) { + jumpPtr->jump.jumpType = TCL_UNCONDITIONAL_JUMP; + convert = 1; + } + target = jumpPtr->jump.codeOffset + 2; + if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) { + target += 3; } - TclFixupForwardJump(envPtr, &jumpPtr->jump, - jumpPtr->offset - jumpPtr->jump.codeOffset, 127); - convert |= jumpPtr->convert; - envPtr->currStackDepth = jumpPtr->depth + 1; freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); + TclFixupForwardJump(envPtr, &jumpPtr->jump, + target - jumpPtr->jump.codeOffset, 127); + freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); @@ -2394,29 +2377,24 @@ CompileExprTree( case AND: case OR: CLANG_ASSERT(jumpPtr); - TclEmitForwardJump(envPtr, (nodePtr->lexeme == AND) - ? TCL_FALSE_JUMP : TCL_TRUE_JUMP, - &jumpPtr->next->jump); + pc1 = CurrentOffset(envPtr); + TclEmitInstInt1((nodePtr->lexeme == AND) ? INST_JUMP_FALSE1 + : INST_JUMP_TRUE1, 0, envPtr); TclEmitPush(TclRegisterNewLiteral(envPtr, (nodePtr->lexeme == AND) ? "1" : "0", 1), envPtr); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &jumpPtr->next->next->jump); - TclFixupForwardJumpToHere(envPtr, &jumpPtr->next->jump, 127); + pc2 = CurrentOffset(envPtr); + TclEmitInstInt1(INST_JUMP1, 0, envPtr); + TclAdjustStackDepth(-1, envPtr); + TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc1, + envPtr->codeStart + pc1 + 1); if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) { - jumpPtr->next->next->jump.codeOffset += 3; + pc2 += 3; } TclEmitPush(TclRegisterNewLiteral(envPtr, (nodePtr->lexeme == AND) ? "0" : "1", 1), envPtr); - TclFixupForwardJumpToHere(envPtr, &jumpPtr->next->next->jump, - 127); + TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc2, + envPtr->codeStart + pc2 + 1); convert = 0; - envPtr->currStackDepth = jumpPtr->depth + 1; - freePtr = jumpPtr; - jumpPtr = jumpPtr->next; - TclStackFree(interp, freePtr); - freePtr = jumpPtr; - jumpPtr = jumpPtr->next; - TclStackFree(interp, freePtr); freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); @@ -2445,14 +2423,11 @@ CompileExprTree( Tcl_Obj *literal = *litObjv; if (optimize) { - int length, index; + int length; const char *bytes = TclGetStringFromObj(literal, &length); - LiteralEntry *lePtr; - Tcl_Obj *objPtr; - - index = TclRegisterNewLiteral(envPtr, bytes, length); - lePtr = envPtr->literalArrayPtr + index; - objPtr = lePtr->objPtr; + int index = TclRegisterNewLiteral(envPtr, bytes, length); + Tcl_Obj *objPtr = TclFetchLiteral(envPtr, index); + if ((objPtr->typePtr == NULL) && (literal->typePtr != NULL)) { /* * Would like to do this: @@ -2488,8 +2463,7 @@ CompileExprTree( break; } case OT_TOKENS: - TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, - envPtr); + CompileTokens(envPtr, tokenPtr, interp); tokenPtr += tokenPtr->numComponents + 1; break; default: @@ -2511,7 +2485,7 @@ CompileExprTree( index = TclRegisterNewLiteral(envPtr, objPtr->bytes, objPtr->length); - tableValue = envPtr->literalArrayPtr[index].objPtr; + tableValue = TclFetchLiteral(envPtr, index); if ((tableValue->typePtr == NULL) && (objPtr->typePtr != NULL)) { /* diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 45a74d7..347e3f0 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -14,6 +14,7 @@ #include "tclInt.h" #include "tclCompile.h" +#include <assert.h> /* * Table of all AuxData types. @@ -62,7 +63,7 @@ InstructionDesc const tclInstructionTable[] = { /* Pop the topmost stack object */ {"dup", 1, +1, 0, {OPERAND_NONE}}, /* Duplicate the topmost stack object and push the result */ - {"concat1", 2, INT_MIN, 1, {OPERAND_UINT1}}, + {"strcat", 2, INT_MIN, 1, {OPERAND_UINT1}}, /* Concatenate the top op1 items and push result */ {"invokeStk1", 2, INT_MIN, 1, {OPERAND_UINT1}}, /* Invoke command named objv[0]; <objc,objv> = <op1,top op1> */ @@ -309,7 +310,7 @@ InstructionDesc const tclInstructionTable[] = { {"pushReturnOpts", 1, +1, 0, {OPERAND_NONE}}, /* Push the interpreter's return option dictionary as an object on the * stack. */ - {"returnStk", 1, -2, 0, {OPERAND_NONE}}, + {"returnStk", 1, -1, 0, {OPERAND_NONE}}, /* Compiled [return]; options and result are on the stack, code and * level are in the options. */ @@ -382,7 +383,8 @@ InstructionDesc const tclInstructionTable[] = { /* finds namespace and otherName in stack, links to local variable at * index op1. Leaves the namespace on stack. */ {"syntax", 9, -1, 2, {OPERAND_INT4, OPERAND_UINT4}}, - /* Compiled bytecodes to signal syntax error. */ + /* Compiled bytecodes to signal syntax error. Equivalent to returnImm + * except for the ERR_ALREADY_LOGGED flag in the interpreter. */ {"reverse", 5, 0, 1, {OPERAND_UINT4}}, /* Reverse the order of the arg elements at the top of stack */ @@ -430,7 +432,7 @@ InstructionDesc const tclInstructionTable[] = { /* Map variable contents back into a dictionary in a variable. Part of * [dict with]. * Stack: ... dictVarName path keyList => ... */ - {"dictRecombineImm", 1, -2, 1, {OPERAND_LVT4}}, + {"dictRecombineImm", 5, -2, 1, {OPERAND_LVT4}}, /* Map variable contents back into a dictionary in the local variable * indicated by the LVT index. Part of [dict with]. * Stack: ... path keyList => ... */ @@ -491,6 +493,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. */ @@ -534,6 +537,119 @@ InstructionDesc const tclInstructionTable[] = { * the word at the top of the stack; * <objc,objv> = <op4,top op4 after popping 1> */ + {"listConcat", 1, -1, 0, {OPERAND_NONE}}, + /* Concatenates the two lists at the top of the stack into a single + * list and pushes that resulting list onto the stack. + * Stack: ... list1 list2 => ... [lconcat list1 list2] */ + + {"expandDrop", 1, 0, 0, {OPERAND_NONE}}, + /* Drops an element from the auxiliary stack, popping stack elements + * until the matching stack depth is reached. */ + + /* New foreach implementation */ + {"foreach_start", 5, +2, 1, {OPERAND_AUX4}}, + /* Initialize execution of a foreach loop. Operand is aux data index + * of the ForeachInfo structure for the foreach command. It pushes 2 + * elements which hold runtime params for foreach_step, they are later + * dropped by foreach_end together with the value lists. NOTE that the + * iterator-tracker and info reference must not be passed to bytecodes + * that handle normal Tcl values. NOTE that this instruction jumps to + * the foreach_step instruction paired with it; the stack info below + * is only nominal. + * Stack: ... listObjs... => ... listObjs... iterTracker info */ + {"foreach_step", 1, 0, 0, {OPERAND_NONE}}, + /* "Step" or begin next iteration of foreach loop. Assigns to foreach + * iteration variables. May jump to straight after the foreach_start + * that pushed the iterTracker and info values. MUST be followed + * immediately by a foreach_end. + * Stack: ... listObjs... iterTracker info => + * ... listObjs... iterTracker info */ + {"foreach_end", 1, 0, 0, {OPERAND_NONE}}, + /* Clean up a foreach loop by dropping the info value, the tracker + * value and the lists that were being iterated over. + * Stack: ... listObjs... iterTracker info => ... */ + {"lmap_collect", 1, -1, 0, {OPERAND_NONE}}, + /* Appends the value at the top of the stack to the list located on + * the stack the "other side" of the foreach-related values. + * Stack: ... collector listObjs... iterTracker info value => + * ... collector listObjs... iterTracker info */ + + {"strtrim", 1, -1, 0, {OPERAND_NONE}}, + /* [string trim] core: removes the characters (designated by the value + * at the top of the stack) from both ends of the string and pushes + * the resulting string. + * Stack: ... string charset => ... trimmedString */ + {"strtrimLeft", 1, -1, 0, {OPERAND_NONE}}, + /* [string trimleft] core: removes the characters (designated by the + * value at the top of the stack) from the left of the string and + * pushes the resulting string. + * Stack: ... string charset => ... trimmedString */ + {"strtrimRight", 1, -1, 0, {OPERAND_NONE}}, + /* [string trimright] core: removes the characters (designated by the + * value at the top of the stack) from the right of the string and + * pushes the resulting string. + * Stack: ... string charset => ... trimmedString */ + + {"concatStk", 5, INT_MIN, 1, {OPERAND_UINT4}}, + /* Wrapper round Tcl_ConcatObj(), used for [concat] and [eval]. opnd + * is number of values to concatenate. + * Operation: push concat(stk1 stk2 ... stktop) */ + + {"strcaseUpper", 1, 0, 0, {OPERAND_NONE}}, + /* [string toupper] core: converts whole string to upper case using + * the default (extended "C" locale) rules. + * Stack: ... string => ... newString */ + {"strcaseLower", 1, 0, 0, {OPERAND_NONE}}, + /* [string tolower] core: converts whole string to upper case using + * the default (extended "C" locale) rules. + * Stack: ... string => ... newString */ + {"strcaseTitle", 1, 0, 0, {OPERAND_NONE}}, + /* [string totitle] core: converts whole string to upper case using + * the default (extended "C" locale) rules. + * Stack: ... string => ... newString */ + {"strreplace", 1, -3, 0, {OPERAND_NONE}}, + /* [string replace] core: replaces a non-empty range of one string + * with the contents of another. + * Stack: ... string fromIdx toIdx replacement => ... newString */ + + {"originCmd", 1, 0, 0, {OPERAND_NONE}}, + /* Reports which command was the origin (via namespace import chain) + * of the command named on the top of the stack. + * Stack: ... cmdName => ... fullOriginalCmdName */ + + {"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 */ + {NULL, 0, 0, 0, {OPERAND_NONE}} }; @@ -554,11 +670,15 @@ static void EnterCmdStartData(CompileEnv *envPtr, static void FreeByteCodeInternalRep(Tcl_Obj *objPtr); static void FreeSubstCodeInternalRep(Tcl_Obj *objPtr); static int GetCmdLocEncodingSize(CompileEnv *envPtr); +static int IsCompactibleCompileEnv(Tcl_Interp *interp, + CompileEnv *envPtr); #ifdef TCL_COMPILE_STATS static void RecordByteCodeStats(ByteCode *codePtr); #endif /* TCL_COMPILE_STATS */ +static void RegisterAuxDataType(const AuxDataType *typePtr); static int SetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); +static void StartExpanding(CompileEnv *envPtr); static int FormatInstruction(ByteCode *codePtr, const unsigned char *pc, Tcl_Obj *bufferObj); static void PrintSourceToObj(Tcl_Obj *appendObj, @@ -573,6 +693,7 @@ static void EnterCmdWordData(ExtCmdLoc *eclPtr, int srcOffset, Tcl_Token *tokenPtr, const char *cmd, int len, int numWords, int line, int *clNext, int **lines, CompileEnv *envPtr); +static void ReleaseCmdWordData(ExtCmdLoc *eclPtr); /* * The structure below defines the bytecode Tcl object type by means of @@ -612,6 +733,13 @@ static const Tcl_ObjType tclInstNameType = { UpdateStringOfInstName, /* updateStringProc */ NULL, /* setFromAnyProc */ }; + +/* + * Helper macros. + */ + +#define TclIncrUInt4AtPtr(ptr, delta) \ + TclStoreInt4AtPtr(TclGetUInt4AtPtr(ptr)+(delta), (ptr)); /* *---------------------------------------------------------------------- @@ -650,11 +778,9 @@ TclSetByteCodeFromAny( Interp *iPtr = (Interp *) interp; CompileEnv compEnv; /* Compilation environment structure allocated * in frame. */ - register const AuxData *auxDataPtr; - LiteralEntry *entryPtr; - register int i; int length, result = TCL_OK; const char *stringPtr; + Proc *procPtr = iPtr->compiledProcPtr; ContLineLoc *clLocPtr; #ifdef TCL_COMPILE_DEBUG @@ -692,9 +818,7 @@ TclSetByteCodeFromAny( clLocPtr = TclContinuationsGet(objPtr); if (clLocPtr) { - compEnv.clLoc = clLocPtr; - compEnv.clNext = &compEnv.clLoc->loc[0]; - Tcl_Preserve(compEnv.clLoc); + compEnv.clNext = &clLocPtr->loc[0]; } TclCompileScript(interp, stringPtr, length, &compEnv); @@ -706,6 +830,40 @@ TclSetByteCodeFromAny( TclEmitOpcode(INST_DONE, &compEnv); /* + * Check for optimizations! + * + * Test if the generated code is free of most hazards; if so, recompile + * but with generation of INST_START_CMD disabled. This produces somewhat + * faster code in some cases, and more compact code in more. + */ + + if (Tcl_GetMaster(interp) == NULL && + !Tcl_LimitTypeEnabled(interp, TCL_LIMIT_COMMANDS|TCL_LIMIT_TIME) + && IsCompactibleCompileEnv(interp, &compEnv)) { + TclFreeCompileEnv(&compEnv); + iPtr->compiledProcPtr = procPtr; + TclInitCompileEnv(interp, &compEnv, stringPtr, length, + iPtr->invokeCmdFramePtr, iPtr->invokeWord); + if (clLocPtr) { + compEnv.clNext = &clLocPtr->loc[0]; + } + compEnv.atCmdStart = 2; /* The disabling magic. */ + TclCompileScript(interp, stringPtr, length, &compEnv); + assert (compEnv.atCmdStart > 1); + TclEmitOpcode(INST_DONE, &compEnv); + assert (compEnv.atCmdStart > 1); + } + + /* + * Apply some peephole optimizations that can cross specific/generic + * instruction generator boundaries. + */ + + if (iPtr->extra.optimizer) { + (iPtr->extra.optimizer)(&compEnv); + } + + /* * Invoke the compilation hook procedure if one exists. */ @@ -722,35 +880,14 @@ TclSetByteCodeFromAny( TclVerifyLocalLiteralTable(&compEnv); #endif /*TCL_COMPILE_DEBUG*/ - TclInitByteCodeObj(objPtr, &compEnv); -#ifdef TCL_COMPILE_DEBUG - if (tclTraceCompile >= 2) { - TclPrintByteCodeObj(interp, objPtr); - fflush(stdout); - } -#endif /* TCL_COMPILE_DEBUG */ - - if (result != TCL_OK) { - /* - * Handle any error from the hookProc - */ - - entryPtr = compEnv.literalArrayPtr; - for (i = 0; i < compEnv.literalArrayNext; i++) { - TclReleaseLiteral(interp, entryPtr->objPtr); - entryPtr++; - } + if (result == TCL_OK) { + TclInitByteCodeObj(objPtr, &compEnv); #ifdef TCL_COMPILE_DEBUG - TclVerifyGlobalLiteralTable(iPtr); -#endif /*TCL_COMPILE_DEBUG*/ - - auxDataPtr = compEnv.auxDataArrayPtr; - for (i = 0; i < compEnv.auxDataArrayNext; i++) { - if (auxDataPtr->type->freeProc != NULL) { - auxDataPtr->type->freeProc(auxDataPtr->clientData); - } - auxDataPtr++; + if (tclTraceCompile >= 2) { + TclPrintByteCodeObj(interp, objPtr); + fflush(stdout); } +#endif /* TCL_COMPILE_DEBUG */ } TclFreeCompileEnv(&compEnv); @@ -789,8 +926,7 @@ SetByteCodeFromAny( if (interp == NULL) { return TCL_ERROR; } - TclSetByteCodeFromAny(interp, objPtr, NULL, NULL); - return TCL_OK; + return TclSetByteCodeFromAny(interp, objPtr, NULL, NULL); } /* @@ -844,10 +980,9 @@ static void FreeByteCodeInternalRep( register Tcl_Obj *objPtr) /* Object whose internal rep to free. */ { - register ByteCode *codePtr = objPtr->internalRep.otherValuePtr; + register ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; objPtr->typePtr = NULL; - objPtr->internalRep.otherValuePtr = NULL; codePtr->refCount--; if (codePtr->refCount <= 0) { TclCleanupByteCode(codePtr); @@ -867,9 +1002,8 @@ FreeByteCodeInternalRep( * None. * * Side effects: - * Frees objPtr's bytecode internal representation and sets its type and - * objPtr->internalRep.otherValuePtr NULL. Also releases its literals and - * frees its auxiliary data items. + * Frees objPtr's bytecode internal representation and sets its type NULL + * Also releases its literals and frees its auxiliary data items. * *---------------------------------------------------------------------- */ @@ -944,7 +1078,7 @@ TclCleanupByteCode( * released. */ - if ((codePtr->flags & TCL_BYTECODE_PRECOMPILED) || (interp == NULL)) { + if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { objArrayPtr = codePtr->objArrayPtr; for (i = 0; i < numLitObjects; i++) { @@ -957,17 +1091,9 @@ TclCleanupByteCode( codePtr->numLitObjects = 0; } else { objArrayPtr = codePtr->objArrayPtr; - for (i = 0; i < numLitObjects; i++) { - /* - * TclReleaseLiteral sets a ByteCode's object array entry NULL to - * indicate that it has already freed the literal. - */ - - objPtr = *objArrayPtr; - if (objPtr != NULL) { - TclReleaseLiteral(interp, objPtr); - } - objArrayPtr++; + while (numLitObjects--) { + /* TclReleaseLiteral calls Tcl_DecrRefCount() for us */ + TclReleaseLiteral(interp, *objArrayPtr++); } } @@ -992,22 +1118,7 @@ TclCleanupByteCode( (char *) codePtr); if (hePtr) { - ExtCmdLoc *eclPtr = Tcl_GetHashValue(hePtr); - - if (eclPtr->type == TCL_LOCATION_SOURCE) { - Tcl_DecrRefCount(eclPtr->path); - } - for (i=0 ; i<eclPtr->nuloc ; i++) { - ckfree(eclPtr->loc[i].line); - } - - if (eclPtr->loc != NULL) { - ckfree(eclPtr->loc); - } - - Tcl_DeleteHashTable(&eclPtr->litInfo); - - ckfree(eclPtr); + ReleaseCmdWordData(Tcl_GetHashValue(hePtr)); Tcl_DeleteHashEntry(hePtr); } } @@ -1021,6 +1132,77 @@ TclCleanupByteCode( } /* + * --------------------------------------------------------------------- + * + * IsCompactibleCompileEnv -- + * + * Checks to see if we may apply some basic compaction optimizations to a + * piece of bytecode. Idempotent. + * + * --------------------------------------------------------------------- + */ + +static int +IsCompactibleCompileEnv( + Tcl_Interp *interp, + CompileEnv *envPtr) +{ + unsigned char *pc; + int size; + + /* + * Special: procedures in the '::tcl' namespace (or its children) are + * considered to be well-behaved and so can have compaction applied even + * if it would otherwise be invalid. + */ + + if (envPtr->procPtr != NULL && envPtr->procPtr->cmdPtr != NULL + && envPtr->procPtr->cmdPtr->nsPtr != NULL) { + Namespace *nsPtr = envPtr->procPtr->cmdPtr->nsPtr; + + if (strcmp(nsPtr->fullName, "::tcl") == 0 + || strncmp(nsPtr->fullName, "::tcl::", 7) == 0) { + return 1; + } + } + + /* + * Go through and ensure that no operation involved can cause a desired + * change of bytecode sequence during running. This comes down to ensuring + * that there are no mapped variables (due to traces) or calls to external + * commands (traces, [uplevel] trickery). This is actually a very + * conservative check; it turns down a lot of code that is OK in practice. + */ + + for (pc = envPtr->codeStart ; pc < envPtr->codeNext ; pc += size) { + switch (*pc) { + /* Invokes */ + case INST_INVOKE_STK1: + case INST_INVOKE_STK4: + case INST_INVOKE_EXPANDED: + case INST_INVOKE_REPLACE: + return 0; + /* Runtime evals */ + case INST_EVAL_STK: + case INST_EXPR_STK: + case INST_YIELD: + return 0; + /* Upvars */ + case INST_UPVAR: + case INST_NSUPVAR: + case INST_VARIABLE: + return 0; + default: + size = tclInstructionTable[*pc].numBytes; + assert (size > 0); + break; + } + } + + return 1; +} + +/* *---------------------------------------------------------------------- * * Tcl_SubstObj -- @@ -1144,14 +1326,19 @@ CompileSubstObj( objPtr->typePtr = &substCodeType; TclFreeCompileEnv(&compEnv); - codePtr = objPtr->internalRep.otherValuePtr; + codePtr = objPtr->internalRep.twoPtrValue.ptr1; objPtr->internalRep.ptrAndLongRep.ptr = codePtr; objPtr->internalRep.ptrAndLongRep.value = flags; if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; } - /* TODO: Debug printing? */ +#ifdef TCL_COMPILE_DEBUG + if (tclTraceCompile >= 2) { + TclPrintByteCodeObj(interp, objPtr); + fflush(stdout); + } +#endif /* TCL_COMPILE_DEBUG */ } return codePtr; } @@ -1183,12 +1370,31 @@ FreeSubstCodeInternalRep( register ByteCode *codePtr = objPtr->internalRep.ptrAndLongRep.ptr; objPtr->typePtr = NULL; - objPtr->internalRep.otherValuePtr = NULL; codePtr->refCount--; if (codePtr->refCount <= 0) { TclCleanupByteCode(codePtr); } } + +static void +ReleaseCmdWordData( + ExtCmdLoc *eclPtr) +{ + int i; + + if (eclPtr->type == TCL_LOCATION_SOURCE) { + Tcl_DecrRefCount(eclPtr->path); + } + for (i=0 ; i<eclPtr->nuloc ; i++) { + ckfree((char *) eclPtr->loc[i].line); + } + + if (eclPtr->loc != NULL) { + ckfree((char *) eclPtr->loc); + } + + ckfree((char *) eclPtr); +} /* *---------------------------------------------------------------------- @@ -1221,6 +1427,8 @@ TclInitCompileEnv( { Interp *iPtr = (Interp *) interp; + assert(tclInstructionTable[LAST_INST_OPCODE+1].name == NULL); + envPtr->iPtr = iPtr; envPtr->source = stringPtr; envPtr->numSrcBytes = numBytes; @@ -1244,6 +1452,7 @@ TclInitCompileEnv( envPtr->mallocedLiteralArray = 0; envPtr->exceptArrayPtr = envPtr->staticExceptArraySpace; + envPtr->exceptAuxArrayPtr = envPtr->staticExAuxArraySpace; envPtr->exceptArrayNext = 0; envPtr->exceptArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES; envPtr->mallocedExceptArray = 0; @@ -1252,6 +1461,7 @@ TclInitCompileEnv( envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE; envPtr->mallocedCmdMap = 0; envPtr->atCmdStart = 1; + envPtr->expandCount = 0; /* * TIP #280: Set up the extended command location information, based on @@ -1267,9 +1477,8 @@ TclInitCompileEnv( envPtr->extCmdMapPtr->nloc = 0; envPtr->extCmdMapPtr->nuloc = 0; envPtr->extCmdMapPtr->path = NULL; - Tcl_InitHashTable(&envPtr->extCmdMapPtr->litInfo, TCL_ONE_WORD_KEYS); - if ((invoker == NULL) || (invoker->type == TCL_LOCATION_EVAL_LIST)) { + if (invoker == NULL) { /* * Initialize the compiler for relative counting in case of a * dynamic context. @@ -1383,7 +1592,6 @@ TclInitCompileEnv( * data is available. */ - envPtr->clLoc = NULL; envPtr->clNext = NULL; envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace; @@ -1422,6 +1630,32 @@ TclFreeCompileEnv( ckfree(envPtr->localLitTable.buckets); envPtr->localLitTable.buckets = envPtr->localLitTable.staticBuckets; } + if (envPtr->iPtr) { + /* + * We never converted to Bytecode, so free the things we would + * have transferred to it. + */ + + int i; + LiteralEntry *entryPtr = envPtr->literalArrayPtr; + AuxData *auxDataPtr = envPtr->auxDataArrayPtr; + + for (i = 0; i < envPtr->literalArrayNext; i++) { + TclReleaseLiteral((Tcl_Interp *)envPtr->iPtr, entryPtr->objPtr); + entryPtr++; + } + +#ifdef TCL_COMPILE_DEBUG + TclVerifyGlobalLiteralTable(envPtr->iPtr); +#endif /*TCL_COMPILE_DEBUG*/ + + for (i = 0; i < envPtr->auxDataArrayNext; i++) { + if (auxDataPtr->type->freeProc != NULL) { + auxDataPtr->type->freeProc(auxDataPtr->clientData); + } + auxDataPtr++; + } + } if (envPtr->mallocedCodeArray) { ckfree(envPtr->codeStart); } @@ -1430,6 +1664,7 @@ TclFreeCompileEnv( } if (envPtr->mallocedExceptArray) { ckfree(envPtr->exceptArrayPtr); + ckfree(envPtr->exceptAuxArrayPtr); } if (envPtr->mallocedCmdMap) { ckfree(envPtr->cmdMapPtr); @@ -1438,17 +1673,8 @@ TclFreeCompileEnv( ckfree(envPtr->auxDataArrayPtr); } if (envPtr->extCmdMapPtr) { - ckfree(envPtr->extCmdMapPtr); - } - - /* - * If we used data about invisible continuation lines, then now is the - * time to release on our hold on it. The lock was set in function - * TclSetByteCodeFromAny(), found in this file. - */ - - if (envPtr->clLoc) { - Tcl_Release(envPtr->clLoc); + ReleaseCmdWordData(envPtr->extCmdMapPtr); + envPtr->extCmdMapPtr = NULL; } } @@ -1550,474 +1776,467 @@ TclWordKnownAtCompileTime( *---------------------------------------------------------------------- */ +static int +ExpandRequested( + Tcl_Token *tokenPtr, + int numWords) +{ + /* Determine whether any words of the command require expansion */ + while (numWords--) { + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + return 1; + } + tokenPtr = TokenAfter(tokenPtr); + } + return 0; +} + +static void +CompileCmdLiteral( + Tcl_Interp *interp, + Tcl_Obj *cmdObj, + CompileEnv *envPtr) +{ + int numBytes; + const char *bytes = Tcl_GetStringFromObj(cmdObj, &numBytes); + int cmdLitIdx = TclRegisterNewCmdLiteral(envPtr, bytes, numBytes); + Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); + + if (cmdPtr) { + TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr); + } + TclEmitPush(cmdLitIdx, envPtr); +} + void -TclCompileScript( - Tcl_Interp *interp, /* Used for error and status reporting. Also - * serves as context for finding and compiling - * commands. May not be NULL. */ - const char *script, /* The source script to compile. */ - int numBytes, /* Number of bytes in script. If < 0, the - * script consists of all bytes up to the - * first null character. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ +TclCompileInvocation( + Tcl_Interp *interp, + Tcl_Token *tokenPtr, + Tcl_Obj *cmdObj, + int numWords, + CompileEnv *envPtr) { - Interp *iPtr = (Interp *) interp; - int lastTopLevelCmdIndex = -1; - /* Index of most recent toplevel command in - * the command location table. Initialized to - * avoid compiler warning. */ - int startCodeOffset = -1; /* Offset of first byte of current command's - * code. Init. to avoid compiler warning. */ - unsigned char *entryCodeNext = envPtr->codeNext; - const char *p, *next; - Namespace *cmdNsPtr; - Command *cmdPtr; - Tcl_Token *tokenPtr; - int bytesLeft, isFirstCmd, wordIdx, currCmdIndex, commandLength, objIndex; - Tcl_DString ds; - /* TIP #280 */ - ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; - int *wlines, wlineat, cmdLine, *clNext; - Tcl_Parse *parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse)); + int wordIdx = 0, depth = TclGetStackDepth(envPtr); + DefineLineInformation; + + if (cmdObj) { + CompileCmdLiteral(interp, cmdObj, envPtr); + wordIdx = 1; + tokenPtr = TokenAfter(tokenPtr); + } - Tcl_DStringInit(&ds); + for (; wordIdx < numWords; wordIdx++, tokenPtr = TokenAfter(tokenPtr)) { + int objIdx; - if (numBytes < 0) { - numBytes = strlen(script); + SetLineInformation(wordIdx); + + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + CompileTokens(envPtr, tokenPtr, interp); + continue; + } + + objIdx = TclRegisterNewLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size); + if (envPtr->clNext) { + TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), + tokenPtr[1].start - envPtr->source, envPtr->clNext); + } + TclEmitPush(objIdx, envPtr); } - Tcl_ResetResult(interp); - isFirstCmd = 1; - if (envPtr->procPtr != NULL) { - cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr; + if (wordIdx <= 255) { + TclEmitInvoke(envPtr, INST_INVOKE_STK1, wordIdx); } else { - cmdNsPtr = NULL; /* use current NS */ + TclEmitInvoke(envPtr, INST_INVOKE_STK4, wordIdx); } + TclCheckStackDepth(depth+1, envPtr); +} - /* - * Each iteration through the following loop compiles the next command - * from the script. - */ +static void +CompileExpanded( + Tcl_Interp *interp, + Tcl_Token *tokenPtr, + Tcl_Obj *cmdObj, + int numWords, + CompileEnv *envPtr) +{ + int wordIdx = 0; + DefineLineInformation; + int depth = TclGetStackDepth(envPtr); + + StartExpanding(envPtr); + if (cmdObj) { + CompileCmdLiteral(interp, cmdObj, envPtr); + wordIdx = 1; + tokenPtr = TokenAfter(tokenPtr); + } - p = script; - bytesLeft = numBytes; - cmdLine = envPtr->line; - clNext = envPtr->clNext; - do { - if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) { - /* - * Compile bytecodes to report the parse error at runtime. - */ + for (; wordIdx < numWords; wordIdx++, tokenPtr = TokenAfter(tokenPtr)) { + int objIdx; - Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, - /* Drop the command terminator (";","]") if appropriate */ - (parsePtr->term == - parsePtr->commandStart + parsePtr->commandSize - 1)? - parsePtr->commandSize - 1 : parsePtr->commandSize); - TclCompileSyntaxError(interp, envPtr); - break; + SetLineInformation(wordIdx); + + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + CompileTokens(envPtr, tokenPtr, interp); + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + TclEmitInstInt4(INST_EXPAND_STKTOP, + envPtr->currStackDepth, envPtr); + } + continue; } - /* - * TIP #280: We have to count newlines before the command even in the - * degenerate case when the command has no words. (See test - * info-30.33). - * So make that counting here, and not in the (numWords > 0) branch - * below. - */ + objIdx = TclRegisterNewLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size); + if (envPtr->clNext) { + TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), + tokenPtr[1].start - envPtr->source, envPtr->clNext); + } + TclEmitPush(objIdx, envPtr); + } - TclAdvanceLines(&cmdLine, p, parsePtr->commandStart); - TclAdvanceContinuations(&cmdLine, &clNext, - parsePtr->commandStart - envPtr->source); + /* + * The stack depth during argument expansion can only be managed at + * runtime, as the number of elements in the expanded lists is not known + * at compile time. We adjust here the stack depth estimate so that it is + * correct after the command with expanded arguments returns. + * + * The end effect of this command's invocation is that all the words of + * the command are popped from the stack, and the result is pushed: the + * stack top changes by (1-wordIdx). + * + * Note that the estimates are not correct while the command is being + * prepared and run, INST_EXPAND_STKTOP is not stack-neutral in general. + */ - if (parsePtr->numWords > 0) { - int expand = 0; /* Set if there are dynamic expansions to - * handle */ + TclEmitInvoke(envPtr, INST_INVOKE_EXPANDED, wordIdx); + TclCheckStackDepth(depth+1, envPtr); +} - /* - * If not the first command, pop the previous command's result - * and, if we're compiling a top level command, update the last - * command's code size to account for the pop instruction. - */ +static int +CompileCmdCompileProc( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + Command *cmdPtr, + CompileEnv *envPtr) +{ + int unwind = 0, incrOffset = -1; + DefineLineInformation; + int depth = TclGetStackDepth(envPtr); - if (!isFirstCmd) { - TclEmitOpcode(INST_POP, envPtr); - envPtr->cmdMapPtr[lastTopLevelCmdIndex].numCodeBytes = - (envPtr->codeNext - envPtr->codeStart) - - startCodeOffset; - } + /* + * Emit of the INST_START_CMD instruction is controlled by the value of + * envPtr->atCmdStart: + * + * atCmdStart == 2 : We are not using the INST_START_CMD instruction. + * atCmdStart == 1 : INST_START_CMD was the last instruction emitted. + * : We do not need to emit another. Instead we + * : increment the number of cmds started at it (except + * : for the special case at the start of a script.) + * atCmdStart == 0 : The last instruction was something else. We need + * : to emit INST_START_CMD here. + */ + + switch (envPtr->atCmdStart) { + case 0: + unwind = tclInstructionTable[INST_START_CMD].numBytes; + TclEmitInstInt4(INST_START_CMD, 0, envPtr); + incrOffset = envPtr->codeNext - envPtr->codeStart; + TclEmitInt4(0, envPtr); + break; + case 1: + if (envPtr->codeNext > envPtr->codeStart) { + incrOffset = envPtr->codeNext - 4 - envPtr->codeStart; + } + break; + case 2: + /* Nothing to do */ + ; + } + if (TCL_OK == TclAttemptCompileProc(interp, parsePtr, 1, cmdPtr, envPtr)) { + if (incrOffset >= 0) { /* - * Determine the actual length of the command. + * We successfully compiled a command. Increment the number of + * commands that start at the currently active INST_START_CMD. */ - commandLength = parsePtr->commandSize; - if (parsePtr->term == parsePtr->commandStart + commandLength-1) { - /* - * The command terminator character (such as ; or ]) is the - * last character in the parsed command. Reduce the length by - * one so that the trace message doesn't include the - * terminator character. - */ + unsigned char *incrPtr = envPtr->codeStart + incrOffset; + unsigned char *startPtr = incrPtr - 5; - commandLength -= 1; + TclIncrUInt4AtPtr(incrPtr, 1); + if (unwind) { + /* We started the INST_START_CMD. Record the code length. */ + TclStoreInt4AtPtr(envPtr->codeNext - startPtr, startPtr + 1); } + } + TclCheckStackDepth(depth+1, envPtr); + return TCL_OK; + } -#ifdef TCL_COMPILE_DEBUG - /* - * If tracing, print a line for each top level command compiled. - */ + envPtr->codeNext -= unwind; /* Unwind INST_START_CMD */ - if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) { - fprintf(stdout, " Compiling: "); - TclPrintSource(stdout, parsePtr->commandStart, - TclMin(commandLength, 55)); - fprintf(stdout, "\n"); - } -#endif + /* + * Throw out any line information generated by the failed compile attempt. + */ - /* - * Check whether expansion has been requested for any of the - * words. - */ + while (mapPtr->nuloc - 1 > eclIndex) { + mapPtr->nuloc--; + ckfree(mapPtr->loc[mapPtr->nuloc].line); + mapPtr->loc[mapPtr->nuloc].line = NULL; + } - for (wordIdx = 0, tokenPtr = parsePtr->tokenPtr; - wordIdx < parsePtr->numWords; - wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { - if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { - expand = 1; - break; - } - } + /* + * Reset the index of next command. Toss out any from failed nested + * partial compiles. + */ - envPtr->numCommands++; - currCmdIndex = envPtr->numCommands - 1; - lastTopLevelCmdIndex = currCmdIndex; - startCodeOffset = envPtr->codeNext - envPtr->codeStart; - EnterCmdStartData(envPtr, currCmdIndex, - parsePtr->commandStart - envPtr->source, startCodeOffset); + envPtr->numCommands = mapPtr->nuloc; + return TCL_ERROR; +} - /* - * Should only start issuing instructions after the "command has - * started" so that the command range is correct in the bytecode. - */ +static int +CompileCommandTokens( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + CompileEnv *envPtr) +{ + Interp *iPtr = (Interp *) interp; + Tcl_Token *tokenPtr = parsePtr->tokenPtr; + ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; + Tcl_Obj *cmdObj = Tcl_NewObj(); + Command *cmdPtr = NULL; + int code = TCL_ERROR; + int cmdKnown, expand = -1; + int *wlines, wlineat; + int cmdLine = envPtr->line; + int *clNext = envPtr->clNext; + int cmdIdx = envPtr->numCommands; + int startCodeOffset = envPtr->codeNext - envPtr->codeStart; + int depth = TclGetStackDepth(envPtr); + + assert (parsePtr->numWords > 0); + + /* Pre-Compile */ + + envPtr->numCommands++; + EnterCmdStartData(envPtr, cmdIdx, + parsePtr->commandStart - envPtr->source, startCodeOffset); - if (expand) { - TclEmitOpcode(INST_EXPAND_START, envPtr); - } + /* + * TIP #280. Scan the words and compute the extended location information. + * The map first contain full per-word line information for use by the + * compiler. This is later replaced by a reduced form which signals + * non-literal words, stored in 'wlines'. + */ - /* - * TIP #280. Scan the words and compute the extended location - * information. The map first contain full per-word line - * information for use by the compiler. This is later replaced by - * a reduced form which signals non-literal words, stored in - * 'wlines'. - */ + EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source, + parsePtr->tokenPtr, parsePtr->commandStart, + parsePtr->commandSize, parsePtr->numWords, cmdLine, + clNext, &wlines, envPtr); + wlineat = eclPtr->nuloc - 1; - EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source, - parsePtr->tokenPtr, parsePtr->commandStart, - parsePtr->commandSize, parsePtr->numWords, cmdLine, - clNext, &wlines, envPtr); - wlineat = eclPtr->nuloc - 1; + envPtr->line = eclPtr->loc[wlineat].line[0]; + envPtr->clNext = eclPtr->loc[wlineat].next[0]; + /* Do we know the command word? */ + Tcl_IncrRefCount(cmdObj); + tokenPtr = parsePtr->tokenPtr; + cmdKnown = TclWordKnownAtCompileTime(tokenPtr, cmdObj); + + /* Is this a command we should (try to) compile with a compileProc ? */ + if (cmdKnown && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) { + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); + if (cmdPtr) { /* - * Each iteration of the following loop compiles one word from the - * command. + * Found a command. Test the ways we can be told not to attempt + * to compile it. */ + if ((cmdPtr->compileProc == NULL) + || (cmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION) + || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { + cmdPtr = NULL; + } + } + if (cmdPtr && !(cmdPtr->flags & CMD_COMPILES_EXPANDED)) { + expand = ExpandRequested(parsePtr->tokenPtr, parsePtr->numWords); + if (expand) { + /* We need to expand, but compileProc cannot. */ + cmdPtr = NULL; + } + } + } - for (wordIdx = 0, tokenPtr = parsePtr->tokenPtr; - wordIdx < parsePtr->numWords; wordIdx++, - tokenPtr += tokenPtr->numComponents + 1) { - - envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; - envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx]; - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - /* - * The word is not a simple string of characters. - */ + /* If cmdPtr != NULL, we will try to call cmdPtr->compileProc */ + if (cmdPtr) { + code = CompileCmdCompileProc(interp, parsePtr, cmdPtr, envPtr); + } - TclCompileTokens(interp, tokenPtr+1, - tokenPtr->numComponents, envPtr); - if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { - TclEmitInstInt4(INST_EXPAND_STKTOP, - envPtr->currStackDepth, envPtr); - } - continue; - } + if (code == TCL_ERROR) { + if (expand < 0) { + expand = ExpandRequested(parsePtr->tokenPtr, parsePtr->numWords); + } - /* - * This is a simple string of literal characters (i.e. we know - * it absolutely and can use it directly). If this is the - * first word and the command has a compile procedure, let it - * compile the command. - */ + if (expand) { + CompileExpanded(interp, parsePtr->tokenPtr, + cmdKnown ? cmdObj : NULL, parsePtr->numWords, envPtr); + } else { + TclCompileInvocation(interp, parsePtr->tokenPtr, + cmdKnown ? cmdObj : NULL, parsePtr->numWords, envPtr); + } + } - if ((wordIdx == 0) && !expand) { - /* - * We copy the string before trying to find the command by - * name. We used to modify the string in place, but this - * is not safe because the name resolution handlers could - * have side effects that rely on the unmodified string. - */ + Tcl_DecrRefCount(cmdObj); - TclDStringClear(&ds); - TclDStringAppendToken(&ds, &tokenPtr[1]); - - cmdPtr = (Command *) Tcl_FindCommand(interp, - Tcl_DStringValue(&ds), - (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0); - - if ((cmdPtr != NULL) - && (cmdPtr->compileProc != NULL) - && !(cmdPtr->nsPtr->flags&NS_SUPPRESS_COMPILATION) - && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES) - && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) { - int code, savedNumCmds = envPtr->numCommands; - unsigned savedCodeNext = - envPtr->codeNext - envPtr->codeStart; - int update = 0; -#ifdef TCL_COMPILE_DEBUG - int startStackDepth = envPtr->currStackDepth; -#endif + TclEmitOpcode(INST_POP, envPtr); + EnterCmdExtentData(envPtr, cmdIdx, + parsePtr->term - parsePtr->commandStart, + (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); - /* - * Mark the start of the command; the proper bytecode - * length will be updated later. There is no need to - * do this for the first bytecode in the compile env, - * as the check is done before calling - * TclNRExecuteByteCode(). Do emit an INST_START_CMD in - * special cases where the first bytecode is in a - * loop, to insure that the corresponding command is - * counted properly. Compilers for commands able to - * produce such a beast (currently 'while 1' only) set - * envPtr->atCmdStart to 0 in order to signal this - * case. [Bug 1752146] - * - * Note that the environment is initialised with - * atCmdStart=1 to avoid emitting ISC for the first - * command. - */ - - if (envPtr->atCmdStart) { - if (savedCodeNext != 0) { - /* - * Increase the number of commands being - * started at the current point. Note that - * this depends on the exact layout of the - * INST_START_CMD's operands, so be careful! - */ - - unsigned char *fixPtr = envPtr->codeNext - 4; - - TclStoreInt4AtPtr(TclGetUInt4AtPtr(fixPtr)+1, - fixPtr); - } - } else { - TclEmitInstInt4(INST_START_CMD, 0, envPtr); - TclEmitInt4(1, envPtr); - update = 1; - } - - code = cmdPtr->compileProc(interp, parsePtr, cmdPtr, - envPtr); - - if (code == TCL_OK) { - /* - * Confirm that the command compiler generated a - * single value on the stack as its result. This - * is only done in debugging mode, as it *should* - * be correct and normal users have no reasonable - * way to fix it anyway. - */ + /* + * TIP #280: Free full form of per-word line data and insert the reduced + * form now + */ -#ifdef TCL_COMPILE_DEBUG - int diff = envPtr->currStackDepth-startStackDepth; - - if (diff != 1 && (diff != 0 || - *(envPtr->codeNext-1) != INST_DONE)) { - Tcl_Panic("bad stack adjustment when compiling" - " %.*s (was %d instead of 1)", - parsePtr->tokenPtr->size, - parsePtr->tokenPtr->start, diff); - } -#endif - if (update) { - /* - * Fix the bytecode length. - */ - - unsigned char *fixPtr = envPtr->codeStart - + savedCodeNext + 1; - unsigned fixLen = envPtr->codeNext - - envPtr->codeStart - savedCodeNext; - - TclStoreInt4AtPtr(fixLen, fixPtr); - } - goto finishCommand; - } - - if (envPtr->atCmdStart && savedCodeNext != 0) { - /* - * Decrease the number of commands being started - * at the current point. Note that this depends on - * the exact layout of the INST_START_CMD's - * operands, so be careful! - */ - - unsigned char *fixPtr = envPtr->codeNext - 4; - - TclStoreInt4AtPtr(TclGetUInt4AtPtr(fixPtr)-1, - fixPtr); - } - - /* - * Restore numCommands and codeNext to their correct - * values, removing any commands compiled before the - * failure to produce bytecode got reported. [Bugs - * 705406 and 735055] - */ - - envPtr->numCommands = savedNumCmds; - envPtr->codeNext = envPtr->codeStart + savedCodeNext; - } + envPtr->line = cmdLine; + envPtr->clNext = clNext; + ckfree(eclPtr->loc[wlineat].line); + ckfree(eclPtr->loc[wlineat].next); + eclPtr->loc[wlineat].line = wlines; + eclPtr->loc[wlineat].next = NULL; - /* - * No compile procedure so push the word. If the command - * was found, push a CmdName object to reduce runtime - * lookups. Mark this as a command name literal to reduce - * shimmering. - */ + TclCheckStackDepth(depth, envPtr); + return cmdIdx; +} - objIndex = TclRegisterNewCmdLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size); - if (cmdPtr != NULL) { - TclSetCmdNameObj(interp, - envPtr->literalArrayPtr[objIndex].objPtr, - cmdPtr); - } - } else { - /* - * Simple argument word of a command. We reach this if and - * only if the command word was not compiled for whatever - * reason. Register the literal's location for use by - * uplevel, etc. commands, should they encounter it - * unmodified. We care only if the we are in a context - * which already allows absolute counting. - */ +void +TclCompileScript( + Tcl_Interp *interp, /* Used for error and status reporting. Also + * serves as context for finding and compiling + * commands. May not be NULL. */ + const char *script, /* The source script to compile. */ + int numBytes, /* Number of bytes in script. If < 0, the + * script consists of all bytes up to the + * first null character. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + int lastCmdIdx = -1; /* Index into envPtr->cmdMapPtr of the last + * command this routine compiles into bytecode. + * Initial value of -1 indicates this routine + * has not yet generated any bytecode. */ + const char *p = script; /* Where we are in our compile. */ + int depth = TclGetStackDepth(envPtr); + + if (envPtr->iPtr == NULL) { + Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv"); + } - objIndex = TclRegisterNewLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size); + /* Each iteration compiles one command from the script. */ - if (envPtr->clNext) { - TclContinuationsEnterDerived( - envPtr->literalArrayPtr[objIndex].objPtr, - tokenPtr[1].start - envPtr->source, - eclPtr->loc[wlineat].next[wordIdx]); - } - } - TclEmitPush(objIndex, envPtr); - } /* for loop */ + while (numBytes > 0) { + Tcl_Parse parse; + const char *next; + if (TCL_OK != Tcl_ParseCommand(interp, p, numBytes, 0, &parse)) { /* - * Emit an invoke instruction for the command. We skip this if a - * compile procedure was found for the command. + * Compile bytecodes to report the parse error at runtime. */ - if (expand) { - /* - * The stack depth during argument expansion can only be - * managed at runtime, as the number of elements in the - * expanded lists is not known at compile time. We adjust here - * the stack depth estimate so that it is correct after the - * command with expanded arguments returns. - * - * The end effect of this command's invocation is that all the - * words of the command are popped from the stack, and the - * result is pushed: the stack top changes by (1-wordIdx). - * - * Note that the estimates are not correct while the command - * is being prepared and run, INST_EXPAND_STKTOP is not - * stack-neutral in general. - */ + Tcl_LogCommandInfo(interp, script, parse.commandStart, + parse.term + 1 - parse.commandStart); + TclCompileSyntaxError(interp, envPtr); + return; + } - TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); - TclAdjustStackDepth((1-wordIdx), envPtr); - } else if (wordIdx > 0) { - /* - * Save PC -> command map for the TclArgumentBC* functions. - */ +#ifdef TCL_COMPILE_DEBUG + /* + * If tracing, print a line for each top level command compiled. + * TODO: Suppress when numWords == 0 ? + */ - int isnew; - Tcl_HashEntry *hePtr = Tcl_CreateHashEntry(&eclPtr->litInfo, - INT2PTR(envPtr->codeNext - envPtr->codeStart), - &isnew); + if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) { + int commandLength = parse.term - parse.commandStart; + fprintf(stdout, " Compiling: "); + TclPrintSource(stdout, parse.commandStart, + TclMin(commandLength, 55)); + fprintf(stdout, "\n"); + } +#endif - Tcl_SetHashValue(hePtr, INT2PTR(wlineat)); - if (wordIdx <= 255) { - TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); - } else { - TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr); - } - } + /* + * TIP #280: Count newlines before the command start. + * (See test info-30.33). + */ - /* - * Update the compilation environment structure and record the - * offsets of the source and code for the command. - */ + TclAdvanceLines(&envPtr->line, p, parse.commandStart); + TclAdvanceContinuations(&envPtr->line, &envPtr->clNext, + parse.commandStart - envPtr->source); - finishCommand: - EnterCmdExtentData(envPtr, currCmdIndex, commandLength, - (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); - isFirstCmd = 0; + /* + * Advance parser to the next command in the script. + */ + next = parse.commandStart + parse.commandSize; + numBytes -= next - p; + p = next; + + if (parse.numWords == 0) { /* - * TIP #280: Free full form of per-word line data and insert the - * reduced form now + * The "command" parsed has no words. In this case we can skip + * the rest of the loop body. With no words, clearly + * CompileCommandTokens() has nothing to do. Since the parser + * aggressively sucks up leading comment and white space, + * including newlines, parse.commandStart must be pointing at + * either the end of script, or a command-terminating semi-colon. + * In either case, the TclAdvance*() calls have nothing to do. + * Finally, when no words are parsed, no tokens have been + * allocated at parse.tokenPtr so there's also nothing for + * Tcl_FreeParse() to do. + * + * The advantage of this shortcut is that CompileCommandTokens() + * can be written with an assumption that parse.numWords > 0, with + * the implication the CCT() always generates bytecode. */ + continue; + } - ckfree(eclPtr->loc[wlineat].line); - ckfree(eclPtr->loc[wlineat].next); - eclPtr->loc[wlineat].line = wlines; - eclPtr->loc[wlineat].next = NULL; - } /* end if parsePtr->numWords > 0 */ + lastCmdIdx = CompileCommandTokens(interp, &parse, envPtr); /* - * Advance to the next command in the script. + * TIP #280: Track lines in the just compiled command. */ - next = parsePtr->commandStart + parsePtr->commandSize; - bytesLeft -= next - p; - p = next; + TclAdvanceLines(&envPtr->line, parse.commandStart, p); + TclAdvanceContinuations(&envPtr->line, &envPtr->clNext, + p - envPtr->source); + Tcl_FreeParse(&parse); + } + if (lastCmdIdx == -1) { /* - * TIP #280: Track lines in the just compiled command. + * Compiling the script yielded no bytecode. The script must be all + * whitespace, comments, and empty commands. Such scripts are defined + * to successfully produce the empty string result, so we emit the + * simple bytecode that makes that happen. */ - TclAdvanceLines(&cmdLine, parsePtr->commandStart, p); - TclAdvanceContinuations(&cmdLine, &clNext, p - envPtr->source); - Tcl_FreeParse(parsePtr); - } while (bytesLeft > 0); - - /* - * TIP #280: Bring the line counts in the CompEnv up to date. - * See tests info-30.33,34,35 . - */ - - envPtr->line = cmdLine; - envPtr->clNext = clNext; - - /* - * If the source script yielded no instructions (e.g., if it was empty), - * push an empty string as the command's result. - */ + PushStringLiteral(envPtr, ""); + } else { + /* + * We compiled at least one command to bytecode. The routine + * CompileCommandTokens() follows the bytecode of each compiled + * command with an INST_POP, so that stack balance is maintained when + * several commands are in sequence. (The result of each command is + * thrown away before moving on to the next command). For the last + * command compiled, we need to undo that INST_POP so that the result + * of the last command becomes the result of the script. The code + * here removes that trailing INST_POP. + */ - if (envPtr->codeNext == entryCodeNext) { - TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); + envPtr->cmdMapPtr[lastCmdIdx].numCodeBytes--; + envPtr->codeNext--; + envPtr->currStackDepth++; } - - envPtr->numSrcBytes = p - script; - TclStackFree(interp, parsePtr); - Tcl_DStringFree(&ds); + TclCheckStackDepth(depth+1, envPtr); } /* @@ -2081,7 +2300,7 @@ TclCompileVarSubst( localVar = TclFindCompiledLocal(name, nameBytes, localVarName, envPtr); } if (localVar < 0) { - TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameBytes), envPtr); + PushLiteral(envPtr, name, nameBytes); } /* @@ -2093,7 +2312,7 @@ TclCompileVarSubst( if (tokenPtr->numComponents == 1) { if (localVar < 0) { - TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr); + TclEmitOpcode(INST_LOAD_STK, envPtr); } else if (localVar <= 255) { TclEmitInstInt1(INST_LOAD_SCALAR1, localVar, envPtr); } else { @@ -2123,11 +2342,12 @@ TclCompileTokens( Tcl_DString textBuffer; /* Holds concatenated chars from adjacent * TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */ char buffer[TCL_UTF_MAX]; - int i, numObjsToConcat, length; + int i, numObjsToConcat, length, adjust; unsigned char *entryCodeNext = envPtr->codeNext; #define NUM_STATIC_POS 20 int isLiteral, maxNumCL, numCL; int *clPosition = NULL; + int depth = TclGetStackDepth(envPtr); /* * For the handling of continuation lines in literals we first check if @@ -2160,6 +2380,7 @@ TclCompileTokens( clPosition = ckalloc(maxNumCL * sizeof(int)); } + adjust = 0; Tcl_DStringInit(&textBuffer); numObjsToConcat = 0; for ( ; count > 0; count--, tokenPtr++) { @@ -2203,6 +2424,7 @@ TclCompileTokens( clPosition[numCL] = clPos; numCL ++; } + adjust++; } break; @@ -2219,15 +2441,16 @@ TclCompileTokens( Tcl_DStringFree(&textBuffer); if (numCL) { - TclContinuationsEnter( - envPtr->literalArrayPtr[literal].objPtr, numCL, - clPosition); + TclContinuationsEnter(TclFetchLiteral(envPtr, literal), + numCL, clPosition); } numCL = 0; } + envPtr->line += adjust; TclCompileScript(interp, tokenPtr->start+1, tokenPtr->size-2, envPtr); + envPtr->line -= adjust; numObjsToConcat++; break; @@ -2267,7 +2490,7 @@ TclCompileTokens( TclEmitPush(literal, envPtr); numObjsToConcat++; if (numCL) { - TclContinuationsEnter(envPtr->literalArrayPtr[literal].objPtr, + TclContinuationsEnter(TclFetchLiteral(envPtr, literal), numCL, clPosition); } numCL = 0; @@ -2278,11 +2501,11 @@ TclCompileTokens( */ while (numObjsToConcat > 255) { - TclEmitInstInt1(INST_CONCAT1, 255, envPtr); + TclEmitInstInt1(INST_STR_CONCAT1, 255, envPtr); numObjsToConcat -= 254; /* concat pushes 1 obj, the result */ } if (numObjsToConcat > 1) { - TclEmitInstInt1(INST_CONCAT1, numObjsToConcat, envPtr); + TclEmitInstInt1(INST_STR_CONCAT1, numObjsToConcat, envPtr); } /* @@ -2290,7 +2513,7 @@ TclCompileTokens( */ if (envPtr->codeNext == entryCodeNext) { - TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); + PushStringLiteral(envPtr, ""); } Tcl_DStringFree(&textBuffer); @@ -2302,6 +2525,7 @@ TclCompileTokens( if (maxNumCL) { ckfree(clPosition); } + TclCheckStackDepth(depth+1, envPtr); } /* @@ -2349,7 +2573,7 @@ TclCompileCmdWord( */ TclCompileTokens(interp, tokenPtr, count, envPtr); - TclEmitOpcode(INST_EVAL_STK, envPtr); + TclEmitInvoke(envPtr, INST_EVAL_STK); } } @@ -2405,19 +2629,19 @@ TclCompileExprWords( wordPtr = tokenPtr; for (i = 0; i < numWords; i++) { - TclCompileTokens(interp, wordPtr+1, wordPtr->numComponents, envPtr); + CompileTokens(envPtr, wordPtr, interp); if (i < (numWords - 1)) { - TclEmitPush(TclRegisterNewLiteral(envPtr, " ", 1), envPtr); + PushStringLiteral(envPtr, " "); } wordPtr += wordPtr->numComponents + 1; } concatItems = 2*numWords - 1; while (concatItems > 255) { - TclEmitInstInt1(INST_CONCAT1, 255, envPtr); + TclEmitInstInt1(INST_STR_CONCAT1, 255, envPtr); concatItems -= 254; } if (concatItems > 1) { - TclEmitInstInt1(INST_CONCAT1, concatItems, envPtr); + TclEmitInstInt1(INST_STR_CONCAT1, concatItems, envPtr); } TclEmitOpcode(INST_EXPR_STK, envPtr); } @@ -2451,21 +2675,17 @@ TclCompileNoOp( { Tcl_Token *tokenPtr; int i; - int savedStackDepth = envPtr->currStackDepth; tokenPtr = parsePtr->tokenPtr; for (i = 1; i < parsePtr->numWords; i++) { tokenPtr = tokenPtr + tokenPtr->numComponents + 1; - envPtr->currStackDepth = savedStackDepth; if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, - envPtr); + CompileTokens(envPtr, tokenPtr, interp); TclEmitOpcode(INST_POP, envPtr); } } - envPtr->currStackDepth = savedStackDepth; - TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); + PushStringLiteral(envPtr, ""); return TCL_OK; } @@ -2514,6 +2734,10 @@ TclInitByteCodeObj( int i, isNew; Interp *iPtr; + if (envPtr->iPtr == NULL) { + Tcl_Panic("TclInitByteCodeObj() called on uninitialized CompileEnv"); + } + iPtr = envPtr->iPtr; codeBytes = envPtr->codeNext - envPtr->codeStart; @@ -2571,7 +2795,9 @@ TclInitByteCodeObj( p += TCL_ALIGN(codeBytes); /* align object array */ codePtr->objArrayPtr = (Tcl_Obj **) p; for (i = 0; i < numLitObjects; i++) { - if (objPtr == envPtr->literalArrayPtr[i].objPtr) { + Tcl_Obj *fetched = TclFetchLiteral(envPtr, i); + + if (objPtr == fetched) { /* * Prevent circular reference where the bytecode intrep of * a value contains a literal which is that same value. @@ -2588,9 +2814,9 @@ TclInitByteCodeObj( codePtr->objArrayPtr[i] = Tcl_NewStringObj(bytes, numBytes); Tcl_IncrRefCount(codePtr->objArrayPtr[i]); - Tcl_DecrRefCount(objPtr); + TclReleaseLiteral((Tcl_Interp *)iPtr, objPtr); } else { - codePtr->objArrayPtr[i] = envPtr->literalArrayPtr[i].objPtr; + codePtr->objArrayPtr[i] = fetched; } } @@ -2639,7 +2865,7 @@ TclInitByteCodeObj( */ TclFreeIntRep(objPtr); - objPtr->internalRep.otherValuePtr = codePtr; + objPtr->internalRep.twoPtrValue.ptr1 = codePtr; objPtr->typePtr = &tclByteCodeType; /* @@ -2651,6 +2877,9 @@ TclInitByteCodeObj( &isNew), envPtr->extCmdMapPtr); envPtr->extCmdMapPtr = NULL; + /* We've used up the CompileEnv. Mark as uninitialized. */ + envPtr->iPtr = NULL; + codePtr->localCachePtr = NULL; } @@ -3065,6 +3294,7 @@ TclCreateExceptRange( * new ExceptionRange structure. */ { register ExceptionRange *rangePtr; + register ExceptionAux *auxPtr; int index = envPtr->exceptArrayNext; if (index >= envPtr->exceptArrayEnd) { @@ -3076,12 +3306,16 @@ TclCreateExceptRange( size_t currBytes = envPtr->exceptArrayNext * sizeof(ExceptionRange); + size_t currBytes2 = envPtr->exceptArrayNext * sizeof(ExceptionAux); int newElems = 2*envPtr->exceptArrayEnd; size_t newBytes = newElems * sizeof(ExceptionRange); + size_t newBytes2 = newElems * sizeof(ExceptionAux); if (envPtr->mallocedExceptArray) { envPtr->exceptArrayPtr = ckrealloc(envPtr->exceptArrayPtr, newBytes); + envPtr->exceptAuxArrayPtr = + ckrealloc(envPtr->exceptAuxArrayPtr, newBytes2); } else { /* * envPtr->exceptArrayPtr isn't a ckalloc'd pointer, so we must @@ -3089,9 +3323,12 @@ TclCreateExceptRange( */ ExceptionRange *newPtr = ckalloc(newBytes); + ExceptionAux *newPtr2 = ckalloc(newBytes2); memcpy(newPtr, envPtr->exceptArrayPtr, currBytes); + memcpy(newPtr2, envPtr->exceptAuxArrayPtr, currBytes2); envPtr->exceptArrayPtr = newPtr; + envPtr->exceptAuxArrayPtr = newPtr2; envPtr->mallocedExceptArray = 1; } envPtr->exceptArrayEnd = newElems; @@ -3106,10 +3343,294 @@ TclCreateExceptRange( rangePtr->breakOffset = -1; rangePtr->continueOffset = -1; rangePtr->catchOffset = -1; + auxPtr = &envPtr->exceptAuxArrayPtr[index]; + auxPtr->supportsContinue = 1; + auxPtr->stackDepth = envPtr->currStackDepth; + auxPtr->expandTarget = envPtr->expandCount; + auxPtr->expandTargetDepth = -1; + auxPtr->numBreakTargets = 0; + auxPtr->breakTargets = NULL; + auxPtr->allocBreakTargets = 0; + auxPtr->numContinueTargets = 0; + auxPtr->continueTargets = NULL; + auxPtr->allocContinueTargets = 0; return index; } /* + * --------------------------------------------------------------------- + * + * TclGetInnermostExceptionRange -- + * + * Returns the innermost exception range that covers the current code + * creation point, and (optionally) the stack depth that is expected at + * that point. Relies on the fact that the range has a numCodeBytes = -1 + * when it is being populated and that inner ranges come after outer + * ranges. + * + * --------------------------------------------------------------------- + */ + +ExceptionRange * +TclGetInnermostExceptionRange( + CompileEnv *envPtr, + int returnCode, + ExceptionAux **auxPtrPtr) +{ + int exnIdx = -1, i; + + for (i=0 ; i<envPtr->exceptArrayNext ; i++) { + ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[i]; + + if (CurrentOffset(envPtr) >= rangePtr->codeOffset && + (rangePtr->numCodeBytes == -1 || CurrentOffset(envPtr) < + rangePtr->codeOffset+rangePtr->numCodeBytes) && + (returnCode != TCL_CONTINUE || + envPtr->exceptAuxArrayPtr[i].supportsContinue)) { + exnIdx = i; + } + } + if (exnIdx == -1) { + return NULL; + } + if (auxPtrPtr) { + *auxPtrPtr = &envPtr->exceptAuxArrayPtr[exnIdx]; + } + return &envPtr->exceptArrayPtr[exnIdx]; +} + +/* + * --------------------------------------------------------------------- + * + * TclAddLoopBreakFixup, TclAddLoopContinueFixup -- + * + * Adds a place that wants to break/continue to the loop exception range + * tracking that will be fixed up once the loop can be finalized. These + * functions will generate an INST_JUMP4 that will be fixed up during the + * loop finalization. + * + * --------------------------------------------------------------------- + */ + +void +TclAddLoopBreakFixup( + CompileEnv *envPtr, + ExceptionAux *auxPtr) +{ + int range = auxPtr - envPtr->exceptAuxArrayPtr; + + if (envPtr->exceptArrayPtr[range].type != LOOP_EXCEPTION_RANGE) { + Tcl_Panic("trying to add 'break' fixup to full exception range"); + } + + if (++auxPtr->numBreakTargets > auxPtr->allocBreakTargets) { + auxPtr->allocBreakTargets *= 2; + auxPtr->allocBreakTargets += 2; + if (auxPtr->breakTargets) { + auxPtr->breakTargets = ckrealloc(auxPtr->breakTargets, + sizeof(int) * auxPtr->allocBreakTargets); + } else { + auxPtr->breakTargets = + ckalloc(sizeof(int) * auxPtr->allocBreakTargets); + } + } + auxPtr->breakTargets[auxPtr->numBreakTargets - 1] = CurrentOffset(envPtr); + TclEmitInstInt4(INST_JUMP4, 0, envPtr); +} + +void +TclAddLoopContinueFixup( + CompileEnv *envPtr, + ExceptionAux *auxPtr) +{ + int range = auxPtr - envPtr->exceptAuxArrayPtr; + + if (envPtr->exceptArrayPtr[range].type != LOOP_EXCEPTION_RANGE) { + Tcl_Panic("trying to add 'continue' fixup to full exception range"); + } + + if (++auxPtr->numContinueTargets > auxPtr->allocContinueTargets) { + auxPtr->allocContinueTargets *= 2; + auxPtr->allocContinueTargets += 2; + if (auxPtr->continueTargets) { + auxPtr->continueTargets = ckrealloc(auxPtr->continueTargets, + sizeof(int) * auxPtr->allocContinueTargets); + } else { + auxPtr->continueTargets = + ckalloc(sizeof(int) * auxPtr->allocContinueTargets); + } + } + auxPtr->continueTargets[auxPtr->numContinueTargets - 1] = + CurrentOffset(envPtr); + TclEmitInstInt4(INST_JUMP4, 0, envPtr); +} + +/* + * --------------------------------------------------------------------- + * + * TclCleanupStackForBreakContinue -- + * + * Ditch the extra elements from the auxiliary stack and the main stack. + * How to do this exactly depends on whether there are any elements on + * the auxiliary stack to pop. + * + * --------------------------------------------------------------------- + */ + +void +TclCleanupStackForBreakContinue( + CompileEnv *envPtr, + ExceptionAux *auxPtr) +{ + int savedStackDepth = envPtr->currStackDepth; + int toPop = envPtr->expandCount - auxPtr->expandTarget; + + if (toPop > 0) { + while (toPop --> 0) { + TclEmitOpcode(INST_EXPAND_DROP, envPtr); + } + TclAdjustStackDepth(auxPtr->expandTargetDepth - envPtr->currStackDepth, + envPtr); + envPtr->currStackDepth = auxPtr->expandTargetDepth; + } + toPop = envPtr->currStackDepth - auxPtr->stackDepth; + while (toPop --> 0) { + TclEmitOpcode(INST_POP, envPtr); + } + envPtr->currStackDepth = savedStackDepth; +} + +/* + * --------------------------------------------------------------------- + * + * StartExpanding -- + * + * Pushes an INST_EXPAND_START and does some additional housekeeping so + * that the [break] and [continue] compilers can use an exception-free + * issue to discard it. + * + * --------------------------------------------------------------------- + */ + +static void +StartExpanding( + CompileEnv *envPtr) +{ + int i; + + TclEmitOpcode(INST_EXPAND_START, envPtr); + + /* + * Update inner exception ranges with information about the environment + * where this expansion started. + */ + + for (i=0 ; i<envPtr->exceptArrayNext ; i++) { + ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[i]; + ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[i]; + + /* + * Ignore loops unless they're still being built. + */ + + if (rangePtr->codeOffset > CurrentOffset(envPtr)) { + continue; + } + if (rangePtr->numCodeBytes != -1) { + continue; + } + + /* + * Adequate condition: further out loops and further in exceptions + * don't actually need this information. + */ + + if (auxPtr->expandTarget == envPtr->expandCount) { + auxPtr->expandTargetDepth = envPtr->currStackDepth; + } + } + + /* + * There's now one more expansion being processed on the auxiliary stack. + */ + + envPtr->expandCount++; +} + +/* + * --------------------------------------------------------------------- + * + * TclFinalizeLoopExceptionRange -- + * + * Finalizes a loop exception range, binding the registered [break] and + * [continue] implementations so that they jump to the correct place. + * Note that this must only be called after *all* the exception range + * target offsets have been set. + * + * --------------------------------------------------------------------- + */ + +void +TclFinalizeLoopExceptionRange( + CompileEnv *envPtr, + int range) +{ + ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[range]; + ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[range]; + int i, offset; + unsigned char *site; + + if (rangePtr->type != LOOP_EXCEPTION_RANGE) { + Tcl_Panic("trying to finalize a loop exception range"); + } + + /* + * Do the jump fixups. Note that these are always issued as INST_JUMP4 so + * there is no need to fuss around with updating code offsets. + */ + + for (i=0 ; i<auxPtr->numBreakTargets ; i++) { + site = envPtr->codeStart + auxPtr->breakTargets[i]; + offset = rangePtr->breakOffset - auxPtr->breakTargets[i]; + TclUpdateInstInt4AtPc(INST_JUMP4, offset, site); + } + for (i=0 ; i<auxPtr->numContinueTargets ; i++) { + site = envPtr->codeStart + auxPtr->continueTargets[i]; + if (rangePtr->continueOffset == -1) { + int j; + + /* + * WTF? Can't bind, so revert to an INST_CONTINUE. Not enough + * space to do anything else. + */ + + *site = INST_CONTINUE; + for (j=0 ; j<4 ; j++) { + *++site = INST_NOP; + } + } else { + offset = rangePtr->continueOffset - auxPtr->continueTargets[i]; + TclUpdateInstInt4AtPc(INST_JUMP4, offset, site); + } + } + + /* + * Drop the arrays we were holding the only reference to. + */ + + if (auxPtr->breakTargets) { + ckfree(auxPtr->breakTargets); + auxPtr->breakTargets = NULL; + auxPtr->numBreakTargets = 0; + } + if (auxPtr->continueTargets) { + ckfree(auxPtr->continueTargets); + auxPtr->continueTargets = NULL; + auxPtr->numContinueTargets = 0; + } +} + +/* *---------------------------------------------------------------------- * * TclCreateAuxData -- @@ -3469,70 +3990,215 @@ TclFixupForwardJump( } } + for (k = 0 ; k < envPtr->exceptArrayNext ; k++) { + ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[k]; + int i; + + for (i=0 ; i<auxPtr->numBreakTargets ; i++) { + if (jumpFixupPtr->codeOffset < auxPtr->breakTargets[i]) { + auxPtr->breakTargets[i] += 3; + } + } + for (i=0 ; i<auxPtr->numContinueTargets ; i++) { + if (jumpFixupPtr->codeOffset < auxPtr->continueTargets[i]) { + auxPtr->continueTargets[i] += 3; + } + } + } + + return 1; /* the jump was grown */ +} + +/* + *---------------------------------------------------------------------- + * + * TclEmitInvoke -- + * + * Emit one of the invoke-related instructions, wrapping it if necessary + * in code that ensures that any break or continue operation passing + * through it gets the stack unwinding correct, converting it into an + * internal jump if in an appropriate context. + * + * Results: + * None + * + * Side effects: + * Issues the jump with all correct stack management. May create another + * loop exception range; pointers to ExceptionRange and ExceptionAux + * structures should not be held across this call. + * + *---------------------------------------------------------------------- + */ + +void +TclEmitInvoke( + CompileEnv *envPtr, + int opcode, + ...) +{ + va_list argList; + ExceptionRange *rangePtr; + ExceptionAux *auxBreakPtr, *auxContinuePtr; + int arg1, arg2, wordCount = 0, expandCount = 0; + int loopRange = 0, breakRange = 0, continueRange = 0; + int cleanup, depth = TclGetStackDepth(envPtr); + + /* + * Parse the arguments. + */ + + va_start(argList, opcode); + switch (opcode) { + case INST_INVOKE_STK1: + wordCount = arg1 = cleanup = va_arg(argList, int); + arg2 = 0; + break; + case INST_INVOKE_STK4: + wordCount = arg1 = cleanup = va_arg(argList, int); + arg2 = 0; + break; + case INST_INVOKE_REPLACE: + arg1 = va_arg(argList, int); + arg2 = va_arg(argList, int); + wordCount = arg1 + arg2 - 1; + cleanup = arg1 + 1; + break; + default: + Tcl_Panic("unexpected opcode"); + case INST_EVAL_STK: + wordCount = cleanup = 1; + arg1 = arg2 = 0; + break; + case INST_RETURN_STK: + wordCount = cleanup = 2; + arg1 = arg2 = 0; + break; + case INST_INVOKE_EXPANDED: + wordCount = arg1 = cleanup = va_arg(argList, int); + arg2 = 0; + expandCount = 1; + break; + } + va_end(argList); + /* - * TIP #280: Adjust the mapping from PC values to the per-command - * information about arguments and their line numbers. + * Determine if we need to handle break and continue exceptions with a + * special handling exception range (so that we can correctly unwind the + * stack). * - * Note: We cannot simply remove an out-of-date entry and then reinsert - * with the proper PC, because then we might overwrite another entry which - * was at that location. Therefore we pull (copy + delete) all effected - * entries (beyond the fixed PC) into an array, update them there, and at - * last reinsert them all. + * These must be done separately; they can be different (especially for + * calls from inside a [for] increment clause). */ - { - ExtCmdLoc* eclPtr = envPtr->extCmdMapPtr; + rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_BREAK, &auxBreakPtr); + if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) { + auxBreakPtr = NULL; + } else if (auxBreakPtr->stackDepth == envPtr->currStackDepth-wordCount + && auxBreakPtr->expandTarget == envPtr->expandCount-expandCount) { + auxBreakPtr = NULL; + } else { + breakRange = auxBreakPtr - envPtr->exceptAuxArrayPtr; + } - /* A helper structure */ + rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_CONTINUE, + &auxContinuePtr); + if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) { + auxContinuePtr = NULL; + } else if (auxContinuePtr->stackDepth == envPtr->currStackDepth-wordCount + && auxContinuePtr->expandTarget == envPtr->expandCount-expandCount) { + auxContinuePtr = NULL; + } else { + continueRange = auxBreakPtr - envPtr->exceptAuxArrayPtr; + } - typedef struct { - int pc; - int cmd; - } MAP; + if (auxBreakPtr != NULL || auxContinuePtr != NULL) { + loopRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + ExceptionRangeStarts(envPtr, loopRange); + } - /* - * And the helper array. At most the whole hashtable is placed into - * this. - */ + /* + * Issue the invoke itself. + */ + + 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; + } + + /* + * If we're generating a special wrapper exception range, we need to + * finish that up now. + */ + + if (auxBreakPtr != NULL || auxContinuePtr != NULL) { + int savedStackDepth = envPtr->currStackDepth; + int savedExpandCount = envPtr->expandCount; + JumpFixup nonTrapFixup; - MAP *map = (MAP*) ckalloc (sizeof(MAP) * eclPtr->litInfo.numEntries); + if (auxBreakPtr != NULL) { + auxBreakPtr = envPtr->exceptAuxArrayPtr + breakRange; + } + if (auxContinuePtr != NULL) { + auxContinuePtr = envPtr->exceptAuxArrayPtr + continueRange; + } - Tcl_HashSearch hSearch; - Tcl_HashEntry* hPtr; - int n, k, isnew; + ExceptionRangeEnds(envPtr, loopRange); + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &nonTrapFixup); /* - * Phase I: Locate the affected entries, and save them in adjusted - * form to the array. This removes them from the hash. + * Careful! When generating these stack unwinding sequences, the depth + * of stack in the cases where they are taken is not the same as if + * the exception is not taken. */ - for (n = 0, hPtr = Tcl_FirstHashEntry(&eclPtr->litInfo, &hSearch); - hPtr != NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { + if (auxBreakPtr != NULL) { + TclAdjustStackDepth(-1, envPtr); - map [n].cmd = PTR2INT(Tcl_GetHashValue(hPtr)); - map [n].pc = PTR2INT(Tcl_GetHashKey (&eclPtr->litInfo,hPtr)); + ExceptionRangeTarget(envPtr, loopRange, breakOffset); + TclCleanupStackForBreakContinue(envPtr, auxBreakPtr); + TclAddLoopBreakFixup(envPtr, auxBreakPtr); + TclAdjustStackDepth(1, envPtr); - if (map[n].pc >= (jumpFixupPtr->codeOffset + 2)) { - Tcl_DeleteHashEntry(hPtr); - map [n].pc += 3; - n++; - } + envPtr->currStackDepth = savedStackDepth; + envPtr->expandCount = savedExpandCount; } - /* - * Phase II: Re-insert the modified entries into the hash. - */ + if (auxContinuePtr != NULL) { + TclAdjustStackDepth(-1, envPtr); - for (k=0;k<n;k++) { - hPtr = Tcl_CreateHashEntry(&eclPtr->litInfo, INT2PTR(map[k].pc), &isnew); - Tcl_SetHashValue(hPtr, INT2PTR(map[k].cmd)); + ExceptionRangeTarget(envPtr, loopRange, continueOffset); + TclCleanupStackForBreakContinue(envPtr, auxContinuePtr); + TclAddLoopContinueFixup(envPtr, auxContinuePtr); + TclAdjustStackDepth(1, envPtr); + + envPtr->currStackDepth = savedStackDepth; + envPtr->expandCount = savedExpandCount; } - ckfree (map); + TclFinalizeLoopExceptionRange(envPtr, loopRange); + TclFixupForwardJumpToHere(envPtr, &nonTrapFixup, 127); } - - return 1; /* the jump was grown */ + TclCheckStackDepth(depth+1-cleanup, envPtr); } /* @@ -3563,7 +4229,7 @@ TclGetInstructionTable(void) /* *-------------------------------------------------------------- * - * TclRegisterAuxDataType -- + * RegisterAuxDataType -- * * This procedure is called to register a new AuxData type in the table * of all AuxData types supported by Tcl. @@ -3579,8 +4245,8 @@ TclGetInstructionTable(void) *-------------------------------------------------------------- */ -void -TclRegisterAuxDataType( +static void +RegisterAuxDataType( const AuxDataType *typePtr) /* Information about object type; storage must * be statically allocated (must live forever; * will not be deallocated). */ @@ -3681,12 +4347,12 @@ TclInitAuxDataTypeTable(void) Tcl_InitHashTable(&auxDataTypeTable, TCL_STRING_KEYS); /* - * There are only two AuxData type at this time, so register them here. + * There are only three AuxData types at this time, so register them here. */ - TclRegisterAuxDataType(&tclForeachInfoType); - TclRegisterAuxDataType(&tclJumptableInfoType); - TclRegisterAuxDataType(&tclDictUpdateInfoType); + RegisterAuxDataType(&tclForeachInfoType); + RegisterAuxDataType(&tclJumptableInfoType); + RegisterAuxDataType(&tclDictUpdateInfoType); } /* @@ -4058,7 +4724,7 @@ Tcl_Obj * TclDisassembleByteCodeObj( Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ { - ByteCode *codePtr = objPtr->internalRep.otherValuePtr; + ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; unsigned char *codeStart, *codeLimit, *pc; unsigned char *codeDeltaNext, *codeLengthNext; unsigned char *srcDeltaNext, *srcLengthNext; @@ -4431,6 +5097,11 @@ FormatInstruction( } 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; @@ -4563,7 +5234,11 @@ TclGetInnerContext( if (!objPtr) { Tcl_Panic("InnerContext: bad tos -- appending null object"); } - if (objPtr->refCount<=0 || objPtr->refCount==0x61616161) { + if ((objPtr->refCount<=0) +#ifdef TCL_MEM_DEBUG + || (objPtr->refCount==0x61616161) +#endif + ) { Tcl_Panic("InnerContext: bad tos -- appending freed object %p", objPtr); } @@ -4643,7 +5318,7 @@ PrintSourceToObj( int maxChars) /* Maximum number of chars to print. */ { register const char *p; - register int i = 0; + register int i = 0, len; if (stringPtr == NULL) { Tcl_AppendToObj(appendObj, "\"\"", -1); @@ -4652,32 +5327,50 @@ PrintSourceToObj( Tcl_AppendToObj(appendObj, "\"", -1); p = stringPtr; - for (; (*p != '\0') && (i < maxChars); p++, i++) { - switch (*p) { + for (; (*p != '\0') && (i < maxChars); p+=len) { + Tcl_UniChar ch; + + 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: - Tcl_AppendPrintfToObj(appendObj, "%c", *p); + if (ch < 0x20 || ch >= 0x7f) { + Tcl_AppendPrintfToObj(appendObj, "\\u%04x", ch); + i += 6; + } else { + Tcl_AppendPrintfToObj(appendObj, "%c", ch); + i++; + } continue; } } Tcl_AppendToObj(appendObj, "\"", -1); + if (*p != '\0') { + Tcl_AppendToObj(appendObj, "...", -1); + } } #ifdef TCL_COMPILE_STATS diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 4d8ed65..5665ca9 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -100,6 +100,54 @@ typedef struct ExceptionRange { } ExceptionRange; /* + * Auxiliary data used when issuing (currently just loop) exception ranges, + * but which is not required during execution. + */ + +typedef struct ExceptionAux { + int supportsContinue; /* Whether this exception range will have a + * continueOffset created for it; if it is a + * loop exception range that *doesn't* have + * one (see [for] next-clause) then we must + * not pick up the range when scanning for a + * target to continue to. */ + int stackDepth; /* The stack depth at the point where the + * exception range was created. This is used + * to calculate the number of POPs required to + * restore the stack to its prior state. */ + int expandTarget; /* The number of expansions expected on the + * auxData stack at the time the loop starts; + * we can't currently discard them except by + * doing INST_INVOKE_EXPANDED; this is a known + * problem. */ + int expandTargetDepth; /* The stack depth expected at the outermost + * expansion within the loop. Not meaningful + * if there are no open expansions between the + * looping level and the point of jump + * issue. */ + int numBreakTargets; /* The number of [break]s that want to be + * targeted to the place where this loop + * exception will be bound to. */ + int *breakTargets; /* The offsets of the INST_JUMP4 instructions + * issued by the [break]s that we must + * update. Note that resizing a jump (via + * TclFixupForwardJump) can cause the contents + * of this array to be updated. When + * numBreakTargets==0, this is NULL. */ + int allocBreakTargets; /* The size of the breakTargets array. */ + int numContinueTargets; /* The number of [continue]s that want to be + * targeted to the place where this loop + * exception will be bound to. */ + int *continueTargets; /* The offsets of the INST_JUMP4 instructions + * issued by the [continue]s that we must + * update. Note that resizing a jump (via + * TclFixupForwardJump) can cause the contents + * of this array to be updated. When + * numContinueTargets==0, this is NULL. */ + int allocContinueTargets; /* The size of the continueTargets array. */ +} ExceptionAux; + +/* * Structure used to map between instruction pc and source locations. It * defines for each compiled Tcl command its code's starting offset and its * source's starting offset and length. Note that the code offset increases @@ -145,13 +193,6 @@ typedef struct ExtCmdLoc { ECL *loc; /* Command word locations (lines). */ int nloc; /* Number of allocated entries in 'loc'. */ int nuloc; /* Number of used entries in 'loc'. */ - Tcl_HashTable litInfo; /* Indexed by bytecode 'PC', to have the - * information accessible per command and - * argument, not per whole bytecode. Value is - * index of command in 'loc', giving us the - * literals to associate with line information - * as command argument, see - * TclArgumentBCEnter() */ } ExtCmdLoc; /* @@ -275,6 +316,11 @@ typedef struct CompileEnv { * entry. */ int mallocedExceptArray; /* 1 if ExceptionRange array was expanded and * exceptArrayPtr points in heap, else 0. */ + ExceptionAux *exceptAuxArrayPtr; + /* Array of information used to restore the + * state when processing BREAK/CONTINUE + * exceptions. Must be the same size as the + * exceptArrayPtr. */ CmdLocation *cmdMapPtr; /* Points to start of CmdLocation array. * numCommands is the index of the next entry * to use; (numCommands-1) is the entry index @@ -296,6 +342,9 @@ typedef struct CompileEnv { /* Initial storage of LiteralEntry array. */ ExceptionRange staticExceptArraySpace[COMPILEENV_INIT_EXCEPT_RANGES]; /* Initial ExceptionRange array storage. */ + ExceptionAux staticExAuxArraySpace[COMPILEENV_INIT_EXCEPT_RANGES]; + /* Initial static except auxiliary info array + * storage. */ CmdLocation staticCmdMapSpace[COMPILEENV_INIT_CMD_MAP_SIZE]; /* Initial storage for cmd location map. */ AuxData staticAuxDataArraySpace[COMPILEENV_INIT_AUX_DATA_SIZE]; @@ -309,11 +358,13 @@ typedef struct CompileEnv { int atCmdStart; /* Flag to say whether an INST_START_CMD * should be issued; they should never be * issued repeatedly, as that is significantly - * inefficient. */ - ContLineLoc *clLoc; /* If not NULL, the table holding the - * locations of the invisible continuation - * lines in the input script, to adjust the - * line counter. */ + * inefficient. If set to 2, that instruction + * should not be issued at all (by the generic + * part of the command compiler). */ + int expandCount; /* Number of INST_EXPAND_START instructions + * encountered that have not yet been paired + * with a corresponding + * INST_INVOKE_EXPANDED. */ int *clNext; /* If not NULL, it refers to the next slot in * clLoc to check for an invisible * continuation line. */ @@ -461,7 +512,7 @@ typedef struct ByteCode { #define INST_PUSH4 2 #define INST_POP 3 #define INST_DUP 4 -#define INST_CONCAT1 5 +#define INST_STR_CONCAT1 5 #define INST_INVOKE_STK1 6 #define INST_INVOKE_STK4 7 #define INST_EVAL_STK 8 @@ -535,8 +586,8 @@ typedef struct ByteCode { #define INST_CONTINUE 66 /* Opcodes 67 to 68 */ -#define INST_FOREACH_START4 67 -#define INST_FOREACH_STEP4 68 +#define INST_FOREACH_START4 67 /* DEPRECATED */ +#define INST_FOREACH_STEP4 68 /* DEPRECATED */ /* Opcodes 69 to 72 */ #define INST_BEGIN_CATCH4 69 @@ -700,6 +751,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 @@ -713,8 +766,41 @@ typedef struct ByteCode { #define INST_INVOKE_REPLACE 163 +#define INST_LIST_CONCAT 164 + +#define INST_EXPAND_DROP 165 + +/* New foreach implementation */ +#define INST_FOREACH_START 166 +#define INST_FOREACH_STEP 167 +#define INST_FOREACH_END 168 +#define INST_LMAP_COLLECT 169 + +/* For compilation of [string trim] and related */ +#define INST_STR_TRIM 170 +#define INST_STR_TRIM_LEFT 171 +#define INST_STR_TRIM_RIGHT 172 + +#define INST_CONCAT_STK 173 + +#define INST_STR_UPPER 174 +#define INST_STR_LOWER 175 +#define INST_STR_TITLE 176 +#define INST_STR_REPLACE 177 + +#define INST_ORIGIN_COMMAND 178 + +#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 + /* The last opcode */ -#define LAST_INST_OPCODE 163 +#define LAST_INST_OPCODE 184 /* * Table describing the Tcl bytecode instructions: their name (for displaying @@ -739,8 +825,9 @@ 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_SCLS1 /* Index into tclStringClassTable. */ } InstOperandType; typedef struct InstructionDesc { @@ -759,6 +846,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 @@ -847,6 +968,10 @@ typedef struct ForeachInfo { } ForeachInfo; MODULE_SCOPE const AuxDataType tclForeachInfoType; +MODULE_SCOPE const AuxDataType tclNewForeachInfoType; + +#define FOREACHINFO(envPtr, index) \ + ((ForeachInfo*)((envPtr)->auxDataArrayPtr[TclGetUInt4AtPtr(index)].clientData)) /* * Structure used to hold information about a switch command that is needed @@ -861,6 +986,9 @@ typedef struct JumptableInfo { MODULE_SCOPE const AuxDataType tclJumptableInfoType; +#define JUMPTABLEINFO(envPtr, index) \ + ((JumptableInfo*)((envPtr)->auxDataArrayPtr[TclGetUInt4AtPtr(index)].clientData)) + /* * Structure used to hold information about a [dict update] command that is * needed during program execution. These structures are stored in CompileEnv @@ -879,6 +1007,9 @@ typedef struct { MODULE_SCOPE const AuxDataType tclDictUpdateInfoType; +#define DICTUPDATEINFO(envPtr, index) \ + ((DictUpdateInfo*)((envPtr)->auxDataArrayPtr[TclGetUInt4AtPtr(index)].clientData)) + /* * ClientData type used by the math operator commands. */ @@ -916,7 +1047,12 @@ MODULE_SCOPE ByteCode * TclCompileObj(Tcl_Interp *interp, Tcl_Obj *objPtr, *---------------------------------------------------------------- */ +MODULE_SCOPE int TclAttemptCompileProc(Tcl_Interp *interp, + Tcl_Parse *parsePtr, int depth, Command *cmdPtr, + CompileEnv *envPtr); MODULE_SCOPE void TclCleanupByteCode(ByteCode *codePtr); +MODULE_SCOPE void TclCleanupStackForBreakContinue(CompileEnv *envPtr, + ExceptionAux *auxPtr); MODULE_SCOPE void TclCompileCmdWord(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count, CompileEnv *envPtr); @@ -925,6 +1061,9 @@ MODULE_SCOPE void TclCompileExpr(Tcl_Interp *interp, const char *script, MODULE_SCOPE void TclCompileExprWords(Tcl_Interp *interp, Tcl_Token *tokenPtr, int numWords, CompileEnv *envPtr); +MODULE_SCOPE void TclCompileInvocation(Tcl_Interp *interp, + Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, int numWords, + CompileEnv *envPtr); MODULE_SCOPE void TclCompileScript(Tcl_Interp *interp, const char *script, int numBytes, CompileEnv *envPtr); @@ -949,16 +1088,16 @@ MODULE_SCOPE void TclDeleteLiteralTable(Tcl_Interp *interp, LiteralTable *tablePtr); MODULE_SCOPE void TclEmitForwardJump(CompileEnv *envPtr, TclJumpType jumpType, JumpFixup *jumpFixupPtr); +MODULE_SCOPE void TclEmitInvoke(CompileEnv *envPtr, int opcode, ...); MODULE_SCOPE ExceptionRange * TclGetExceptionRangeForPc(unsigned char *pc, int catchOnly, ByteCode *codePtr); MODULE_SCOPE void TclExpandJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE int TclNRExecuteByteCode(Tcl_Interp *interp, ByteCode *codePtr); +MODULE_SCOPE Tcl_Obj * TclFetchLiteral(CompileEnv *envPtr, unsigned int index); MODULE_SCOPE void TclFinalizeAuxDataTypeTable(void); MODULE_SCOPE int TclFindCompiledLocal(const char *name, int nameChars, int create, CompileEnv *envPtr); -MODULE_SCOPE LiteralEntry * TclLookupLiteralEntry(Tcl_Interp *interp, - Tcl_Obj *objPtr); MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr, JumpFixup *jumpFixupPtr, int jumpDist, int distThreshold); @@ -967,16 +1106,24 @@ MODULE_SCOPE void TclFreeJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE void TclInitAuxDataTypeTable(void); MODULE_SCOPE void TclInitByteCodeObj(Tcl_Obj *objPtr, CompileEnv *envPtr); -MODULE_SCOPE void TclInitCompilation(void); MODULE_SCOPE void TclInitCompileEnv(Tcl_Interp *interp, CompileEnv *envPtr, const char *string, int numBytes, const CmdFrame *invoker, int word); MODULE_SCOPE void TclInitJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE void TclInitLiteralTable(LiteralTable *tablePtr); +MODULE_SCOPE ExceptionRange *TclGetInnermostExceptionRange(CompileEnv *envPtr, + int returnCode, ExceptionAux **auxPtrPtr); +MODULE_SCOPE void TclAddLoopBreakFixup(CompileEnv *envPtr, + ExceptionAux *auxPtr); +MODULE_SCOPE void TclAddLoopContinueFixup(CompileEnv *envPtr, + ExceptionAux *auxPtr); +MODULE_SCOPE void TclFinalizeLoopExceptionRange(CompileEnv *envPtr, + int range); #ifdef TCL_COMPILE_STATS MODULE_SCOPE char * TclLiteralStats(LiteralTable *tablePtr); MODULE_SCOPE int TclLog2(int value); #endif +MODULE_SCOPE void TclOptimizeBytecode(void *envPtr); #ifdef TCL_COMPILE_DEBUG MODULE_SCOPE void TclPrintByteCodeObj(Tcl_Interp *interp, Tcl_Obj *objPtr); @@ -987,9 +1134,10 @@ MODULE_SCOPE void TclPrintObject(FILE *outFile, Tcl_Obj *objPtr, int maxChars); MODULE_SCOPE void TclPrintSource(FILE *outFile, const char *string, int maxChars); -MODULE_SCOPE void TclRegisterAuxDataType(const AuxDataType *typePtr); -MODULE_SCOPE int TclRegisterLiteral(CompileEnv *envPtr, - char *bytes, int length, int flags); +MODULE_SCOPE void TclPushVarName(Tcl_Interp *interp, + Tcl_Token *varTokenPtr, CompileEnv *envPtr, + int flags, int *localIndexPtr, + int *isScalarPtr); MODULE_SCOPE void TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr); MODULE_SCOPE void TclInvalidateCmdLiteral(Tcl_Interp *interp, const char *name, Namespace *nsPtr); @@ -1027,6 +1175,15 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); *---------------------------------------------------------------- */ +/* + * Simplified form to access AuxData. + * + * ClientData TclFetchAuxData(CompileEng *envPtr, int index); + */ + +#define TclFetchAuxData(envPtr, index) \ + (envPtr)->auxDataArrayPtr[(index)].clientData + #define LITERAL_ON_HEAP 0x01 #define LITERAL_CMD_NAME 0x02 @@ -1071,6 +1228,21 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); (envPtr)->currStackDepth += (delta); \ } while (0) +#define TclGetStackDepth(envPtr) \ + ((envPtr)->currStackDepth) + +#define TclSetStackDepth(depth, envPtr) \ + (envPtr)->currStackDepth = (depth) + +#define TclCheckStackDepth(depth, envPtr) \ + do { \ + int dd = (depth); \ + if (dd != (envPtr)->currStackDepth) { \ + Tcl_Panic("bad stack depth computations: is %i, should be %i", \ + (envPtr)->currStackDepth, dd); \ + } \ + } while (0) + /* * Macro used to update the stack requirements. It is called by the macros * TclEmitOpCode, TclEmitInst1 and TclEmitInst4. @@ -1093,6 +1265,18 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); } while (0) /* + * Macros used to update the flag that indicates if we are at the start of a + * command, based on whether the opcode is INST_START_COMMAND. + * + * void TclUpdateAtCmdStart(unsigned char op, CompileEnv *envPtr); + */ + +#define TclUpdateAtCmdStart(op, envPtr) \ + if ((envPtr)->atCmdStart < 2) { \ + (envPtr)->atCmdStart = ((op) == INST_START_CMD ? 1 : 0); \ + } + +/* * Macro to emit an opcode byte into a CompileEnv's code array. The ANSI C * "prototype" for this macro is: * @@ -1105,7 +1289,7 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); TclExpandCodeArray(envPtr); \ } \ *(envPtr)->codeNext++ = (unsigned char) (op); \ - (envPtr)->atCmdStart = ((op) == INST_START_CMD); \ + TclUpdateAtCmdStart(op, envPtr); \ TclUpdateStackReqs(op, 0, envPtr); \ } while (0) @@ -1157,7 +1341,7 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); } \ *(envPtr)->codeNext++ = (unsigned char) (op); \ *(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i)); \ - (envPtr)->atCmdStart = ((op) == INST_START_CMD); \ + TclUpdateAtCmdStart(op, envPtr); \ TclUpdateStackReqs(op, i, envPtr); \ } while (0) @@ -1175,7 +1359,7 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); (unsigned char) ((unsigned int) (i) >> 8); \ *(envPtr)->codeNext++ = \ (unsigned char) ((unsigned int) (i) ); \ - (envPtr)->atCmdStart = ((op) == INST_START_CMD); \ + TclUpdateAtCmdStart(op, envPtr); \ TclUpdateStackReqs(op, i, envPtr); \ } while (0) @@ -1199,6 +1383,18 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); } while (0) /* + * If the expr compiler finished with TRY_CONVERT, macro to remove it when the + * job is done by the following instruction. + */ + +#define TclClearNumConversion(envPtr) \ + do { \ + if (*(envPtr->codeNext - 1) == INST_TRY_CVT_TO_NUMERIC) { \ + envPtr->codeNext--; \ + } \ + } while (0) + +/* * Macros to update a (signed or unsigned) integer starting at a pointer. The * two variants depend on the number of bytes. The ANSI C "prototypes" for * these macros are: @@ -1308,16 +1504,16 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); #define TclMax(i, j) ((((int) i) > ((int) j))? (i) : (j)) /* - * Convenience macro for use when compiling bodies of commands. The ANSI C - * "prototype" for this macro is: + * Convenience macros for use when compiling bodies of commands. The ANSI C + * "prototype" for these macros are: * - * static void CompileBody(CompileEnv *envPtr, Tcl_Token *tokenPtr, - * Tcl_Interp *interp); + * static void BODY(Tcl_Token *tokenPtr, int word); */ -#define CompileBody(envPtr, tokenPtr, interp) \ - TclCompileCmdWord((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ - (envPtr)) +#define BODY(tokenPtr, word) \ + SetLineInformation((word)); \ + TclCompileCmdWord(interp, (tokenPtr)+1, (tokenPtr)->numComponents, \ + envPtr) /* * Convenience macro for use when compiling tokens to be pushed. The ANSI C @@ -1331,15 +1527,19 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ (envPtr)); /* - * Convenience macro for use when pushing literals. The ANSI C "prototype" for - * this macro is: + * Convenience macros for use when pushing literals. The ANSI C "prototype" for + * these macros are: * * static void PushLiteral(CompileEnv *envPtr, * const char *string, int length); + * static void PushStringLiteral(CompileEnv *envPtr, + * const char *string); */ #define PushLiteral(envPtr, string, length) \ TclEmitPush(TclRegisterNewLiteral((envPtr), (string), (length)), (envPtr)) +#define PushStringLiteral(envPtr, string) \ + PushLiteral((envPtr), (string), (int) (sizeof(string "") - 1)) /* * Macro to advance to the next token; it is more mnemonic than the address @@ -1368,14 +1568,11 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); * of LOOP ranges is an interesting datum for debugging purposes, and that is * what we compute now. * - * static int DeclareExceptionRange(CompileEnv *envPtr, int type); * static int ExceptionRangeStarts(CompileEnv *envPtr, int index); * static void ExceptionRangeEnds(CompileEnv *envPtr, int index); * static void ExceptionRangeTarget(CompileEnv *envPtr, int index, LABEL); */ -#define DeclareExceptionRange(envPtr, type) \ - (TclCreateExceptRange((type), (envPtr))) #define ExceptionRangeStarts(envPtr, index) \ (((envPtr)->exceptDepth++), \ ((envPtr)->maxExceptDepth = \ @@ -1406,6 +1603,76 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); Tcl_DStringLength(dsPtr), /*flags*/ 0) /* + * Macro that encapsulates an efficiency trick that avoids a function call for + * the simplest of compiles. The ANSI C "prototype" for this macro is: + * + * static void CompileWord(CompileEnv *envPtr, Tcl_Token *tokenPtr, + * Tcl_Interp *interp, int word); + */ + +#define CompileWord(envPtr, tokenPtr, interp, word) \ + if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) { \ + PushLiteral((envPtr), (tokenPtr)[1].start, (tokenPtr)[1].size); \ + } else { \ + SetLineInformation((word)); \ + CompileTokens((envPtr), (tokenPtr), (interp)); \ + } + +/* + * TIP #280: Remember the per-word line information of the current command. An + * index is used instead of a pointer as recursive compilation may reallocate, + * i.e. move, the array. This is also the reason to save the nuloc now, it may + * change during the course of the function. + * + * Macro to encapsulate the variable definition and setup. + */ + +#define DefineLineInformation \ + ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ + int eclIndex = mapPtr->nuloc - 1 + +#define SetLineInformation(word) \ + envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ + envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] + +#define PushVarNameWord(i,v,e,f,l,sc,word) \ + SetLineInformation(word); \ + TclPushVarName(i,v,e,f,l,sc) + +/* + * Often want to issue one of two versions of an instruction based on whether + * the argument will fit in a single byte or not. This makes it much clearer. + */ + +#define Emit14Inst(nm,idx,envPtr) \ + if (idx <= 255) { \ + TclEmitInstInt1(nm##1,idx,envPtr); \ + } else { \ + TclEmitInstInt4(nm##4,idx,envPtr); \ + } + +/* + * How to get an anonymous local variable (used for holding temporary values + * off the stack) or a local simple scalar. + */ + +#define AnonymousLocal(envPtr) \ + (TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1, (envPtr))) +#define LocalScalar(chars,len,envPtr) \ + (!TclIsLocalScalar((chars), (len)) ? -1 : \ + TclFindCompiledLocal((chars), (len), /*create*/ 1, (envPtr))) +#define LocalScalarFromToken(tokenPtr,envPtr) \ + ((tokenPtr)->type != TCL_TOKEN_SIMPLE_WORD ? -1 : \ + LocalScalar((tokenPtr)[1].start, (tokenPtr)[1].size, (envPtr))) + +/* + * Flags bits used by TclPushVarName. + */ + +#define TCL_NO_LARGE_INDEX 1 /* Do not return localIndex value > 255 */ +#define TCL_NO_ELEMENT 2 /* Do not push the array element. */ + +/* * DTrace probe macros (NOPs if DTrace support is not enabled). */ diff --git a/generic/tclConfig.c b/generic/tclConfig.c index a4ba71a..2fb3e92 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -26,14 +26,15 @@ #define ASSOC_KEY "tclPackageAboutDict" /* - * A ClientData struct for the QueryConfig command. Store the two bits + * A ClientData struct for the QueryConfig command. Store the three bits * of data we need; the package name for which we store a config dict, - * and the (Tcl_Interp *) in which it is stored. + * the (Tcl_Interp *) in which it is stored, and the encoding. */ typedef struct QCCD { Tcl_Obj *pkg; Tcl_Interp *interp; + char *encoding; } QCCD; /* @@ -75,22 +76,28 @@ Tcl_RegisterConfig( const char *valEncoding) /* Name of the encoding used to store the * configuration values, ASCII, thus UTF-8. */ { + Tcl_Obj *pDB, *pkgDict; Tcl_DString cmdName; const Tcl_Config *cfg; - Tcl_Encoding venc = Tcl_GetEncoding(NULL, valEncoding); QCCD *cdPtr = ckalloc(sizeof(QCCD)); cdPtr->interp = interp; + if (valEncoding) { + cdPtr->encoding = ckalloc(strlen(valEncoding)+1); + strcpy(cdPtr->encoding, valEncoding); + } else { + cdPtr->encoding = NULL; + } cdPtr->pkg = Tcl_NewStringObj(pkgName, -1); /* * Phase I: Adding the provided information to the internal database of - * package meta data. Only if we have an ok encoding. + * package meta data. * * Phase II: Create a command for querying this database, specific to the - * package registerting its configuration. This is the approved interface + * package registering its configuration. This is the approved interface * in TIP 59. In the future a more general interface should be done, as - * followup to TIP 59. Simply because our database is now general across + * follow-up to TIP 59. Simply because our database is now general across * packages, and not a structure tied to one package. * * Note, the created command will have a reference through its clientdata. @@ -103,51 +110,35 @@ Tcl_RegisterConfig( * dictionaries visible at Tcl level. I.e. they are not filled */ - if (venc != NULL) { - Tcl_Obj *pkgDict, *pDB = GetConfigDict(interp); - - /* - * Retrieve package specific configuration... - */ - - if (Tcl_DictObjGet(interp, pDB, cdPtr->pkg, &pkgDict) != TCL_OK - || (pkgDict == NULL)) { - pkgDict = Tcl_NewDictObj(); - } else if (Tcl_IsShared(pkgDict)) { - pkgDict = Tcl_DuplicateObj(pkgDict); - } - - /* - * Extend the package configuration... - */ - - for (cfg=configuration ; cfg->key!=NULL && cfg->key[0]!='\0' ; cfg++) { - Tcl_DString conv; - const char *convValue = - Tcl_ExternalToUtfDString(venc, cfg->value, -1, &conv); + pDB = GetConfigDict(interp); - /* - * We know that the keys are in ASCII/UTF-8, so for them is no - * conversion required. - */ + /* + * Retrieve package specific configuration... + */ - Tcl_DictObjPut(interp, pkgDict, Tcl_NewStringObj(cfg->key, -1), - Tcl_NewStringObj(convValue, -1)); - Tcl_DStringFree(&conv); - } + if (Tcl_DictObjGet(interp, pDB, cdPtr->pkg, &pkgDict) != TCL_OK + || (pkgDict == NULL)) { + pkgDict = Tcl_NewDictObj(); + } else if (Tcl_IsShared(pkgDict)) { + pkgDict = Tcl_DuplicateObj(pkgDict); + } - /* - * We're now done with the encoding, so drop it. - */ + /* + * Extend the package configuration... + * We cannot assume that the encodings are initialized, therefore + * store the value as-is in a byte array. See Bug [9b2e636361]. + */ - Tcl_FreeEncoding(venc); + for (cfg=configuration ; cfg->key!=NULL && cfg->key[0]!='\0' ; cfg++) { + Tcl_DictObjPut(interp, pkgDict, Tcl_NewStringObj(cfg->key, -1), + Tcl_NewByteArrayObj((unsigned char *)cfg->value, strlen(cfg->value))); + } - /* - * Write the changes back into the overall database. - */ + /* + * Write the changes back into the overall database. + */ - Tcl_DictObjPut(interp, pDB, cdPtr->pkg, pkgDict); - } + Tcl_DictObjPut(interp, pDB, cdPtr->pkg, pkgDict); /* * Now create the interface command for retrieval of the package @@ -218,6 +209,9 @@ QueryConfigObjCmd( enum subcmds { CFG_GET, CFG_LIST }; + Tcl_DString conv; + Tcl_Encoding venc = NULL; + const char *value; if ((objc < 2) || (objc > 3)) { Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg?"); @@ -257,7 +251,21 @@ QueryConfigObjCmd( return TCL_ERROR; } - Tcl_SetObjResult(interp, val); + if (cdPtr->encoding) { + venc = Tcl_GetEncoding(interp, cdPtr->encoding); + if (!venc) { + return TCL_ERROR; + } + } + /* + * Value is stored as-is in a byte array, see Bug [9b2e636361], + * so we have to decode it first. + */ + value = (const char *) Tcl_GetByteArrayFromObj(val, &n); + value = Tcl_ExternalToUtfDString(venc, value, n, &conv); + Tcl_SetObjResult(interp, Tcl_NewStringObj(value, + Tcl_DStringLength(&conv))); + Tcl_DStringFree(&conv); return TCL_OK; case CFG_LIST: @@ -324,7 +332,10 @@ QueryConfigDelete( Tcl_DictObjRemove(NULL, pDB, pkgName); Tcl_DecrRefCount(pkgName); - ckfree(cdPtr); + if (cdPtr->encoding) { + ckfree((char *)cdPtr->encoding); + } + ckfree((char *)cdPtr); } /* @@ -366,7 +377,7 @@ GetConfigDict( * * This function is associated with the "Package About dict" assoc data * for an interpreter; it is invoked when the interpreter is deleted in - * order to free the information assoicated with any pending error + * order to free the information associated with any pending error * reports. * * Results: diff --git a/generic/tclDate.c b/generic/tclDate.c index 14bac51..6222a8a 100644 --- a/generic/tclDate.c +++ b/generic/tclDate.c @@ -2686,7 +2686,7 @@ TclDatelex( location->first_column = yyInput - info->dateStart; for ( ; ; ) { - while (isspace(UCHAR(*yyInput))) { + while (TclIsSpaceProc(*yyInput)) { yyInput++; } diff --git a/generic/tclDecls.h b/generic/tclDecls.h index fe9ba2b..91c0add 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -31,6 +31,10 @@ /* !BEGIN!: Do not edit below this line. */ +#ifdef __cplusplus +extern "C" { +#endif + /* * Exported function declarations: */ @@ -59,7 +63,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 +73,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 */ @@ -507,7 +511,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, @@ -1831,19 +1835,19 @@ typedef struct TclStubs { 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 */ @@ -2005,10 +2009,10 @@ typedef struct TclStubs { 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 */ @@ -2479,10 +2483,8 @@ typedef struct TclStubs { void (*tcl_ZlibStreamSetCompressionDictionary) (Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); /* 630 */ } TclStubs; -#ifdef __cplusplus -extern "C" { -#endif extern const TclStubs *tclStubsPtr; + #ifdef __cplusplus } #endif @@ -2511,7 +2513,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 +2521,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 +2841,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 */ @@ -3783,6 +3785,7 @@ extern const TclStubs *tclStubsPtr; # undef Tcl_Init # undef Tcl_SetPanicProc # undef Tcl_SetVar +# undef Tcl_ObjSetVar2 # undef Tcl_StaticPackage # undef TclFSGetNativePath # define Tcl_CreateInterp() (tclStubsPtr->tcl_CreateInterp()) @@ -3791,6 +3794,8 @@ extern const TclStubs *tclStubsPtr; # define Tcl_SetPanicProc(proc) (tclStubsPtr->tcl_SetPanicProc(proc)) # define Tcl_SetVar(interp, varName, newValue, flags) \ (tclStubsPtr->tcl_SetVar(interp, varName, newValue, flags)) +# define Tcl_ObjSetVar2(interp, part1, part2, newValue, flags) \ + (tclStubsPtr->tcl_ObjSetVar2(interp, part1, part2, newValue, flags)) #endif #if defined(_WIN32) && defined(UNICODE) @@ -3803,16 +3808,110 @@ extern const TclStubs *tclStubsPtr; #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT +#undef Tcl_SeekOld +#undef Tcl_TellOld + +#undef Tcl_PkgPresent +#define Tcl_PkgPresent(interp, name, version, exact) \ + Tcl_PkgPresentEx(interp, name, version, exact, NULL) +#undef Tcl_PkgProvide +#define Tcl_PkgProvide(interp, name, version) \ + Tcl_PkgProvideEx(interp, name, version, NULL) +#undef Tcl_PkgRequire +#define Tcl_PkgRequire(interp, name, version, exact) \ + Tcl_PkgRequireEx(interp, name, version, exact, NULL) +#undef Tcl_GetIndexFromObj +#define Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr) \ + Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, \ + sizeof(char *), msg, flags, indexPtr) +#undef Tcl_NewBooleanObj +#define Tcl_NewBooleanObj(boolValue) \ + Tcl_NewIntObj((boolValue)!=0) +#undef Tcl_DbNewBooleanObj +#define Tcl_DbNewBooleanObj(boolValue, file, line) \ + Tcl_DbNewLongObj((boolValue)!=0, file, line) +#undef Tcl_SetBooleanObj +#define Tcl_SetBooleanObj(objPtr, boolValue) \ + Tcl_SetIntObj((objPtr), (boolValue)!=0) +#undef Tcl_SetVar +#define Tcl_SetVar(interp, varName, newValue, flags) \ + Tcl_SetVar2(interp, varName, NULL, newValue, flags) +#undef Tcl_UnsetVar +#define Tcl_UnsetVar(interp, varName, flags) \ + Tcl_UnsetVar2(interp, varName, NULL, flags) +#undef Tcl_GetVar +#define Tcl_GetVar(interp, varName, flags) \ + Tcl_GetVar2(interp, varName, NULL, flags) +#undef Tcl_TraceVar +#define Tcl_TraceVar(interp, varName, flags, proc, clientData) \ + Tcl_TraceVar2(interp, varName, NULL, flags, proc, clientData) +#undef Tcl_UntraceVar +#define Tcl_UntraceVar(interp, varName, flags, proc, clientData) \ + Tcl_UntraceVar2(interp, varName, NULL, flags, proc, clientData) +#undef Tcl_VarTraceInfo +#define Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData) \ + Tcl_VarTraceInfo2(interp, varName, NULL, flags, proc, prevClientData) +#undef Tcl_UpVar +#define Tcl_UpVar(interp, frameName, varName, localName, flags) \ + Tcl_UpVar2(interp, frameName, varName, NULL, localName, flags) + +#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) +# if defined(__CYGWIN__) && defined(TCL_WIDE_INT_IS_LONG) +/* On Cygwin64, long is 64-bit while on Win64 long is 32-bit. Therefore + * we have to make sure that all stub entries on Cygwin64 follow the + * Win64 signature. Cygwin64 stubbed extensions cannot use those stub + * entries any more, they should use the 64-bit alternatives where + * possible. Tcl 9 must find a better solution, but that cannot be done + * without introducing a binary incompatibility. + */ +# undef Tcl_DbNewLongObj +# undef Tcl_GetLongFromObj +# undef Tcl_NewLongObj +# undef Tcl_SetLongObj +# undef Tcl_ExprLong +# undef Tcl_ExprLongObj +# undef Tcl_UniCharNcmp +# undef Tcl_UtfNcmp +# undef Tcl_UtfNcasecmp +# undef Tcl_UniCharNcasecmp +# define Tcl_DbNewLongObj ((Tcl_Obj*(*)(long,const char*,int))Tcl_DbNewWideIntObj) +# define Tcl_GetLongFromObj ((int(*)(Tcl_Interp*,Tcl_Obj*,long*))Tcl_GetWideIntFromObj) +# define Tcl_NewLongObj ((Tcl_Obj*(*)(long))Tcl_NewWideIntObj) +# define Tcl_SetLongObj ((void(*)(Tcl_Obj*,long))Tcl_SetWideIntObj) +# define Tcl_ExprLong TclExprLong + static inline int TclExprLong(Tcl_Interp *interp, const char *string, long *ptr){ + int intValue; + int result = tclStubsPtr->tcl_ExprLong(interp, string, (long *)&intValue); + if (result == TCL_OK) *ptr = (long)intValue; + return result; + } +# define Tcl_ExprLongObj TclExprLongObj + static inline int TclExprLongObj(Tcl_Interp *interp, Tcl_Obj *obj, long *ptr){ + int intValue; + int result = tclStubsPtr->tcl_ExprLongObj(interp, obj, (long *)&intValue); + if (result == TCL_OK) *ptr = (long)intValue; + return result; + } +# define Tcl_UniCharNcmp(ucs,uct,n) \ + ((int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned int))tclStubsPtr->tcl_UniCharNcmp)(ucs,uct,(unsigned int)(n)) +# define Tcl_UtfNcmp(s1,s2,n) \ + ((int(*)(const char*,const char*,unsigned int))tclStubsPtr->tcl_UtfNcmp)(s1,s2,(unsigned int)(n)) +# define Tcl_UtfNcasecmp(s1,s2,n) \ + ((int(*)(const char*,const char*,unsigned int))tclStubsPtr->tcl_UtfNcasecmp)(s1,s2,(unsigned int)(n)) +# define Tcl_UniCharNcasecmp(ucs,uct,n) \ + ((int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned int))tclStubsPtr->tcl_UniCharNcasecmp)(ucs,uct,(unsigned int)(n)) +# endif +#endif + /* * Deprecated Tcl procedures: */ -#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) -# undef Tcl_EvalObj -# define Tcl_EvalObj(interp,objPtr) \ - Tcl_EvalObjEx((interp),(objPtr),0) -# undef Tcl_GlobalEvalObj -# define Tcl_GlobalEvalObj(interp,objPtr) \ - Tcl_EvalObjEx((interp),(objPtr),TCL_EVAL_GLOBAL) -#endif + +#undef Tcl_EvalObj +#define Tcl_EvalObj(interp,objPtr) \ + Tcl_EvalObjEx((interp),(objPtr),0) +#undef Tcl_GlobalEvalObj +#define Tcl_GlobalEvalObj(interp,objPtr) \ + Tcl_EvalObjEx((interp),(objPtr),TCL_EVAL_GLOBAL) #endif /* _TCLDECLS */ diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 170e744..15fbe1e 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -155,6 +155,13 @@ typedef struct Dict { } Dict; /* + * Accessor macro for converting between a Tcl_Obj* and a Dict. Note that this + * must be assignable as well as readable. + */ + +#define DICT(dictObj) (*((Dict **)&(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 +319,7 @@ DeleteChainEntry( return 0; } else { Tcl_Obj *valuePtr = Tcl_GetHashValue(&cPtr->entry); + TclDecrRefCount(valuePtr); } @@ -361,7 +369,7 @@ DupDictInternalRep( Tcl_Obj *srcPtr, Tcl_Obj *copyPtr) { - Dict *oldDict = srcPtr->internalRep.otherValuePtr; + Dict *oldDict = DICT(srcPtr); Dict *newDict = ckalloc(sizeof(Dict)); ChainEntry *cPtr; @@ -396,7 +404,8 @@ DupDictInternalRep( * Store in the object. */ - copyPtr->internalRep.otherValuePtr = newDict; + DICT(copyPtr) = newDict; + copyPtr->internalRep.twoPtrValue.ptr2 = NULL; copyPtr->typePtr = &tclDictType; } @@ -422,14 +431,12 @@ static void FreeDictInternalRep( Tcl_Obj *dictPtr) { - Dict *dict = dictPtr->internalRep.otherValuePtr; + Dict *dict = DICT(dictPtr); dict->refcount--; if (dict->refcount <= 0) { DeleteDict(dict); } - - dictPtr->internalRep.otherValuePtr = NULL; /* Belt and braces! */ dictPtr->typePtr = NULL; } @@ -489,7 +496,7 @@ UpdateStringOfDict( { #define LOCAL_SIZE 20 int localFlags[LOCAL_SIZE], *flagPtr = NULL; - Dict *dict = dictPtr->internalRep.otherValuePtr; + Dict *dict = DICT(dictPtr); ChainEntry *cPtr; Tcl_Obj *keyPtr, *valuePtr; int i, length, bytesNeeded = 0; @@ -602,7 +609,7 @@ SetDictFromAny( Tcl_Obj *objPtr) { Tcl_HashEntry *hPtr; - int isNew, result; + int isNew; Dict *dict = ckalloc(sizeof(Dict)); InitChainTable(dict); @@ -653,10 +660,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; @@ -675,11 +681,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) { @@ -715,7 +720,8 @@ SetDictFromAny( dict->epoch = 0; dict->chain = NULL; dict->refcount = 1; - objPtr->internalRep.otherValuePtr = dict; + DICT(objPtr) = dict; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = &tclDictType; return TCL_OK; @@ -725,15 +731,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; } /* @@ -779,12 +780,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.otherValuePtr; + dict = DICT(dictPtr); if (flags & DICT_PATH_UPDATE) { dict->chain = NULL; } @@ -820,14 +820,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.otherValuePtr; + newDict = DICT(tmpObj); if (flags & DICT_PATH_UPDATE) { if (Tcl_IsShared(tmpObj)) { TclDecrRefCount(tmpObj); @@ -835,7 +834,7 @@ TclTraceDictPath( Tcl_IncrRefCount(tmpObj); Tcl_SetHashValue(hPtr, tmpObj); dict->epoch++; - newDict = tmpObj->internalRep.otherValuePtr; + newDict = DICT(tmpObj); } newDict->chain = dictPtr; @@ -870,17 +869,17 @@ static void InvalidateDictChain( Tcl_Obj *dictObj) { - Dict *dict = dictObj->internalRep.otherValuePtr; + Dict *dict = DICT(dictObj); do { - Tcl_InvalidateStringRep(dictObj); + TclInvalidateStringRep(dictObj); dict->epoch++; dictObj = dict->chain; if (dictObj == NULL) { break; } dict->chain = NULL; - dict = dictObj->internalRep.otherValuePtr; + dict = DICT(dictObj); } while (dict != NULL); } @@ -918,18 +917,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) { - Tcl_InvalidateStringRep(dictPtr); + TclInvalidateStringRep(dictPtr); } - dict = dictPtr->internalRep.otherValuePtr; + dict = DICT(dictPtr); hPtr = CreateChainEntry(dict, keyPtr, &isNew); Tcl_IncrRefCount(valuePtr); if (!isNew) { @@ -972,15 +968,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.otherValuePtr; + dict = DICT(dictPtr); hPtr = Tcl_FindHashEntry(&dict->table, keyPtr); if (hPtr == NULL) { *valuePtrPtr = NULL; @@ -1021,18 +1015,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) { - Tcl_InvalidateStringRep(dictPtr); - } - dict = dictPtr->internalRep.otherValuePtr; + dict = DICT(dictPtr); if (DeleteChainEntry(dict, keyPtr)) { + if (dictPtr->bytes != NULL) { + TclInvalidateStringRep(dictPtr); + } dict->epoch++; } return TCL_OK; @@ -1064,14 +1056,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.otherValuePtr; + dict = DICT(dictPtr); *sizePtr = dict->table.numEntries; return TCL_OK; } @@ -1118,15 +1108,12 @@ 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.otherValuePtr; + dict = DICT(dictPtr); cPtr = dict->entryChainHead; if (cPtr == NULL) { searchPtr->epoch = -1; @@ -1301,11 +1288,12 @@ Tcl_DictObjPutKeyList( return TCL_ERROR; } - dict = dictPtr->internalRep.otherValuePtr; + 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); @@ -1357,7 +1345,7 @@ Tcl_DictObjRemoveKeyList( return TCL_ERROR; } - dict = dictPtr->internalRep.otherValuePtr; + dict = DICT(dictPtr); DeleteChainEntry(dict, keyv[keyc-1]); InvalidateDictChain(dictPtr); return TCL_OK; @@ -1397,13 +1385,14 @@ Tcl_NewDictObj(void) Dict *dict; TclNewObj(dictPtr); - Tcl_InvalidateStringRep(dictPtr); + TclInvalidateStringRep(dictPtr); dict = ckalloc(sizeof(Dict)); InitChainTable(dict); dict->epoch = 0; dict->chain = NULL; dict->refcount = 1; - dictPtr->internalRep.otherValuePtr = dict; + DICT(dictPtr) = dict; + dictPtr->internalRep.twoPtrValue.ptr2 = NULL; dictPtr->typePtr = &tclDictType; return dictPtr; #endif @@ -1446,13 +1435,14 @@ Tcl_DbNewDictObj( Dict *dict; TclDbNewObj(dictPtr, file, line); - Tcl_InvalidateStringRep(dictPtr); + TclInvalidateStringRep(dictPtr); dict = ckalloc(sizeof(Dict)); InitChainTable(dict); dict->epoch = 0; dict->chain = NULL; dict->refcount = 1; - dictPtr->internalRep.otherValuePtr = dict; + DICT(dictPtr) = dict; + dictPtr->internalRep.twoPtrValue.ptr2 = NULL; dictPtr->typePtr = &tclDictType; return dictPtr; #else /* !TCL_MEM_DEBUG */ @@ -1506,7 +1496,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; @@ -1631,8 +1621,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 ...?"); @@ -1640,18 +1629,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; @@ -1683,8 +1672,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 ...?"); @@ -1692,18 +1680,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; @@ -1752,10 +1740,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) { @@ -1837,12 +1824,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) { @@ -2058,13 +2042,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.otherValuePtr; + dict = DICT(dictPtr); statsStr = Tcl_HashStats(&dict->table); Tcl_SetObjResult(interp, Tcl_NewStringObj(statsStr, -1)); @@ -2101,7 +2083,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; } @@ -2154,10 +2136,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 { /* @@ -2166,7 +2148,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]); @@ -2175,11 +2157,11 @@ DictIncrCmd( Tcl_IncrRefCount(incrPtr); code = TclIncrObj(interp, valuePtr, incrPtr); - Tcl_DecrRefCount(incrPtr); + TclDecrRefCount(incrPtr); } } if (code == TCL_OK) { - Tcl_InvalidateStringRep(dictPtr); + TclInvalidateStringRep(dictPtr); valuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr, TCL_LEAVE_ERR_MSG); if (valuePtr == NULL) { @@ -2188,7 +2170,7 @@ DictIncrCmd( Tcl_SetObjResult(interp, valuePtr); } } else if (dictPtr->refCount == 0) { - Tcl_DecrRefCount(dictPtr); + TclDecrRefCount(dictPtr); } return code; } @@ -2222,7 +2204,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; } @@ -2266,9 +2248,9 @@ DictLappendCmd( } if (allocatedValue) { - Tcl_DictObjPut(interp, dictPtr, objv[2], valuePtr); + Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr); } else if (dictPtr->bytes != NULL) { - Tcl_InvalidateStringRep(dictPtr); + TclInvalidateStringRep(dictPtr); } resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr, @@ -2309,7 +2291,7 @@ DictAppendCmd( int i, allocatedDict = 0; if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "varName key ?value ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?value ...?"); return TCL_ERROR; } @@ -2331,17 +2313,15 @@ DictAppendCmd( if (valuePtr == NULL) { TclNewObj(valuePtr); - } else { - if (Tcl_IsShared(valuePtr)) { - valuePtr = Tcl_DuplicateObj(valuePtr); - } + } else if (Tcl_IsShared(valuePtr)) { + valuePtr = Tcl_DuplicateObj(valuePtr); } for (i=3 ; i<objc ; i++) { Tcl_AppendObjToObj(valuePtr, objv[i]); } - Tcl_DictObjPut(interp, dictPtr, objv[2], valuePtr); + Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr); resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr, TCL_LEAVE_ERR_MSG); @@ -2385,7 +2365,7 @@ DictForNRCmd( if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, - "{keyVar valueVar} dictionary script"); + "{keyVarName valueVarName} dictionary script"); return TCL_ERROR; } @@ -2399,6 +2379,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)); @@ -2432,12 +2413,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; } @@ -2576,7 +2559,7 @@ DictMapNRCmd( if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, - "{keyVar valueVar} dictionary script"); + "{keyVarName valueVarName} dictionary script"); return TCL_ERROR; } @@ -2590,6 +2573,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)); @@ -2784,7 +2768,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; } @@ -2844,7 +2828,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; } @@ -2951,12 +2935,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); } @@ -2974,7 +2958,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 */ } } @@ -3000,7 +2984,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 */ } } @@ -3012,7 +2996,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; } @@ -3028,6 +3012,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]; @@ -3066,19 +3051,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; } @@ -3101,7 +3082,7 @@ DictFilterCmd( } TclDecrRefCount(boolObj); if (satisfied) { - Tcl_DictObjPut(interp, resultObj, keyObj, valueObj); + Tcl_DictObjPut(NULL, resultObj, keyObj, valueObj); } break; case TCL_BREAK: @@ -3192,7 +3173,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; } @@ -3289,18 +3270,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); @@ -3349,7 +3329,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; } diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 7d2206b..d246cb2 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -9,7 +9,6 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#include <sys/stat.h> #include "tclInt.h" typedef size_t (LengthProc)(const char *src); @@ -183,6 +182,7 @@ TCL_DECLARE_MUTEX(encodingMutex) static Tcl_Encoding defaultEncoding; static Tcl_Encoding systemEncoding; +Tcl_Encoding tclIdentityEncoding; /* * The following variable is used in the sparse matrix code for a @@ -271,7 +271,7 @@ static int Iso88591ToUtfProc(ClientData clientData, int *dstCharsPtr); /* - * A Tcl_ObjType for holding a cached Tcl_Encoding in the otherValuePtr field + * A Tcl_ObjType for holding a cached Tcl_Encoding in the twoPtrValue.ptr1 field * of the intrep. This should help the lifetime of encodings be more useful. * See concerns raised in [Bug 1077262]. */ @@ -314,7 +314,7 @@ Tcl_GetEncodingFromObj( return TCL_ERROR; } TclFreeIntRep(objPtr); - objPtr->internalRep.otherValuePtr = encoding; + objPtr->internalRep.twoPtrValue.ptr1 = encoding; objPtr->typePtr = &encodingType; } *encodingPtr = Tcl_GetEncoding(NULL, name); @@ -335,7 +335,7 @@ static void FreeEncodingIntRep( Tcl_Obj *objPtr) { - Tcl_FreeEncoding(objPtr->internalRep.otherValuePtr); + Tcl_FreeEncoding(objPtr->internalRep.twoPtrValue.ptr1); objPtr->typePtr = NULL; } @@ -354,7 +354,7 @@ DupEncodingIntRep( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { - dupPtr->internalRep.otherValuePtr = Tcl_GetEncoding(NULL, srcPtr->bytes); + dupPtr->internalRep.twoPtrValue.ptr1 = Tcl_GetEncoding(NULL, srcPtr->bytes); } /* @@ -568,7 +568,7 @@ TclInitEncodingSubsystem(void) type.freeProc = NULL; type.nullSize = 1; type.clientData = NULL; - Tcl_CreateEncoding(&type); + tclIdentityEncoding = Tcl_CreateEncoding(&type); type.encodingName = "utf-8"; type.toUtfProc = UtfExtToUtfIntProc; @@ -652,6 +652,7 @@ TclFinalizeEncodingSubsystem(void) Tcl_MutexLock(&encodingMutex); encodingsInitialized = 0; FreeEncoding(systemEncoding); + FreeEncoding(tclIdentityEncoding); hPtr = Tcl_FirstHashEntry(&encodingTable, &search); while (hPtr != NULL) { diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 88de9f3..022dafa 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -35,9 +35,6 @@ static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr, static void FreeEnsembleCmdRep(Tcl_Obj *objPtr); static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static void StringOfEnsembleCmdRep(Tcl_Obj *objPtr); -static int CompileToCompiledCommand(Tcl_Interp *interp, - Tcl_Parse *parsePtr, int depth, Command *cmdPtr, - CompileEnv *envPtr); static void CompileToInvokedCommand(Tcl_Interp *interp, Tcl_Parse *parsePtr, Tcl_Obj *replacements, Command *cmdPtr, CompileEnv *envPtr); @@ -88,16 +85,6 @@ const Tcl_ObjType tclEnsembleCmdType = { NULL /* setFromAnyProc */ }; -/* - * Copied from tclCompCmds.c - */ - -#define DefineLineInformation \ - ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ - int eclIndex = mapPtr->nuloc - 1 -#define SetLineInformation(word) \ - envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ - envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] static inline Tcl_Obj * NewNsObj( @@ -1537,6 +1524,14 @@ TclMakeEnsemble( cmdName = nameParts[nameCount - 1]; } } + + /* + * Switch on compilation always for core ensembles now that we can do + * nice bytecode things with them. Do it now. Waiting until later will + * just cause pointless epoch bumps. + */ + + ensembleFlags |= ENSEMBLE_COMPILE; ensemble = Tcl_CreateEnsemble(interp, cmdName, ns, ensembleFlags); /* @@ -1588,14 +1583,6 @@ TclMakeEnsemble( } } Tcl_SetEnsembleMappingDict(interp, ensemble, mapDict); - - /* - * Switch on compilation always for core ensembles now that we can do - * nice bytecode things with them. - */ - - Tcl_SetEnsembleFlags(interp, ensemble, - ensembleFlags | ENSEMBLE_COMPILE); } Tcl_DStringFree(&buf); @@ -1718,7 +1705,7 @@ NsEnsembleImplementationCmdNR( if (objv[1+ensemblePtr->numParameters]->typePtr==&tclEnsembleCmdType){ EnsembleCmdRep *ensembleCmd = objv[1+ensemblePtr->numParameters] - ->internalRep.otherValuePtr; + ->internalRep.twoPtrValue.ptr1; if (ensembleCmd->nsPtr == ensemblePtr->nsPtr && ensembleCmd->epoch == ensemblePtr->epoch && @@ -2196,7 +2183,7 @@ EnsembleUnknownCallback( } Tcl_AddErrorInfo(interp, "\n result of " "ensemble unknown subcommand handler: "); - Tcl_AddErrorInfo(interp, TclGetString(unknownCmd)); + Tcl_AppendObjToErrorInfo(interp, unknownCmd); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_RESULT", NULL); } else { @@ -2238,7 +2225,7 @@ MakeCachedEnsembleCommand( int length; if (objPtr->typePtr == &tclEnsembleCmdType) { - ensembleCmd = objPtr->internalRep.otherValuePtr; + ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; Tcl_DecrRefCount(ensembleCmd->realPrefixObj); TclNsDecrRefCount(ensembleCmd->nsPtr); ckfree(ensembleCmd->fullSubcmdName); @@ -2250,7 +2237,7 @@ MakeCachedEnsembleCommand( TclFreeIntRep(objPtr); ensembleCmd = ckalloc(sizeof(EnsembleCmdRep)); - objPtr->internalRep.otherValuePtr = ensembleCmd; + objPtr->internalRep.twoPtrValue.ptr1 = ensembleCmd; objPtr->typePtr = &tclEnsembleCmdType; } @@ -2645,7 +2632,7 @@ static void FreeEnsembleCmdRep( Tcl_Obj *objPtr) { - EnsembleCmdRep *ensembleCmd = objPtr->internalRep.otherValuePtr; + EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; Tcl_DecrRefCount(ensembleCmd->realPrefixObj); ckfree(ensembleCmd->fullSubcmdName); @@ -2677,12 +2664,12 @@ DupEnsembleCmdRep( Tcl_Obj *objPtr, Tcl_Obj *copyPtr) { - EnsembleCmdRep *ensembleCmd = objPtr->internalRep.otherValuePtr; + EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; EnsembleCmdRep *ensembleCopy = ckalloc(sizeof(EnsembleCmdRep)); int length = strlen(ensembleCmd->fullSubcmdName); copyPtr->typePtr = &tclEnsembleCmdType; - copyPtr->internalRep.otherValuePtr = ensembleCopy; + copyPtr->internalRep.twoPtrValue.ptr1 = ensembleCopy; ensembleCopy->nsPtr = ensembleCmd->nsPtr; ensembleCopy->epoch = ensembleCmd->epoch; ensembleCopy->token = ensembleCmd->token; @@ -2715,7 +2702,7 @@ static void StringOfEnsembleCmdRep( Tcl_Obj *objPtr) { - EnsembleCmdRep *ensembleCmd = objPtr->internalRep.otherValuePtr; + EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; int length = strlen(ensembleCmd->fullSubcmdName); objPtr->length = length; @@ -2764,13 +2751,6 @@ TclCompileEnsemble( const char *word; 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; } @@ -2782,6 +2762,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; @@ -2992,6 +2978,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; } @@ -3004,8 +3001,8 @@ TclCompileEnsemble( */ invokeAnyway = 1; - if (CompileToCompiledCommand(interp, parsePtr, depth, cmdPtr, - envPtr) == TCL_OK) { + if (TCL_OK == TclAttemptCompileProc(interp, parsePtr, depth, cmdPtr, + envPtr)) { ourResult = TCL_OK; goto cleanup; } @@ -3039,95 +3036,88 @@ TclCompileEnsemble( return ourResult; } -/* - * How to compile a subcommand using its own command compiler. To do that, we - * have to perform some trickery to rewrite the arguments, as compilers *must* - * have parse tokens that refer to addresses in the original script. - */ - -static int -CompileToCompiledCommand( +int +TclAttemptCompileProc( Tcl_Interp *interp, Tcl_Parse *parsePtr, int depth, Command *cmdPtr, CompileEnv *envPtr) /* Holds resulting instructions. */ { - Tcl_Parse synthetic; - Tcl_Token *tokenPtr; int result, i; - int savedNumCmds = envPtr->numCommands; + Tcl_Token *saveTokenPtr = parsePtr->tokenPtr; int savedStackDepth = envPtr->currStackDepth; unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart; + DefineLineInformation; if (cmdPtr->compileProc == NULL) { return TCL_ERROR; } - TclParseInit(interp, NULL, 0, &synthetic); - synthetic.numWords = parsePtr->numWords - depth + 1; - TclGrowParseTokenArray(&synthetic, 2); - synthetic.numTokens = 2; - /* - * Now we have the space to work in, install something rewritten. The - * first word will "officially" be the bytes of the structured ensemble - * name. That's technically wrong, but nobody will care; we just need - * *something* here... + * Advance parsePtr->tokenPtr so that it points at the last subcommand. + * This will be wrong, but it will not matter, and it will put the + * tokens for the arguments in the right place without the needed to + * allocate a synthetic Tcl_Parse struct, or copy tokens around. */ - synthetic.tokenPtr[0].type = TCL_TOKEN_SIMPLE_WORD; - synthetic.tokenPtr[0].start = parsePtr->tokenPtr[0].start; - synthetic.tokenPtr[0].numComponents = 1; - synthetic.tokenPtr[1].type = TCL_TOKEN_TEXT; - synthetic.tokenPtr[1].start = parsePtr->tokenPtr[0].start; - synthetic.tokenPtr[1].numComponents = 0; - for (i=0,tokenPtr=parsePtr->tokenPtr ; i<depth ; i++) { - int sclen = (tokenPtr->start - synthetic.tokenPtr[0].start) - + tokenPtr->size; - - synthetic.tokenPtr[0].size = sclen; - synthetic.tokenPtr[1].size = sclen; - tokenPtr = TokenAfter(tokenPtr); + for (i = 0; i < depth - 1; i++) { + parsePtr->tokenPtr = TokenAfter(parsePtr->tokenPtr); } + parsePtr->numWords -= (depth - 1); /* - * Copy over the real argument tokens. + * Shift the line information arrays to account for different word + * index values. */ - for (i=1; i<synthetic.numWords; i++) { - int toCopy; - - toCopy = tokenPtr->numComponents + 1; - TclGrowParseTokenArray(&synthetic, toCopy); - memcpy(synthetic.tokenPtr + synthetic.numTokens, tokenPtr, - sizeof(Tcl_Token) * toCopy); - synthetic.numTokens += toCopy; - tokenPtr = TokenAfter(tokenPtr); - } + mapPtr->loc[eclIndex].line += (depth - 1); + mapPtr->loc[eclIndex].next += (depth - 1); /* * Hand off compilation to the subcommand compiler. At last! */ - result = cmdPtr->compileProc(interp, &synthetic, cmdPtr, envPtr); + result = cmdPtr->compileProc(interp, parsePtr, cmdPtr, envPtr); + + /* + * Undo the shift. + */ + + mapPtr->loc[eclIndex].line -= (depth - 1); + mapPtr->loc[eclIndex].next -= (depth - 1); + + parsePtr->numWords += (depth - 1); + parsePtr->tokenPtr = saveTokenPtr; /* - * If our target fails to compile, revert the number of commands and the - * pointer to the place to issue the next instruction. [Bug 3600328] + * If our target failed to compile, revert any data from failed partial + * compiles. Note that envPtr->numCommands need not be checked because + * we avoid compiling subcommands that recursively call TclCompileScript(). */ if (result != TCL_OK) { - envPtr->numCommands = savedNumCmds; envPtr->currStackDepth = savedStackDepth; envPtr->codeNext = envPtr->codeStart + savedCodeNext; - } +#ifdef TCL_COMPILE_DEBUG + } else { + /* + * Confirm that the command compiler generated a single value on + * the stack as its result. This is only done in debugging mode, + * as it *should* be correct and normal users have no reasonable + * way to fix it anyway. + */ - /* - * Clean up if necessary. - */ + int diff = envPtr->currStackDepth - savedStackDepth; + + if (diff != 1) { + Tcl_Panic("bad stack adjustment when compiling" + " %.*s (was %d instead of 1)", parsePtr->tokenPtr->size, + parsePtr->tokenPtr->start, diff); + } +#endif + } - Tcl_FreeParse(&synthetic); return result; } @@ -3157,28 +3147,29 @@ CompileToInvokedCommand( */ Tcl_ListObjGetElements(NULL, replacements, &numWords, &words); - for (i=0,tokPtr=parsePtr->tokenPtr ; i<parsePtr->numWords ; i++) { + for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords; + i++, tokPtr = TokenAfter(tokPtr)) { if (i > 0 && i < numWords+1) { bytes = Tcl_GetStringFromObj(words[i-1], &length); PushLiteral(envPtr, bytes, length); - } else if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) { + continue; + } + + SetLineInformation(i); + if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) { int literal = TclRegisterNewLiteral(envPtr, tokPtr[1].start, tokPtr[1].size); if (envPtr->clNext) { TclContinuationsEnterDerived( - envPtr->literalArrayPtr[literal].objPtr, + TclFetchLiteral(envPtr, literal), tokPtr[1].start - envPtr->source, - mapPtr->loc[eclIndex].next[i]); + envPtr->clNext); } TclEmitPush(literal, envPtr); } else { - if (envPtr->clNext) { - SetLineInformation(i); - } CompileTokens(envPtr, tokPtr, interp); } - tokPtr = TokenAfter(tokPtr); } /* @@ -3190,7 +3181,7 @@ CompileToInvokedCommand( Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); bytes = Tcl_GetStringFromObj(objPtr, &length); cmdLit = TclRegisterNewCmdLiteral(envPtr, bytes, length); - TclSetCmdNameObj(interp, envPtr->literalArrayPtr[cmdLit].objPtr, cmdPtr); + TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLit), cmdPtr); TclEmitPush(cmdLit, envPtr); TclDecrRefCount(objPtr); @@ -3198,9 +3189,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); } /* @@ -3224,51 +3213,13 @@ CompileBasicNArgCommand( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - Tcl_Token *tokenPtr; - Tcl_Obj *objPtr; - char *bytes; - int length, i, literal; - DefineLineInformation; - - /* - * Push the name of the command we're actually dispatching to as part of - * the implementation. - */ + Tcl_Obj *objPtr = Tcl_NewObj(); - objPtr = Tcl_NewObj(); + Tcl_IncrRefCount(objPtr); Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); - bytes = Tcl_GetStringFromObj(objPtr, &length); - literal = TclRegisterNewCmdLiteral(envPtr, bytes, length); - TclSetCmdNameObj(interp, envPtr->literalArrayPtr[literal].objPtr, cmdPtr); - TclEmitPush(literal, envPtr); - TclDecrRefCount(objPtr); - - /* - * Push the words of the command. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - for (i=1 ; i<parsePtr->numWords ; i++) { - if (envPtr->clNext) { - SetLineInformation(i); - } - if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - PushLiteral(envPtr, tokenPtr[1].start, tokenPtr[1].size); - } else { - CompileTokens(envPtr, tokenPtr, interp); - } - tokenPtr = TokenAfter(tokenPtr); - } - - /* - * Do the standard dispatch. - */ - - if (i <= 255) { - TclEmitInstInt1(INST_INVOKE_STK1, i, envPtr); - } else { - TclEmitInstInt4(INST_INVOKE_STK4, i, envPtr); - } + TclCompileInvocation(interp, parsePtr->tokenPtr, objPtr, + parsePtr->numWords, envPtr); + Tcl_DecrRefCount(objPtr); return TCL_OK; } diff --git a/generic/tclEnv.c b/generic/tclEnv.c index b5ae6ea..cd1a954 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -76,36 +76,56 @@ TclSetupEnv( Tcl_Interp *interp) /* Interpreter whose "env" array is to be * managed. */ { + Var *varPtr, *arrayPtr; + Tcl_Obj *varNamePtr; Tcl_DString envString; - char *p1, *p2; - int i; + Tcl_HashTable namesHash; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; /* * Synchronize the values in the environ array with the contents of the * Tcl "env" variable. To do this: - * 1) Remove the trace that fires when the "env" var is unset. - * 2) Unset the "env" variable. - * 3) If there are no environ variables, create an empty "env" array. - * Otherwise populate the array with current values. - * 4) Add a trace that synchronizes the "env" array. + * 1) Remove the trace that fires when the "env" var is updated. + * 2) Find the existing contents of the "env", storing in a hash table. + * 3) Create/update elements for each environ variable, removing + * elements from the hash table as we go. + * 4) Remove the elements for each remaining entry in the hash table, + * which must have existed before yet have no analog in the environ + * variable. + * 5) Add a trace that synchronizes the "env" array. */ Tcl_UntraceVar2(interp, "env", NULL, TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc, NULL); - Tcl_UnsetVar2(interp, "env", NULL, TCL_GLOBAL_ONLY); + /* + * Find out what elements are currently in the global env array. + */ - if (environ[0] == NULL) { - Tcl_Obj *varNamePtr; + TclNewLiteralStringObj(varNamePtr, "env"); + Tcl_IncrRefCount(varNamePtr); + Tcl_InitObjHashTable(&namesHash); + varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL, TCL_GLOBAL_ONLY, + /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); + TclFindArrayPtrElements(varPtr, &namesHash); + + /* + * Go through the environment array and transfer its values into Tcl. At + * the same time, remove those elements we add/update from the hash table + * of existing elements, so that after this part processes, that table + * will hold just the parts to remove. + */ + + if (environ[0] != NULL) { + int i; - TclNewLiteralStringObj(varNamePtr, "env"); - Tcl_IncrRefCount(varNamePtr); - TclArraySet(interp, varNamePtr, NULL); - Tcl_DecrRefCount(varNamePtr); - } else { Tcl_MutexLock(&envMutex); for (i = 0; environ[i] != NULL; i++) { + Tcl_Obj *obj1, *obj2; + char *p1, *p2; + p1 = Tcl_ExternalToUtfDString(NULL, environ[i], -1, &envString); p2 = strchr(p1, '='); if (p2 == NULL) { @@ -119,12 +139,41 @@ TclSetupEnv( } p2++; p2[-1] = '\0'; - Tcl_SetVar2(interp, "env", p1, p2, TCL_GLOBAL_ONLY); + obj1 = Tcl_NewStringObj(p1, -1); + obj2 = Tcl_NewStringObj(p2, -1); Tcl_DStringFree(&envString); + + Tcl_IncrRefCount(obj1); + Tcl_IncrRefCount(obj2); + Tcl_ObjSetVar2(interp, varNamePtr, obj1, obj2, TCL_GLOBAL_ONLY); + hPtr = Tcl_FindHashEntry(&namesHash, obj1); + if (hPtr != NULL) { + Tcl_DeleteHashEntry(hPtr); + } + Tcl_DecrRefCount(obj1); + Tcl_DecrRefCount(obj2); } Tcl_MutexUnlock(&envMutex); } + /* + * Delete those elements that existed in the array but which had no + * counterparts in the environment array. + */ + + for (hPtr=Tcl_FirstHashEntry(&namesHash, &search); hPtr!=NULL; + hPtr=Tcl_NextHashEntry(&search)) { + Tcl_Obj *elemName = Tcl_GetHashValue(hPtr); + + TclObjUnsetVar2(interp, varNamePtr, elemName, TCL_GLOBAL_ONLY); + } + Tcl_DeleteHashTable(&namesHash); + Tcl_DecrRefCount(varNamePtr); + + /* + * Re-establish the trace. + */ + Tcl_TraceVar2(interp, "env", NULL, TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc, NULL); @@ -395,7 +444,7 @@ TclUnsetEnv( * that no = should be included, and Windows requires it. */ -#if defined(__WIN32__) || defined(__CYGWIN__) +#if defined(_WIN32) || defined(__CYGWIN__) string = ckalloc(length + 2); memcpy(string, name, (size_t) length); string[length] = '='; @@ -404,7 +453,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); @@ -565,7 +614,8 @@ EnvTraceProc( const char *value = TclGetEnv(name2, &valueString); if (value == NULL) { - return (char *) "no such variable"; + Tcl_UnsetVar2(interp, name1, name2, 0); + return NULL; } Tcl_SetVar2(interp, name1, name2, value, 0); Tcl_DStringFree(&valueString); diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 0b585b6..941d566 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1030,14 +1030,8 @@ TclInitSubsystems(void) TclpInitLock(); if (subsystemsInitialized == 0) { - /* - * Have to set this bit here to avoid deadlock with the routines - * below us that call into TclInitSubsystems. - */ - - subsystemsInitialized = 1; - /* + /* * Initialize locks used by the memory allocators before anything * interesting happens so we can use the allocators in the * implementation of self-initializing locks. @@ -1061,6 +1055,7 @@ TclInitSubsystems(void) TclInitEncodingSubsystem(); /* Process wide encoding init. */ TclpSetInterfaces(); TclInitNamespaceSubsystem();/* Register ns obj type (mutexed). */ + subsystemsInitialized = 1; } TclpInitUnlock(); } @@ -1176,8 +1171,6 @@ Tcl_Finalize(void) TclFinalizeEncodingSubsystem(); - Tcl_SetPanicProc(NULL); - /* * Repeat finalization of the thread local storage once more. Although * this step is already done by the Tcl_FinalizeThread call above, series @@ -1402,7 +1395,7 @@ Tcl_VwaitObjCmd( return TCL_ERROR; } nameString = Tcl_GetString(objv[1]); - if (Tcl_TraceVar(interp, nameString, + if (Tcl_TraceVar2(interp, nameString, NULL, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, VwaitVarProc, &done) != TCL_OK) { return TCL_ERROR; @@ -1420,7 +1413,7 @@ Tcl_VwaitObjCmd( break; } } - Tcl_UntraceVar(interp, nameString, + Tcl_UntraceVar2(interp, nameString, NULL, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, VwaitVarProc, &done); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 8a68e9b..2f9aac3 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -174,34 +174,32 @@ 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) #define PUSH_TAUX_OBJ(objPtr) \ do { \ + if (auxObjList) { \ + objPtr->length += auxObjList->length; \ + } \ objPtr->internalRep.ptrAndLongRep.ptr = auxObjList; \ auxObjList = objPtr; \ } while (0) @@ -257,7 +255,7 @@ VarHashCreateVar( /* Verify the stack depth, only when no expansion is in progress */ -#if TCL_COMPILE_DEBUG +#ifdef TCL_COMPILE_DEBUG #define CHECK_STACK() \ do { \ ValidatePcAndStackTop(codePtr, pc, CURR_DEPTH, \ @@ -290,12 +288,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) @@ -315,6 +315,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() @@ -357,6 +421,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 @@ -378,6 +444,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, \ @@ -394,6 +462,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 */ @@ -434,7 +503,7 @@ VarHashCreateVar( * ClientData *ptrPtr, int *tPtr); */ -#ifdef NO_WIDE_TYPE +#ifdef TCL_WIDE_INT_IS_LONG #define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ (((objPtr)->typePtr == &tclIntType) \ ? (*(tPtr) = TCL_NUMBER_LONG, \ @@ -448,9 +517,9 @@ VarHashCreateVar( (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ ((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \ (((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \ - ? TCL_ERROR : \ + ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \ TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) -#else /* !NO_WIDE_TYPE */ +#else /* !TCL_WIDE_INT_IS_LONG */ #define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ (((objPtr)->typePtr == &tclIntType) \ ? (*(tPtr) = TCL_NUMBER_LONG, \ @@ -468,9 +537,9 @@ VarHashCreateVar( (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ ((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \ (((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \ - ? TCL_ERROR : \ + ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \ TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) -#endif /* NO_WIDE_TYPE */ +#endif /* TCL_WIDE_INT_IS_LONG */ /* * Macro used in this file to save a function call for common uses of @@ -487,30 +556,6 @@ VarHashCreateVar( : 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 NO_WIDE_TYPE -#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ - (((objPtr)->typePtr == &tclIntType) \ - ? (*(wideIntPtr) = (Tcl_WideInt) \ - ((objPtr)->internalRep.longValue), TCL_OK) : \ - Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) -#else /* !NO_WIDE_TYPE */ -#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 /* NO_WIDE_TYPE */ - -/* * Macro used to make the check for type overflow more mnemonic. This works by * comparing sign bits; the rest of the word is irrelevant. The ANSI C * "prototype" (where inttype_t is any integer type) is: @@ -718,20 +763,21 @@ static ExceptionRange * GetExceptRangeForPc(const unsigned char *pc, int catchOnly, ByteCode *codePtr); static const char * GetSrcInfoForPc(const unsigned char *pc, ByteCode *codePtr, int *lengthPtr, - const unsigned char **pcBeg); + const unsigned char **pcBeg, int *cmdIdxPtr); static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, int growth, int move); static void IllegalExprOperandType(Tcl_Interp *interp, const unsigned char *pc, Tcl_Obj *opndPtr); static void InitByteCodeExecution(Tcl_Interp *interp); -static inline int OFFSET(void *ptr); +static inline int wordSkip(void *ptr); static void ReleaseDictIterator(Tcl_Obj *objPtr); /* Useful elsewhere, make available in tclInt.h or stubs? */ static Tcl_Obj ** StackAllocWords(Tcl_Interp *interp, int numWords); 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; /* @@ -882,7 +928,7 @@ TclCreateExecEnv( esPtr->nextPtr = NULL; esPtr->markerPtr = NULL; esPtr->endPtr = &esPtr->stackWords[size-1]; - esPtr->tosPtr = &esPtr->stackWords[-1]; + esPtr->tosPtr = STACK_BASE(esPtr); Tcl_MutexLock(&execMutex); if (!execInitialized) { @@ -1001,13 +1047,13 @@ TclFinalizeExecution(void) (TCL_ALLOCALIGN/sizeof(Tcl_Obj *)) /* - * OFFSET computes how many words have to be skipped until the next aligned + * wordSkip computes how many words have to be skipped until the next aligned * word. Note that we are only interested in the low order bits of ptr, so * that any possible information loss in PTR2INT is of no consequence. */ static inline int -OFFSET( +wordSkip( void *ptr) { int mask = TCL_ALLOCALIGN-1; @@ -1020,7 +1066,7 @@ OFFSET( */ #define MEMSTART(markerPtr) \ - ((markerPtr) + OFFSET(markerPtr)) + ((markerPtr) + wordSkip(markerPtr)) /* *---------------------------------------------------------------------- @@ -1065,7 +1111,7 @@ GrowEvaluationStack( } else { #ifndef PURIFY Tcl_Obj **tmpMarkerPtr = esPtr->tosPtr + 1; - int offset = OFFSET(tmpMarkerPtr); + int offset = wordSkip(tmpMarkerPtr); if (needed + offset < 0) { /* @@ -1103,8 +1149,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) { @@ -1116,7 +1162,7 @@ GrowEvaluationStack( DeleteExecStack(esPtr); esPtr = oldPtr; } else { - currElems = esPtr->endPtr - &esPtr->stackWords[-1]; + currElems = esPtr->endPtr - STACK_BASE(esPtr); } /* @@ -1270,10 +1316,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; @@ -1423,17 +1469,12 @@ Tcl_NRExprObj( Tcl_Obj *resultPtr) { ByteCode *codePtr; + Tcl_InterpState state = Tcl_SaveInterpState(interp, TCL_OK); - /* TODO: consider saving whole state? */ - Tcl_Obj *saveObjPtr = Tcl_GetObjResult(interp); - - Tcl_IncrRefCount(saveObjPtr); - + Tcl_ResetResult(interp); codePtr = CompileExprObj(interp, objPtr); - /* TODO: Confirm reset not required? */ - /*Tcl_ResetResult(interp);*/ - Tcl_NRAddCallback(interp, ExprObjCallback, saveObjPtr, resultPtr, + Tcl_NRAddCallback(interp, ExprObjCallback, state, resultPtr, NULL, NULL); return TclNRExecuteByteCode(interp, codePtr); } @@ -1444,14 +1485,15 @@ ExprObjCallback( Tcl_Interp *interp, int result) { - Tcl_Obj *saveObjPtr = data[0]; + Tcl_InterpState state = data[0]; Tcl_Obj *resultPtr = data[1]; if (result == TCL_OK) { TclSetDuplicateObj(resultPtr, Tcl_GetObjResult(interp)); - Tcl_SetObjResult(interp, saveObjPtr); + (void) Tcl_RestoreInterpState(interp, state); + } else { + Tcl_DiscardInterpState(state); } - TclDecrRefCount(saveObjPtr); return result; } @@ -1494,7 +1536,7 @@ CompileExprObj( if (objPtr->typePtr == &exprCodeType) { Namespace *namespacePtr = iPtr->varFramePtr->nsPtr; - codePtr = objPtr->internalRep.otherValuePtr; + codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != namespacePtr) @@ -1534,7 +1576,7 @@ CompileExprObj( TclInitByteCodeObj(objPtr, &compEnv); objPtr->typePtr = &exprCodeType; TclFreeCompileEnv(&compEnv); - codePtr = objPtr->internalRep.otherValuePtr; + codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; @@ -1606,10 +1648,9 @@ static void FreeExprCodeInternalRep( Tcl_Obj *objPtr) { - ByteCode *codePtr = objPtr->internalRep.otherValuePtr; + ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; objPtr->typePtr = NULL; - objPtr->internalRep.otherValuePtr = NULL; codePtr->refCount--; if (codePtr->refCount <= 0) { TclCleanupByteCode(codePtr); @@ -1667,7 +1708,7 @@ TclCompileObj( * here. */ - codePtr = objPtr->internalRep.otherValuePtr; + codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != namespacePtr) @@ -1795,7 +1836,7 @@ TclCompileObj( iPtr->invokeWord = word; TclSetByteCodeFromAny(interp, objPtr, NULL, NULL); iPtr->invokeCmdFramePtr = NULL; - codePtr = objPtr->internalRep.otherValuePtr; + codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; @@ -1869,7 +1910,7 @@ TclIncrObj( TclSetLongObj(valuePtr, sum); return TCL_OK; } -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG { Tcl_WideInt w1 = (Tcl_WideInt) augend; Tcl_WideInt w2 = (Tcl_WideInt) addend; @@ -1902,7 +1943,7 @@ TclIncrObj( return TCL_ERROR; } -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG if ((type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) { Tcl_WideInt w1, w2, sum; @@ -1932,6 +1973,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 @@ -1964,10 +2040,6 @@ TclNRExecuteByteCode( * sizeof(void *); int numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *); - if (iPtr->execEnvPtr->rewind) { - return TCL_ERROR; - } - codePtr->refCount++; /* @@ -1986,11 +2058,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 @@ -2000,7 +2069,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; @@ -2008,8 +2076,9 @@ TclNRExecuteByteCode( bcFramePtr->litarg = NULL; bcFramePtr->data.tebc.codePtr = codePtr; bcFramePtr->data.tebc.pc = NULL; - bcFramePtr->cmd.str.cmd = NULL; - bcFramePtr->cmd.str.len = 0; + bcFramePtr->cmdObj = NULL; + bcFramePtr->cmd = NULL; + bcFramePtr->len = 0; #ifdef TCL_COMPILE_STATS iPtr->stats.numExecutions++; @@ -2019,8 +2088,8 @@ TclNRExecuteByteCode( * 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; } @@ -2076,9 +2145,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. @@ -2086,7 +2152,8 @@ 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 */ /* @@ -2094,8 +2161,10 @@ TEBCresume( * 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 @@ -2120,82 +2189,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 (!pc) { + /* bytecode is starting from scratch */ + checkInterp = 0; + pc = codePtr->codeStart; + goto cleanup0; + } else { + /* resume from invocation */ + CACHE_STACK_INFO(); if (iPtr->execEnvPtr->rewind) { result = TCL_ERROR; + goto abnormalReturn; } + 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 (codePtr->flags & TCL_BYTECODE_RECOMPILE) { iPtr->flags |= ERR_ALREADY_LOGGED; codePtr->flags &= ~TCL_BYTECODE_RECOMPILE; } - CACHE_STACK_INFO(); - if (result == TCL_OK) { -#ifndef TCL_COMPILE_DEBUG - if (*pc == INST_POP) { - NEXT_INST_V(1, cleanup, 0); - } -#endif - /* - * Push the call's object result and continue execution with the - * next instruction. - */ - - TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=", - objc, cmdNameBuf), Tcl_GetObjResult(interp)); - - objResultPtr = Tcl_GetObjResult(interp); - - /* - * Reset the interp's result to avoid possible duplications of - * large objects [Bug 781585]. We do not call Tcl_ResetResult to - * avoid any side effects caused by the resetting of errorInfo and - * errorCode [Bug 804681], which are not needed here. We chose - * instead to manipulate the interp's object result directly. - * - * Note that the result object is now in objResultPtr, it keeps - * the refCount it had in its role of iPtr->objResultPtr. - */ - - TclNewObj(objPtr); - Tcl_IncrRefCount(objPtr); - iPtr->objResultPtr = objPtr; - NEXT_INST_V(0, cleanup, -1); + 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 @@ -2321,7 +2385,7 @@ TEBCresume( goto instLoadScalar1; } else if (inst == INST_PUSH1) { PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]); - TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), OBJ_AT_TOS); + TRACE_WITH_OBJ(("%u => ", TclGetUInt1AtPtr(pc+1)), OBJ_AT_TOS); inst = *(pc += 2); goto peepholeStart; } else if (inst == INST_START_CMD) { @@ -2332,13 +2396,22 @@ TEBCresume( iPtr->cmdCount += TclGetUInt4AtPtr(pc+5); if (checkInterp) { checkInterp = 0; - if ((codePtr->compileEpoch != iPtr->compileEpoch) - || (codePtr->nsEpoch != iPtr->varFramePtr->nsPtr->resolverEpoch)) { + if (((codePtr->compileEpoch != iPtr->compileEpoch) || + (codePtr->nsEpoch != iPtr->varFramePtr->nsPtr->resolverEpoch)) && + !(codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { goto instStartCmdFailed; } } inst = *(pc += 9); goto peepholeStart; + } else if (inst == INST_NOP) { +#ifndef TCL_COMPILE_DEBUG + while (inst == INST_NOP) +#endif + { + inst = *++pc; + } + goto peepholeStart; } switch (inst) { @@ -2354,7 +2427,7 @@ TEBCresume( TRACE(("%u %u => ", code, level)); result = TclProcessReturn(interp, code, level, OBJ_AT_TOS); if (result == TCL_OK) { - TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")", + TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")\n", O2S(objResultPtr))); NEXT_INST_F(9, 1, 0); } @@ -2363,6 +2436,7 @@ TEBCresume( iPtr->flags &= ~ERR_ALREADY_LOGGED; } cleanup = 2; + TRACE_APPEND(("\n")); goto processExceptionReturn; } @@ -2370,36 +2444,119 @@ TEBCresume( TRACE(("=> ")); objResultPtr = POP_OBJECT(); result = Tcl_SetReturnOptions(interp, OBJ_AT_TOS); - Tcl_DecrRefCount(OBJ_AT_TOS); - OBJ_AT_TOS = objResultPtr; if (result == TCL_OK) { - TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")", + Tcl_DecrRefCount(OBJ_AT_TOS); + OBJ_AT_TOS = objResultPtr; + TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")\n", O2S(objResultPtr))); NEXT_INST_F(1, 0, 0); + } else if (result == TCL_ERROR) { + /* + * BEWARE! Must do this in this order, because an error in the + * option dictionary overrides the result (and can be verified by + * test). + */ + + Tcl_SetObjResult(interp, objResultPtr); + Tcl_SetReturnOptions(interp, OBJ_AT_TOS); + Tcl_DecrRefCount(OBJ_AT_TOS); + OBJ_AT_TOS = objResultPtr; + } else { + Tcl_DecrRefCount(OBJ_AT_TOS); + OBJ_AT_TOS = objResultPtr; + Tcl_SetObjResult(interp, objResultPtr); } - Tcl_SetObjResult(interp, objResultPtr); cleanup = 1; + TRACE_APPEND(("\n")); goto processExceptionReturn; - case INST_YIELD: { - 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), + Tcl_GetString(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. */ @@ -2408,18 +2565,14 @@ TEBCresume( iPtr->cmdFramePtr = bcFramePtr; if (iPtr->flags & INTERP_DEBUG_FRAME) { - TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, - codePtr, bcFramePtr, 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; } @@ -2432,11 +2585,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; @@ -2502,9 +2658,6 @@ TEBCresume( TclDecrRefCount(objPtr); NEXT_INST_F(1, 0, 0); - case INST_NOP: - NEXT_INST_F(1, 0, 0); - case INST_DUP: objResultPtr = OBJ_AT_TOS; TRACE_WITH_OBJ(("=> "), objResultPtr); @@ -2513,7 +2666,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: { @@ -2528,10 +2681,11 @@ TEBCresume( *b = tmpPtr; a++; b--; } + TRACE(("%u => OK\n", opnd)); NEXT_INST_F(5, 0, 0); } - case INST_CONCAT1: { + case INST_STR_CONCAT1: { int appendLen = 0; char *bytes, *p; Tcl_Obj **currPtr; @@ -2611,7 +2765,7 @@ TEBCresume( Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } -#if !TCL_COMPILE_DEBUG +#ifndef TCL_COMPILE_DEBUG if (bytes != tclEmptyStringRep && !Tcl_IsShared(objResultPtr)) { TclFreeIntRep(objResultPtr); objResultPtr->bytes = ckrealloc(bytes, length+appendLen+1); @@ -2647,7 +2801,7 @@ TEBCresume( Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } -#if !TCL_COMPILE_DEBUG +#ifndef TCL_COMPILE_DEBUG if (!Tcl_IsShared(objResultPtr)) { bytes = (char *) Tcl_SetByteArrayLength(objResultPtr, length + appendLen); @@ -2680,6 +2834,17 @@ TEBCresume( NEXT_INST_V(2, opnd, 1); } + case INST_CONCAT_STK: + /* + * Pop the opnd (objc) top stack elements, run through Tcl_ConcatObj, + * and then decrement their ref counts. + */ + + opnd = TclGetUInt4AtPtr(pc+1); + objResultPtr = Tcl_ConcatObj(opnd, &OBJ_AT_DEPTH(opnd-1)); + TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); + NEXT_INST_V(5, opnd, 1); + case INST_EXPAND_START: /* * Push an element to the auxObjList. This records the current @@ -2696,9 +2861,28 @@ TEBCresume( TclNewObj(objPtr); objPtr->internalRep.ptrAndLongRep.value = 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: + /* + * Drops an element of the auxObjList, popping stack elements to + * restore the stack to the state before the point where the aux + * element was created. + */ + + CLANG_ASSERT(auxObjList); + objc = CURR_DEPTH - auxObjList->internalRep.ptrAndLongRep.value; + POP_TAUX_OBJ(); +#ifdef TCL_COMPILE_DEBUG + /* Ugly abuse! */ + starting = 1; +#endif + TRACE(("=> drop %d items\n", objc)); + NEXT_INST_V(1, objc, 0); + case INST_EXPAND_STKTOP: { int i; ptrdiff_t moved; @@ -2710,9 +2894,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(); @@ -2724,22 +2908,27 @@ TEBCresume( * stack depth, as seen by the compiler. */ - length = objc + (codePtr->maxStackDepth - TclGetInt4AtPtr(pc+1)); - DECACHE_STACK_INFO(); - moved = GrowEvaluationStack(iPtr->execEnvPtr, length, 1) - - (Tcl_Obj **) TD; - if (moved) { - /* - * Change the global data to point to the new stack: move the - * TEBCdataPtr TD, recompute the position of every other - * stack-allocated parameter, update the stack pointers. - */ + auxObjList->length += objc - 1; + if ((objc > 1) && (auxObjList->length > 0)) { + length = auxObjList->length /* Total expansion room we need */ + + codePtr->maxStackDepth /* Beyond the original max */ + - CURR_DEPTH; /* Relative to where we are */ + DECACHE_STACK_INFO(); + moved = GrowEvaluationStack(iPtr->execEnvPtr, length, 1) + - (Tcl_Obj **) TD; + if (moved) { + /* + * Change the global data to point to the new stack: move the + * TEBCdataPtr TD, recompute the position of every other + * stack-allocated parameter, update the stack pointers. + */ - esPtr = iPtr->execEnvPtr->execStackPtr; - TD = (TEBCdata *) (((Tcl_Obj **)TD) + moved); + esPtr = iPtr->execEnvPtr->execStackPtr; + TD = (TEBCdata *) (((Tcl_Obj **)TD) + moved); - catchTop += moved; - tosPtr += moved; + catchTop += moved; + tosPtr += moved; + } } /* @@ -2751,6 +2940,7 @@ TEBCresume( PUSH_OBJECT(objv[i]); } + TRACE_APPEND(("OK\n")); Tcl_DecrRefCount(objPtr); NEXT_INST_F(5, 0, 0); } @@ -2843,8 +3033,7 @@ TEBCresume( iPtr->cmdFramePtr = bcFramePtr; if (iPtr->flags & INTERP_DEBUG_FRAME) { - TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, - codePtr, bcFramePtr, pc - codePtr->codeStart); + ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv); } DECACHE_STACK_INFO(); @@ -2852,7 +3041,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: @@ -2989,8 +3178,7 @@ TEBCresume( bcFramePtr->data.tebc.pc = (char *) pc; iPtr->cmdFramePtr = bcFramePtr; if (iPtr->flags & INTERP_DEBUG_FRAME) { - TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, - codePtr, bcFramePtr, pc - codePtr->codeStart); + ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv); } iPtr->ensembleRewrite.sourceObjs = objv; iPtr->ensembleRewrite.numRemovedObjs = opnd; @@ -3089,7 +3277,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; @@ -3115,7 +3303,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; } @@ -3142,7 +3330,7 @@ TEBCresume( 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))); @@ -3291,7 +3479,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); @@ -3341,7 +3529,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; @@ -3389,7 +3577,7 @@ TEBCresume( 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 @@ -3415,7 +3603,7 @@ TEBCresume( { Tcl_Obj *incrPtr; -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG Tcl_WideInt w; #endif long increment; @@ -3464,9 +3652,11 @@ TEBCresume( varPtr = TclObjLookupVarEx(interp, objPtr, part2Ptr, TCL_LEAVE_ERR_MSG, "read", 1, 1, &arrayPtr); if (!varPtr) { - Tcl_AddObjErrorInfo(interp, - "\n (reading value of variable to increment)", -1); - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + DECACHE_STACK_INFO(); + Tcl_AddErrorInfo(interp, + "\n (reading value of variable to increment)"); + CACHE_STACK_INFO(); + TRACE_ERROR(interp); Tcl_DecrRefCount(incrPtr); goto gotError; } @@ -3492,7 +3682,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; } @@ -3537,7 +3727,7 @@ TEBCresume( } goto doneIncr; } -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG w = (Tcl_WideInt)augend; TRACE(("%u %ld => ", opnd, increment)); @@ -3559,7 +3749,7 @@ TEBCresume( goto doneIncr; #endif } /* end if (type == TCL_NUMBER_LONG) */ -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG if (type == TCL_NUMBER_WIDE) { Tcl_WideInt sum; @@ -3604,8 +3794,7 @@ TEBCresume( TclNewLongObj(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); @@ -3627,7 +3816,7 @@ TEBCresume( arrayPtr = NULL; part1Ptr = part2Ptr = NULL; cleanup = 0; - TRACE(("%u %ld => ", opnd, increment)); + TRACE(("%u %s => ", opnd, Tcl_GetString(incrPtr))); doIncrVar: if (TclIsVarDirectModifyable2(varPtr, arrayPtr)) { @@ -3642,8 +3831,7 @@ 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); @@ -3654,8 +3842,7 @@ TEBCresume( CACHE_STACK_INFO(); Tcl_DecrRefCount(incrPtr); if (objResultPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } } @@ -3676,6 +3863,8 @@ TEBCresume( */ case INST_EXIST_SCALAR: + cleanup = 0; + pcAdjustment = 5; opnd = TclGetUInt4AtPtr(pc+1); varPtr = LOCAL(opnd); while (TclIsVarLink(varPtr)) { @@ -3692,16 +3881,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); @@ -3712,7 +3896,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", @@ -3729,13 +3913,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))); @@ -3743,6 +3925,7 @@ TEBCresume( case INST_EXIST_STK: cleanup = 1; + pcAdjustment = 1; part2Ptr = NULL; part1Ptr = OBJ_AT_TOS; /* variable name */ TRACE(("\"%.30s\" => ", O2S(part1Ptr))); @@ -3762,9 +3945,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. @@ -3782,7 +3973,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 @@ -3795,6 +3986,7 @@ TEBCresume( goto slowUnsetScalar; } varPtr->value.objPtr = NULL; + TRACE_APPEND(("OK\n")); NEXT_INST_F(6, 0, 0); } @@ -3815,7 +4007,7 @@ 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)) { varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); @@ -3831,12 +4023,14 @@ TEBCresume( 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); } } @@ -3860,7 +4054,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; @@ -3869,7 +4063,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(); @@ -3878,11 +4073,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; /* @@ -3891,7 +4087,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; @@ -3944,8 +4140,7 @@ TEBCresume( TCL_GLOBAL_ONLY|TCL_TRACE_ARRAY), 1, opnd); CACHE_STACK_INFO(); if (result == TCL_ERROR) { - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } } @@ -3978,7 +4173,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: @@ -3990,9 +4185,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); @@ -4020,9 +4216,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; } @@ -4037,13 +4235,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; } @@ -4058,16 +4259,18 @@ TEBCresume( /*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; } @@ -4085,7 +4288,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))) { @@ -4097,6 +4300,7 @@ TEBCresume( Var *linkPtr = varPtr->value.linkPtr; if (linkPtr == otherPtr) { + TRACE_APPEND(("already linked\n")); NEXT_INST_F(5, 1, 0); } if (TclIsVarInHash(linkPtr)) { @@ -4113,6 +4317,7 @@ TEBCresume( } } else if (TclPtrObjMakeUpvar(interp, otherPtr, NULL, 0, opnd) != TCL_OK) { + TRACE_ERROR(interp); goto gotError; } @@ -4121,6 +4326,7 @@ TEBCresume( * variables - and [variable] did not push it at all. */ + TRACE_APPEND(("link made\n")); NEXT_INST_F(5, 1, 0); } @@ -4167,32 +4373,30 @@ 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), - (unsigned)(pc + jmpOffset[1] - codePtr->codeStart))); + TRACE_APPEND(("%.20s false, new pc %u\n", O2S(valuePtr), + (unsigned)(pc + jmpOffset[0] - codePtr->codeStart))); } } #endif @@ -4210,7 +4414,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)); @@ -4305,13 +4509,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; } @@ -4320,38 +4522,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; @@ -4363,9 +4603,212 @@ 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(); + + 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); @@ -4399,6 +4842,7 @@ TEBCresume( } /* + * End of TclOO support instructions. * ----------------------------------------------------------------- * Start of INST_LIST and related instructions. */ @@ -4420,19 +4864,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. @@ -4450,8 +4894,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; } @@ -4459,8 +4902,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 @@ -4472,6 +4914,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 @@ -4479,8 +4922,7 @@ 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; } @@ -4503,8 +4945,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 */ @@ -4519,10 +4960,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; } @@ -4530,7 +4972,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: @@ -4540,6 +4982,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 @@ -4558,7 +5001,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; } @@ -4566,7 +5009,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 */ @@ -4586,6 +5029,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. @@ -4593,8 +5038,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; } @@ -4602,7 +5046,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 @@ -4615,6 +5059,8 @@ 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 @@ -4622,8 +5068,7 @@ TEBCresume( */ if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { - TRACE_WITH_OBJ(("\"%.30s\" %d %d => ERROR: ", O2S(valuePtr), - fromIdx, toIdx), Tcl_GetObjResult(interp)); + TRACE_ERROR(interp); goto gotError; } @@ -4680,9 +5125,7 @@ TEBCresume( List *listPtr = valuePtr->internalRep.twoPtrValue.ptr1; if (listPtr->refCount == 1) { - TRACE(("\"%.30s\" %d %d => ", O2S(valuePtr), - TclGetInt4AtPtr(pc+1), TclGetInt4AtPtr(pc+5))); - for (index=toIdx+1 ; index<objc-1 ; index++) { + for (index=toIdx+1; index<objc ; index++) { TclDecrRefCount(objv[index]); } listPtr->elemCount = toIdx+1; @@ -4697,8 +5140,7 @@ TEBCresume( 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: @@ -4707,9 +5149,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; @@ -4740,7 +5182,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. @@ -4748,21 +5190,30 @@ 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); + JUMP_PEEPHOLE_F(match, 1, 2); + + case INST_LIST_CONCAT: + value2Ptr = OBJ_AT_TOS; + valuePtr = OBJ_UNDER_TOS; + TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_DuplicateObj(valuePtr); + if (Tcl_ListObjAppendList(interp, objResultPtr, + value2Ptr) != TCL_OK) { + TRACE_ERROR(interp); + TclDecrRefCount(objResultPtr); + goto gotError; + } + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); + NEXT_INST_F(1, 2, 1); + } else { + if (Tcl_ListObjAppendList(interp, valuePtr, value2Ptr) != TCL_OK){ + TRACE_ERROR(interp); + goto gotError; + } + TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); + NEXT_INST_F(1, 1, 0); } -#endif - objResultPtr = TCONST(match); - NEXT_INST_F(0, 2, 1); /* * End of INST_LIST and related instructions. @@ -4892,25 +5343,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. @@ -4918,6 +5418,7 @@ TEBCresume( length = Tcl_GetCharLength(valuePtr); if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) { + TRACE_ERROR(interp); goto gotError; } @@ -4943,18 +5444,18 @@ TEBCresume( 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; } @@ -5014,33 +5515,216 @@ TEBCresume( int length3; Tcl_Obj *value3Ptr; + case INST_STR_REPLACE: + value3Ptr = POP_OBJECT(); + valuePtr = OBJ_AT_DEPTH(2); + length = Tcl_GetCharLength(valuePtr) - 1; + TRACE(("\"%.20s\" %s %s \"%.20s\" => ", O2S(valuePtr), + O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(value3Ptr))); + if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length, + &fromIdx) != TCL_OK + || TclGetIntForIndexM(interp, OBJ_AT_TOS, length, + &toIdx) != TCL_OK) { + TclDecrRefCount(value3Ptr); + TRACE_ERROR(interp); + goto gotError; + } + TclDecrRefCount(OBJ_AT_TOS); + (void) POP_OBJECT(); + TclDecrRefCount(OBJ_AT_TOS); + (void) POP_OBJECT(); + if (fromIdx < 0) { + fromIdx = 0; + } + + if (fromIdx > toIdx || fromIdx > length) { + TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); + TclDecrRefCount(value3Ptr); + NEXT_INST_F(1, 0, 0); + } + + if (toIdx > length) { + toIdx = length; + } + + if (fromIdx == 0 && toIdx == length) { + TclDecrRefCount(OBJ_AT_TOS); + OBJ_AT_TOS = value3Ptr; + TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr))); + NEXT_INST_F(1, 0, 0); + } + + length3 = Tcl_GetCharLength(value3Ptr); + + /* + * Remove substring. In-place. + */ + + if (length3 == 0 && !Tcl_IsShared(valuePtr) && toIdx == length) { + TclDecrRefCount(value3Ptr); + Tcl_SetObjLength(valuePtr, fromIdx); + TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); + NEXT_INST_F(1, 0, 0); + } + + /* + * See if we can splice in place. This happens when the number of + * characters being replaced is the same as the number of characters + * in the string to be inserted. + */ + + if (length3 - 1 == toIdx - fromIdx) { + unsigned char *bytes1, *bytes2; + + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_DuplicateObj(valuePtr); + if (TclIsPureByteArray(objResultPtr) + && TclIsPureByteArray(value3Ptr)) { + bytes1 = Tcl_GetByteArrayFromObj(objResultPtr, NULL); + bytes2 = Tcl_GetByteArrayFromObj(value3Ptr, NULL); + memcpy(bytes1 + fromIdx, bytes2, length3); + } else { + ustring1 = Tcl_GetUnicodeFromObj(objResultPtr, NULL); + ustring2 = Tcl_GetUnicodeFromObj(value3Ptr, NULL); + memcpy(ustring1 + fromIdx, ustring2, + length3 * sizeof(Tcl_UniChar)); + + /* + * Magic! Flush the info in the string internal rep that + * refers to the about-to-be-invalidated UTF-8 rep. This + * sets the 'allocated' field of the String structure to 0 + * to indicate that a new buffer needs to be allocated. + * This is safe; we know we've got a tclStringTypePtr set + * at this point (post Tcl_GetUnicodeFromObj). + */ + + ((int *) objResultPtr->internalRep.otherValuePtr)[1] = 0; + } + Tcl_InvalidateStringRep(objResultPtr); + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); + NEXT_INST_F(1, 1, 1); + } else { + if (TclIsPureByteArray(valuePtr) + && TclIsPureByteArray(value3Ptr)) { + bytes1 = Tcl_GetByteArrayFromObj(valuePtr, NULL); + bytes2 = Tcl_GetByteArrayFromObj(value3Ptr, NULL); + memcpy(bytes1 + fromIdx, bytes2, length3); + } else { + ustring1 = Tcl_GetUnicodeFromObj(valuePtr, NULL); + ustring2 = Tcl_GetUnicodeFromObj(value3Ptr, NULL); + memcpy(ustring1 + fromIdx, ustring2, + length3 * sizeof(Tcl_UniChar)); + + /* + * Magic! Flush the info in the string internal rep that + * refers to the about-to-be-invalidated UTF-8 rep. This + * sets the 'allocated' field of the String structure to 0 + * to indicate that a new buffer needs to be allocated. + * This is safe; we know we've got a tclStringTypePtr set + * at this point (post Tcl_GetUnicodeFromObj). + */ + + ((int *) objResultPtr->internalRep.otherValuePtr)[1] = 0; + } + Tcl_InvalidateStringRep(valuePtr); + TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); + NEXT_INST_F(1, 0, 0); + } + } + + /* + * Get the unicode representation; this is where we guarantee to lose + * bytearrays. + */ + + ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length); + length--; + + /* + * Remove substring using copying. + */ + + if (length3 == 0) { + if (fromIdx > 0) { + objResultPtr = Tcl_NewUnicodeObj(ustring1, fromIdx); + if (toIdx < length) { + Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1, + length - toIdx); + } + } else { + objResultPtr = Tcl_NewUnicodeObj(ustring1 + toIdx + 1, + length - toIdx); + } + TclDecrRefCount(value3Ptr); + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); + NEXT_INST_F(1, 1, 1); + } + + /* + * Splice string pieces by full copying. + */ + + if (fromIdx > 0) { + objResultPtr = Tcl_NewUnicodeObj(ustring1, fromIdx); + Tcl_AppendObjToObj(objResultPtr, value3Ptr); + if (toIdx < length) { + Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1, + length - toIdx); + } + } else if (Tcl_IsShared(value3Ptr)) { + objResultPtr = Tcl_DuplicateObj(value3Ptr); + if (toIdx < length) { + Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1, + length - toIdx); + } + } else { + /* + * Be careful with splicing the stack in this case; we have a + * refCount:1 object in value3Ptr and we want to append to it and + * make it be the refCount:1 object at the top of the stack + * afterwards. [Bug 82e7f67325] + */ + + if (toIdx < length) { + Tcl_AppendUnicodeToObj(value3Ptr, ustring1 + toIdx + 1, + length - toIdx); + } + TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr))); + TclDecrRefCount(valuePtr); + OBJ_AT_TOS = value3Ptr; /* Tricky! */ + 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); @@ -5069,6 +5753,7 @@ 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); @@ -5091,7 +5776,6 @@ TEBCresume( TRACE(("%.20s %.20s => %d\n", O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match)); - TclNewIntObj(objResultPtr, match); NEXT_INST_F(1, 2, 1); @@ -5115,6 +5799,25 @@ TEBCresume( 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: @@ -5157,26 +5860,77 @@ 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 = TclTrimLeft(string1, length, string2, length2); + if (trim1 < length) { + trim2 = TclTrimRight(string1, length, string2, length2); + } else { + trim2 = 0; + } + 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. @@ -5187,44 +5941,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); } /* @@ -5238,6 +5972,39 @@ TEBCresume( int type1, type2; long l1, l2, lResult; + case INST_NUM_TYPE: + if (GetNumberFromObj(NULL, OBJ_AT_TOS, &ptr1, &type1) != TCL_OK) { + type1 = 0; + } else if (type1 == TCL_NUMBER_LONG) { + /* value is between LONG_MIN and LONG_MAX */ + /* [string is integer] is -UINT_MAX to UINT_MAX range */ + int i; + + if (Tcl_GetIntFromObj(NULL, OBJ_AT_TOS, &i) != TCL_OK) { + type1 = TCL_NUMBER_WIDE; + } +#ifndef TCL_WIDE_INT_IS_LONG + } else if (type1 == TCL_NUMBER_WIDE) { + /* value is between WIDE_MIN and WIDE_MAX */ + /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */ + int i; + if (Tcl_GetIntFromObj(NULL, OBJ_AT_TOS, &i) == TCL_OK) { + type1 = TCL_NUMBER_LONG; + } +#endif + } else if (type1 == TCL_NUMBER_BIG) { + /* value is an integer outside the WIDE_MIN to WIDE_MAX range */ + /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */ + Tcl_WideInt w; + + if (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: case INST_LT: @@ -5322,21 +6089,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: @@ -5423,13 +6178,13 @@ TEBCresume( if (l2 < 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) { TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); @@ -5471,13 +6226,13 @@ TEBCresume( if (l2 < 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) { TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); @@ -5494,12 +6249,12 @@ 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; @@ -5557,8 +6312,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))); @@ -5635,7 +6389,7 @@ TEBCresume( w1 = (Tcl_WideInt) l1; w2 = (Tcl_WideInt) l2; wResult = w1 + w2; -#ifdef NO_WIDE_TYPE +#ifdef TCL_WIDE_INT_IS_LONG /* * Check for overflow. */ @@ -5650,7 +6404,7 @@ TEBCresume( w1 = (Tcl_WideInt) l1; w2 = (Tcl_WideInt) l2; wResult = w1 - w2; -#ifdef NO_WIDE_TYPE +#ifdef TCL_WIDE_INT_IS_LONG /* * Must check for overflow. The macro tests for overflows in * sums by looking at the sign bits. As we have a subtraction @@ -5730,8 +6484,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))); @@ -5749,7 +6502,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); @@ -5758,18 +6511,20 @@ 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); @@ -5780,23 +6535,28 @@ TEBCresume( l1 = *((const long *) ptr1); if (Tcl_IsShared(valuePtr)) { TclNewLongObj(objResultPtr, ~l1); + TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } TclSetLongObj(valuePtr, ~l1); + 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); @@ -5806,23 +6566,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) { if (Tcl_IsShared(valuePtr)) { TclNewLongObj(objResultPtr, -l1); + TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } TclSetLongObj(valuePtr, -l1); + 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); } @@ -5835,6 +6600,7 @@ TEBCresume( */ valuePtr = OBJ_AT_TOS; + TRACE(("\"%.20s\" => ", O2S(valuePtr))); if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) { if (*pc == INST_UPLUS) { @@ -5842,7 +6608,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); @@ -5851,7 +6617,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)) { @@ -5860,7 +6626,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); @@ -5870,8 +6636,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(); @@ -5889,7 +6654,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)) { @@ -5904,11 +6669,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); } @@ -5917,6 +6682,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(); @@ -5925,6 +6701,7 @@ TEBCresume( */ result = TCL_BREAK; cleanup = 0; + TRACE(("=> BREAK!\n")); goto processExceptionReturn; case INST_CONTINUE: @@ -5935,6 +6712,7 @@ TEBCresume( */ result = TCL_CONTINUE; cleanup = 0; + TRACE(("=> CONTINUE!\n")); goto processExceptionReturn; { @@ -5946,7 +6724,7 @@ TEBCresume( int varIndex, valIndex, continueLoop, j, iterTmpIndex; long i; - case INST_FOREACH_START4: + case INST_FOREACH_START4: /* DEPRECATED */ /* * Initialize the temporary local var that holds the count of the * number of iterations of the loop body to -1. @@ -5979,13 +6757,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; @@ -6012,8 +6791,8 @@ 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) { @@ -6068,9 +6847,9 @@ TEBCresume( if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){ CACHE_STACK_INFO(); - TRACE_WITH_OBJ(( - "%u => ERROR init. index temp %d: ", - opnd,varIndex), Tcl_GetObjResult(interp)); + TRACE_APPEND(( + "ERROR init. index temp %d: %s\n", + varIndex, O2S(Tcl_GetObjResult(interp)))); TclDecrRefCount(listPtr); goto gotError; } @@ -6082,8 +6861,8 @@ TEBCresume( listTmpIndex++; } } - TRACE(("%u => %d lists, iter %d, %s loop\n", opnd, numLists, - iterNum, (continueLoop? "continue" : "exit"))); + TRACE_APPEND(("%d lists, iter %d, %s loop\n", + numLists, iterNum, (continueLoop? "continue" : "exit"))); /* * Run-time peep-hole optimisation: the compiler ALWAYS follows @@ -6097,6 +6876,200 @@ TEBCresume( } else { NEXT_INST_F((continueLoop? 5 : TclGetInt4AtPtr(pc+1)), 0, 0); } + + } + { + ForeachInfo *infoPtr; + Tcl_Obj *listPtr, **elements, *tmpPtr; + ForeachVarList *varListPtr; + int numLists, iterMax, listLen, numVars; + int iterTmp, iterNum, listTmpDepth; + int varIndex, valIndex, j; + long i; + + case INST_FOREACH_START: + /* + * Initialize the data for the looping construct, pushing the + * corresponding Tcl_Objs to the stack. + */ + + opnd = TclGetUInt4AtPtr(pc+1); + infoPtr = codePtr->auxDataArrayPtr[opnd].clientData; + numLists = infoPtr->numLists; + 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 = INT2PTR(0); + tmpPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(iterMax); + PUSH_OBJECT(tmpPtr); /* iterCounts object */ + + /* + * Store a pointer to the ForeachInfo struct; same dirty trick + * as above + */ + + TclNewObj(tmpPtr); + tmpPtr->internalRep.otherValuePtr = infoPtr; + PUSH_OBJECT(tmpPtr); /* infoPtr object */ + 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.otherValuePtr; + numLists = infoPtr->numLists; + TRACE(("=> ")); + + tmpPtr = OBJ_AT_DEPTH(1); + iterNum = PTR2INT(tmpPtr->internalRep.twoPtrValue.ptr1); + iterMax = PTR2INT(tmpPtr->internalRep.twoPtrValue.ptr2); + + /* + * If some list still has a remaining list element iterate one more + * time. Assign to var the next element from its value list. + */ + + if (iterNum < iterMax) { + /* + * Set the variables and jump back to run the body + */ + + tmpPtr->internalRep.twoPtrValue.ptr1 = INT2PTR(iterNum + 1); + + listTmpDepth = numLists + 1; + + for (i = 0; i < numLists; i++) { + varListPtr = infoPtr->varLists[i]; + numVars = varListPtr->numVars; + + listPtr = OBJ_AT_DEPTH(listTmpDepth); + TclListObjGetElements(interp, listPtr, &listLen, &elements); + + valIndex = (iterNum * numVars); + for (j = 0; j < numVars; j++) { + if (valIndex >= listLen) { + TclNewObj(valuePtr); + } else { + valuePtr = elements[valIndex]; + } + + varIndex = varListPtr->varIndexes[j]; + varPtr = LOCAL(varIndex); + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + if (TclIsVarDirectWritable(varPtr)) { + value2Ptr = varPtr->value.objPtr; + if (valuePtr != value2Ptr) { + if (value2Ptr != NULL) { + TclDecrRefCount(value2Ptr); + } + varPtr->value.objPtr = valuePtr; + Tcl_IncrRefCount(valuePtr); + } + } else { + DECACHE_STACK_INFO(); + if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL, + valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){ + CACHE_STACK_INFO(); + TRACE_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.otherValuePtr; + 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.otherValuePtr; + 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: @@ -6158,7 +7131,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); } /* @@ -6175,10 +7149,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")); @@ -6187,6 +7161,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)); @@ -6199,10 +7174,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; @@ -6211,34 +7187,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: @@ -6312,8 +7294,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; } @@ -6335,8 +7317,7 @@ TEBCresume( CACHE_STACK_INFO(); TclDecrRefCount(dictPtr); if (objResultPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } } @@ -6345,7 +7326,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: @@ -6378,6 +7359,7 @@ TEBCresume( if (allocateDict) { TclDecrRefCount(dictPtr); } + TRACE_ERROR(interp); goto gotError; } @@ -6426,6 +7408,7 @@ TEBCresume( if (allocateDict) { TclDecrRefCount(dictPtr); } + TRACE_ERROR(interp); goto gotError; } Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, valuePtr); @@ -6435,6 +7418,7 @@ TEBCresume( if (allocateDict) { TclDecrRefCount(dictPtr); } + TRACE_ERROR(interp); goto gotError; } @@ -6471,8 +7455,7 @@ TEBCresume( CACHE_STACK_INFO(); TclDecrRefCount(dictPtr); if (objResultPtr == NULL) { - TRACE_APPEND(("ERROR: %.30s\n", - O2S(Tcl_GetObjResult(interp)))); + TRACE_ERROR(interp); goto gotError; } } @@ -6491,7 +7474,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); @@ -6527,8 +7519,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 @@ -6536,37 +7529,17 @@ 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", - 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 => ", opnd)); if (TclIsVarDirectReadable(varPtr)) { dictPtr = varPtr->value.objPtr; } else { @@ -6575,11 +7548,13 @@ TEBCresume( TCL_LEAVE_ERR_MSG, opnd); CACHE_STACK_INFO(); if (dictPtr == NULL) { + TRACE_ERROR(interp); goto gotError; } } if (TclListObjGetElements(interp, OBJ_AT_TOS, &length, &keyPtrPtr) != TCL_OK) { + TRACE_ERROR(interp); goto gotError; } if (length != duiPtr->length) { @@ -6588,6 +7563,7 @@ TEBCresume( for (i=0 ; i<length ; i++) { if (Tcl_DictObjGet(interp, dictPtr, keyPtrPtr[i], &valuePtr) != TCL_OK) { + TRACE_ERROR(interp); goto gotError; } varPtr = LOCAL(duiPtr->varIndices[i]); @@ -6603,21 +7579,23 @@ TEBCresume( valuePtr, TCL_LEAVE_ERR_MSG, duiPtr->varIndices[i]) == NULL) { CACHE_STACK_INFO(); + TRACE_ERROR(interp); goto gotError; } CACHE_STACK_INFO(); } + 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 { @@ -6626,11 +7604,13 @@ TEBCresume( 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); @@ -6676,26 +7656,27 @@ TEBCresume( 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_APPEND(("%.30s\n", O2S(objResultPtr))); + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); case INST_DICT_RECOMBINE_STK: @@ -6705,14 +7686,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; } @@ -6722,7 +7703,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")); @@ -6736,7 +7717,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)) { @@ -6747,7 +7728,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")); @@ -6782,7 +7763,7 @@ TEBCresume( */ processExceptionReturn: -#if TCL_COMPILE_DEBUG +#ifdef TCL_COMPILE_DEBUG switch (*pc) { case INST_INVOKE_STK1: opnd = TclGetUInt1AtPtr(pc+1); @@ -6839,14 +7820,14 @@ TEBCresume( rangePtr->codeOffset, rangePtr->continueOffset)); NEXT_INST_F(0, 0, 0); } -#if TCL_COMPILE_DEBUG +#ifdef TCL_COMPILE_DEBUG if (traceInstructions) { objPtr = Tcl_GetObjResult(interp); if ((result != TCL_ERROR) && (result != TCL_RETURN)) { - 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))); } } @@ -6859,8 +7840,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; @@ -6871,9 +7852,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(); @@ -6901,7 +7882,7 @@ TEBCresume( if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { const unsigned char *pcBeg; - bytes = GetSrcInfoForPc(pc, codePtr, &length, &pcBeg); + bytes = GetSrcInfoForPc(pc, codePtr, &length, &pcBeg, NULL); DECACHE_STACK_INFO(); TclLogCommandInfo(interp, codePtr->source, bytes, bytes ? length : 0, pcBeg, tosPtr); @@ -7083,12 +8064,11 @@ TEBCresume( } codePtr->flags |= TCL_BYTECODE_RECOMPILE; - bytes = GetSrcInfoForPc(pc, codePtr, &length, NULL); + bytes = GetSrcInfoForPc(pc, codePtr, &length, NULL, NULL); opnd = TclGetUInt4AtPtr(pc+1); pc += (opnd-1); PUSH_OBJECT(Tcl_NewStringObj(bytes, length)); goto instEvalStk; - NEXT_INST_F(9, 0, 0); } } @@ -7100,6 +8080,58 @@ TEBCresume( #undef auxObjList #undef catchTop #undef TCONST + +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; +} /* *---------------------------------------------------------------------- @@ -7196,7 +8228,7 @@ ExecuteExtendedBinaryMathOp( return constants[0]; } } -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG if (type1 == TCL_NUMBER_WIDE) { w1 = *((const Tcl_WideInt *)ptr1); if (type2 != TCL_NUMBER_BIG) { @@ -7271,7 +8303,7 @@ ExecuteExtendedBinaryMathOp( case TCL_NUMBER_LONG: invalid = (*((const long *)ptr2) < 0L); break; -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: invalid = (*((const Tcl_WideInt *)ptr2) < (Tcl_WideInt)0); break; @@ -7355,7 +8387,7 @@ ExecuteExtendedBinaryMathOp( case TCL_NUMBER_LONG: zero = (*(const long *)ptr1 > 0L); break; -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: zero = (*(const Tcl_WideInt *)ptr1 > (Tcl_WideInt)0); break; @@ -7376,7 +8408,7 @@ ExecuteExtendedBinaryMathOp( } shift = (int)(*(const long *)ptr2); -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG /* * Handle shifts within the native wide range. */ @@ -7559,7 +8591,7 @@ ExecuteExtendedBinaryMathOp( BIG_RESULT(&bigResult); } -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) { TclGetWideIntFromObj(NULL, valuePtr, &w1); TclGetWideIntFromObj(NULL, value2Ptr, &w2); @@ -7637,7 +8669,7 @@ ExecuteExtendedBinaryMathOp( negativeExponent = (l2 < 0); oddExponent = (int) (l2 & 1); break; -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: w2 = *((const Tcl_WideInt *)ptr2); negativeExponent = (w2 < 0); @@ -7829,7 +8861,7 @@ ExecuteExtendedBinaryMathOp( #if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) if (type1 == TCL_NUMBER_LONG) { w1 = l1; -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG } else if (type1 == TCL_NUMBER_WIDE) { w1 = *((const Tcl_WideInt *) ptr1); #endif @@ -8032,7 +9064,7 @@ ExecuteExtendedBinaryMathOp( switch (opcode) { case INST_ADD: wResult = w1 + w2; -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) #endif { @@ -8048,7 +9080,7 @@ ExecuteExtendedBinaryMathOp( case INST_SUB: wResult = w1 - w2; -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) #endif { @@ -8174,7 +9206,7 @@ ExecuteExtendedUnaryMathOp( switch (opcode) { case INST_BITNOT: -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG if (type == TCL_NUMBER_WIDE) { w = *((const Tcl_WideInt *) ptr); WIDE_RESULT(~w); @@ -8196,7 +9228,7 @@ ExecuteExtendedUnaryMathOp( } TclBNInitBignumFromLong(&big, *(const long *) ptr); break; -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: w = *((const Tcl_WideInt *) ptr); if (w != LLONG_MIN) { @@ -8248,7 +9280,7 @@ TclCompareTwoNumbers( mp_int big1, big2; double d1, d2, tmp; long l1, l2; -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG Tcl_WideInt w1, w2; #endif @@ -8263,7 +9295,7 @@ TclCompareTwoNumbers( l2 = *((const long *)ptr2); longCompare: return (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ); -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: w2 = *((const Tcl_WideInt *)ptr2); w1 = (Tcl_WideInt)l1; @@ -8315,7 +9347,7 @@ TclCompareTwoNumbers( return compare; } -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: w1 = *((const Tcl_WideInt *)ptr1); switch (type2) { @@ -8376,7 +9408,7 @@ TclCompareTwoNumbers( } l1 = (long) d1; goto longCompare; -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: w2 = *((const Tcl_WideInt *)ptr2); d2 = (double) w2; @@ -8420,7 +9452,7 @@ TclCompareTwoNumbers( case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); switch (type2) { -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: #endif case TCL_NUMBER_LONG: @@ -8577,7 +9609,7 @@ ValidatePcAndStackTop( if (checkStack && ((stackTop < 0) || (stackTop > stackUpperBound))) { int numChars; - const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL); + const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL, NULL); fprintf(stderr, "\nBad stack top %d at pc %u in TclNRExecuteByteCode (min 0, max %i)", stackTop, relativePc, stackUpperBound); @@ -8627,10 +9659,12 @@ 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_STR_NEQ) { + operator = operatorStrings[opcode - INST_LOR]; } if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) { @@ -8661,7 +9695,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 @@ -8682,16 +9716,26 @@ IllegalExprOperandType( *---------------------------------------------------------------------- */ -const char * -TclGetSrcInfoForCmd( - Interp *iPtr, - int *lenPtr) +Tcl_Obj * +TclGetSourceFromFrame( + CmdFrame *cfPtr, + int objc, + Tcl_Obj *const objv[]) { - CmdFrame *cfPtr = iPtr->cmdFramePtr; - ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr; - - return GetSrcInfoForPc((unsigned char *) cfPtr->data.tebc.pc, - codePtr, lenPtr, NULL); + if (cfPtr == NULL) { + return Tcl_NewListObj(objc, objv); + } + if (cfPtr->cmdObj == NULL) { + if (cfPtr->cmd == NULL) { + ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr; + + cfPtr->cmd = GetSrcInfoForPc((unsigned char *) + cfPtr->data.tebc.pc, codePtr, &cfPtr->len, NULL, NULL); + } + cfPtr->cmdObj = Tcl_NewStringObj(cfPtr->cmd, cfPtr->len); + Tcl_IncrRefCount(cfPtr->cmdObj); + } + return cfPtr->cmdObj; } void @@ -8700,13 +9744,16 @@ TclGetSrcInfoForPc( { ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr; - if (cfPtr->cmd.str.cmd == NULL) { - cfPtr->cmd.str.cmd = GetSrcInfoForPc( + assert(cfPtr->type == TCL_LOCATION_BC); + + if (cfPtr->cmd == NULL) { + + cfPtr->cmd = GetSrcInfoForPc( (unsigned char *) cfPtr->data.tebc.pc, codePtr, - &cfPtr->cmd.str.len, NULL); + &cfPtr->len, NULL, NULL); } - if (cfPtr->cmd.str.cmd != NULL) { + if (cfPtr->cmd != NULL) { /* * We now have the command. We can get the srcOffset back and from * there find the list of word locations for this command. @@ -8723,7 +9770,7 @@ TclGetSrcInfoForPc( return; } - srcOffset = cfPtr->cmd.str.cmd - codePtr->source; + srcOffset = cfPtr->cmd - codePtr->source; eclPtr = Tcl_GetHashValue(hePtr); for (i=0; i < eclPtr->nuloc; i++) { @@ -8763,9 +9810,12 @@ GetSrcInfoForPc( int *lengthPtr, /* If non-NULL, the location where the length * of the command's source should be stored. * If NULL, no length is stored. */ - const unsigned char **pcBeg)/* If non-NULL, the bytecode location + const unsigned char **pcBeg,/* If non-NULL, the bytecode location * where the current instruction starts. * If NULL; no pointer is stored. */ + int *cmdIdxPtr) /* If non-NULL, the location where the index + * of the command containing the pc should + * be stored. */ { register int pcOffset = (pc - codePtr->codeStart); int numCmds = codePtr->numCommands; @@ -8775,6 +9825,7 @@ GetSrcInfoForPc( int bestDist = INT_MAX; /* Distance of pc to best cmd's start pc. */ int bestSrcOffset = -1; /* Initialized to avoid compiler warning. */ int bestSrcLength = -1; /* Initialized to avoid compiler warning. */ + int bestCmdIdx = -1; if ((pcOffset < 0) || (pcOffset >= codePtr->numCodeBytes)) { if (pcBeg != NULL) *pcBeg = NULL; @@ -8842,6 +9893,7 @@ GetSrcInfoForPc( bestDist = dist; bestSrcOffset = srcOffset; bestSrcLength = srcLen; + bestCmdIdx = i; } } } @@ -8871,6 +9923,10 @@ GetSrcInfoForPc( *lengthPtr = bestSrcLength; } + if (cmdIdxPtr != NULL) { + *cmdIdxPtr = bestCmdIdx; + } + return (codePtr->source + bestSrcOffset); } diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index adf60d9..8bf0a5a 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -10,7 +10,6 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#include <sys/stat.h> #include "tclInt.h" #include "tclFileSystem.h" @@ -518,7 +517,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,17 +734,14 @@ CopyRenameOneFile( */ errfile = target; - - /* - * We now need to reset the result, because the above call, if it - * failed, may have put an error message in place. (Ideally we - * would prefer not to pass an interpreter in above, but the - * channel IO code used by TclCrossFilesystemCopy currently - * requires one). - */ - - Tcl_ResetResult(interp); } + /* + * We now need to reset the result, because the above call, + * may have left set it. (Ideally we would prefer not to pass + * an interpreter in above, but the channel IO code used by + * TclCrossFilesystemCopy currently requires one) + */ + Tcl_ResetResult(interp); } if ((copyFlag == 0) && (result == TCL_OK)) { if (S_ISDIR(sourceStatBuf.st_mode)) { @@ -1200,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 193ca4e..5d4702b 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -11,7 +11,6 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#include <sys/stat.h> #include "tclInt.h" #include "tclRegexp.h" #include "tclFileSystem.h" /* For TclGetPathType() */ diff --git a/generic/tclGet.c b/generic/tclGet.c index 4c19b55..97e8c7b 100644 --- a/generic/tclGet.c +++ b/generic/tclGet.c @@ -137,7 +137,7 @@ Tcl_GetBoolean( obj.length = strlen(src); obj.typePtr = NULL; - code = Tcl_ConvertToType(interp, &obj, &tclBooleanType); + code = TclSetBooleanFromAny(interp, &obj); if (obj.refCount > 1) { Tcl_Panic("invalid sharing of Tcl_Obj on C stack"); } diff --git a/generic/tclIO.c b/generic/tclIO.c index 715c1ef..d7ed3ac 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. @@ -16,6 +17,108 @@ #include <assert.h> /* + * For each channel handler registered in a call to Tcl_CreateChannelHandler, + * there is one record of the following type. All of records for a specific + * channel are chained together in a singly linked list which is stored in + * the channel structure. + */ + +typedef struct ChannelHandler { + Channel *chanPtr; /* The channel structure for this channel. */ + int mask; /* Mask of desired events. */ + Tcl_ChannelProc *proc; /* Procedure to call in the type of + * Tcl_CreateChannelHandler. */ + ClientData clientData; /* Argument to pass to procedure. */ + struct ChannelHandler *nextPtr; + /* Next one in list of registered handlers. */ +} ChannelHandler; + +/* + * This structure keeps track of the current ChannelHandler being invoked in + * the current invocation of ChannelHandlerEventProc. There is a potential + * problem if a ChannelHandler is deleted while it is the current one, since + * ChannelHandlerEventProc needs to look at the nextPtr field. To handle this + * problem, structures of the type below indicate the next handler to be + * processed for any (recursively nested) dispatches in progress. The + * nextHandlerPtr field is updated if the handler being pointed to is deleted. + * The nextPtr field is used to chain together all recursive invocations, so + * that Tcl_DeleteChannelHandler can find all the recursively nested + * invocations of ChannelHandlerEventProc and compare the handler being + * deleted against the NEXT handler to be invoked in that invocation; when it + * finds such a situation, Tcl_DeleteChannelHandler updates the nextHandlerPtr + * field of the structure to the next handler. + */ + +typedef struct NextChannelHandler { + ChannelHandler *nextHandlerPtr; /* The next handler to be invoked in + * this invocation. */ + struct NextChannelHandler *nestedHandlerPtr; + /* Next nested invocation of + * ChannelHandlerEventProc. */ +} NextChannelHandler; + +/* + * The following structure describes the event that is added to the Tcl + * event queue by the channel handler check procedure. + */ + +typedef struct ChannelHandlerEvent { + Tcl_Event header; /* Standard header for all events. */ + Channel *chanPtr; /* The channel that is ready. */ + int readyMask; /* Events that have occurred. */ +} ChannelHandlerEvent; + +/* + * The following structure is used by Tcl_GetsObj() to encapsulates the + * state for a "gets" operation. + */ + +typedef struct GetsState { + Tcl_Obj *objPtr; /* The object to which UTF-8 characters + * will be appended. */ + char **dstPtr; /* Pointer into objPtr's string rep where + * next character should be stored. */ + Tcl_Encoding encoding; /* The encoding to use to convert raw bytes + * to UTF-8. */ + ChannelBuffer *bufPtr; /* The current buffer of raw bytes being + * emptied. */ + Tcl_EncodingState state; /* The encoding state just before the last + * external to UTF-8 conversion in + * FilterInputBytes(). */ + int rawRead; /* The number of bytes removed from bufPtr + * in the last call to FilterInputBytes(). */ + int bytesWrote; /* The number of bytes of UTF-8 data + * appended to objPtr during the last call to + * FilterInputBytes(). */ + int charsWrote; /* The corresponding number of UTF-8 + * characters appended to objPtr during the + * last call to FilterInputBytes(). */ + int totalChars; /* The total number of UTF-8 characters + * appended to objPtr so far, just before the + * last call to FilterInputBytes(). */ +} GetsState; + +/* + * The following structure encapsulates the state for a background channel + * copy. Note that the data buffer for the copy will be appended to this + * structure. + */ + +typedef struct CopyState { + struct Channel *readPtr; /* Pointer to input channel. */ + struct Channel *writePtr; /* Pointer to output channel. */ + int readFlags; /* Original read channel flags. */ + int writeFlags; /* Original write channel flags. */ + Tcl_WideInt toRead; /* Number of bytes to copy, or -1. */ + Tcl_WideInt total; /* Total bytes transferred (written). */ + Tcl_Interp *interp; /* Interp that started the copy. */ + Tcl_Obj *cmdPtr; /* Command to be invoked at completion. */ + int bufSize; /* Size of appended buffer. */ + char buffer[1]; /* Copy buffer, this must be the last + * field. */ +} CopyState; + +/* * All static variables used in this file are collected into a single instance * of the following structure. For multi-threaded implementations, there is * one instance of this structure for each thread. @@ -44,15 +147,29 @@ typedef struct ThreadSpecificData { static Tcl_ThreadDataKey dataKey; /* + * Structure to record a close callback. One such record exists for + * each close callback registered for a channel. + */ + +typedef struct CloseCallback { + Tcl_CloseProc *proc; /* The procedure to call. */ + ClientData clientData; /* Arbitrary one-word data to pass + * to the callback. */ + struct CloseCallback *nextPtr; /* For chaining close callbacks. */ +} CloseCallback; + +/* * Static functions in this file: */ static ChannelBuffer * AllocChannelBuffer(int length); +static void PreserveChannelBuffer(ChannelBuffer *bufPtr); +static void ReleaseChannelBuffer(ChannelBuffer *bufPtr); +static int IsShared(ChannelBuffer *bufPtr); 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); @@ -64,9 +181,6 @@ 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 void CopyEventProc(ClientData clientData, int mask); static void CreateScriptRecord(Tcl_Interp *interp, @@ -79,16 +193,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); @@ -97,29 +211,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 @@ -172,7 +287,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) @@ -209,23 +324,22 @@ static int WillRead(Channel *chanPtr); 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, /* updateStringProc */ NULL /* setFromAnyProc SetChannelFromAny */ }; #define GET_CHANNELSTATE(objPtr) \ - ((ChannelState *) (objPtr)->internalRep.otherValuePtr) + ((ChannelState *) (objPtr)->internalRep.twoPtrValue.ptr1) #define SET_CHANNELSTATE(objPtr, storePtr) \ - ((objPtr)->internalRep.otherValuePtr = (void *) (storePtr)) + ((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (storePtr)) #define GET_CHANNELINTERP(objPtr) \ - ((Interp *) (objPtr)->internalRep.twoPtrValue.ptr2) + ((Tcl_Interp *) (objPtr)->internalRep.twoPtrValue.ptr2) #define SET_CHANNELINTERP(objPtr, storePtr) \ ((objPtr)->internalRep.twoPtrValue.ptr2 = (void *) (storePtr)) @@ -268,19 +382,79 @@ 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. + */ + ResetFlag(chanPtr->state, CHANNEL_BLOCKED | CHANNEL_EOF); 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 */ + ResetFlag(chanPtr->state, CHANNEL_BLOCKED | CHANNEL_EOF); + 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 @@ -695,6 +869,8 @@ Tcl_DeleteCloseHandler( if ((cbPtr->proc == proc) && (cbPtr->clientData == clientData)) { if (cbPrevPtr == NULL) { statePtr->closeCbPtr = cbPtr->nextPtr; + } else { + cbPrevPtr->nextPtr = cbPtr->nextPtr; } ckfree(cbPtr); break; @@ -1061,15 +1237,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)) { /* @@ -1465,11 +1632,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. @@ -1634,6 +1797,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; @@ -1665,17 +1832,17 @@ 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; @@ -1763,6 +1930,13 @@ Tcl_UnstackChannel( * 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; /* @@ -1867,7 +2041,7 @@ Tcl_UnstackChannel( */ Tcl_EventuallyFree(chanPtr, TCL_DYNAMIC); - UpdateInterest(downChanPtr); + UpdateInterest(statePtr->topChanPtr); if (result != 0) { Tcl_SetErrno(result); @@ -2179,8 +2353,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; +} /* *---------------------------------------------------------------------- @@ -2211,20 +2413,23 @@ 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 + * 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; } @@ -2259,7 +2464,7 @@ RecycleBuffer( * If we reached this code we return the buffer to the OS. */ - ckfree(bufPtr); + ReleaseChannelBuffer(bufPtr); return; keepBuffer: @@ -2297,6 +2502,11 @@ DiscardOutputQueued( } statePtr->outQueueHead = NULL; statePtr->outQueueTail = NULL; + bufPtr = statePtr->curOutPtr; + if (bufPtr && BytesLeft(bufPtr)) { + statePtr->curOutPtr = NULL; + RecycleBuffer(statePtr, bufPtr, 0); + } } /* @@ -2364,8 +2574,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 @@ -2385,63 +2593,58 @@ 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). + * 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))) { + 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. + */ + + Tcl_Preserve(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 @@ -2456,6 +2659,7 @@ FlushChannel( if (errorCode == EINTR) { errorCode = 0; + ReleaseChannelBuffer(bufPtr); continue; } @@ -2477,6 +2681,7 @@ FlushChannel( UpdateInterest(chanPtr); } errorCode = 0; + ReleaseChannelBuffer(bufPtr); break; } @@ -2538,14 +2743,15 @@ 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. @@ -2558,7 +2764,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. @@ -2573,6 +2780,19 @@ 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. + */ + + assert(!calledFromAsyncFlush); } } @@ -2659,7 +2879,7 @@ CloseChannel( */ if (statePtr->curOutPtr != NULL) { - ckfree(statePtr->curOutPtr); + ReleaseChannelBuffer(statePtr->curOutPtr); statePtr->curOutPtr = NULL; } @@ -2722,10 +2942,6 @@ CloseChannel( } Tcl_FreeEncoding(statePtr->encoding); - if (statePtr->outputStage != NULL) { - ckfree(statePtr->outputStage); - statePtr->outputStage = NULL; - } } /* @@ -3075,10 +3291,18 @@ 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(); } @@ -3113,14 +3337,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. */ @@ -3165,7 +3381,17 @@ 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; @@ -3278,10 +3504,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)) { /* @@ -3343,14 +3565,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. @@ -3662,7 +3876,7 @@ Tcl_Write( if (srcLen < 0) { srcLen = strlen(src); } - return DoWrite(chanPtr, src, srcLen); + return WriteBytes(chanPtr, src, srcLen); } /* @@ -3753,82 +3967,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; } /* @@ -3904,12 +4076,25 @@ 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; } @@ -3920,110 +4105,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. - * - *---------------------------------------------------------------------- - */ - -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 -- + * Write -- * - * 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. @@ -4040,381 +4124,164 @@ 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. - */ - - while (stageLen + saved + endEncoding > 0) { - bufPtr = statePtr->curOutPtr; - if (bufPtr == NULL) { - bufPtr = AllocChannelBuffer(statePtr->bufSize); - statePtr->curOutPtr = 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. - */ - - memcpy(dst, safe, (size_t) saved); - bufPtr->nextAdded += saved; - dst += saved; - dstLen -= saved; - saved = 0; - } - - result = Tcl_UtfToExternal(NULL, encoding, stage, stageLen, - statePtr->outputEncodingFlags, - &statePtr->outputEncodingState, dst, - dstLen + BUFFER_PADDING, &stageRead, &dstWrote, NULL); - + if (saved) { /* - * 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. + * Here's some translated bytes left over from the last buffer + * that we need to stick at the beginning of this buffer. */ - statePtr->outputEncodingFlags &= ~TCL_ENCODING_START; + memcpy(InsertPoint(bufPtr), safe, (size_t) saved); + bufPtr->nextAdded += saved; + saved = 0; + } + PreserveChannelBuffer(bufPtr); + dst = InsertPoint(bufPtr); + dstLen = SpaceLeft(bufPtr); + + result = Tcl_UtfToExternal(NULL, encoding, src, srcLimit, + statePtr->outputEncodingFlags, + &statePtr->outputEncodingState, dst, + dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL); + + /* See chan-io-1.[89]. Tcl Bug 506297. */ + statePtr->outputEncodingFlags &= ~TCL_ENCODING_START; + + if ((result != TCL_OK) && (srcRead + dstWrote == 0)) { + /* We're reading from invalid/incomplete UTF-8 */ + 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. - */ + + result |= Tcl_UtfToExternal(NULL, encoding, nl, nlLen, + statePtr->outputEncodingFlags, + &statePtr->outputEncodingState, dst, + dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL); - saved = -SpaceLeft(bufPtr); - memcpy(safe, dst + dstLen, (size_t) saved); - bufPtr->nextAdded = bufPtr->bufLength; - } - if (CheckFlush(chanPtr, bufPtr, sawLF) != 0) { - return -1; - } + 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; - } - *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 */ - - /* - * 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. - */ - - 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 (FlushChannel(NULL, chanPtr, 0) != 0) { + ReleaseChannelBuffer(bufPtr); + return -1; + } + flushed += statePtr->bufSize; + if (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; } /* @@ -4496,8 +4363,7 @@ Tcl_GetsObj( Tcl_EncodingState oldState; if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) { - copiedTotal = -1; - goto done; + return -1; } /* @@ -4517,6 +4383,7 @@ Tcl_GetsObj( */ chanPtr = statePtr->topChanPtr; + Tcl_Preserve(chanPtr); bufPtr = statePtr->inQueueHead; encoding = statePtr->encoding; @@ -4540,16 +4407,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(); } /* @@ -4738,6 +4596,7 @@ Tcl_GetsObj( Tcl_SetObjLength(objPtr, oldLength); CommonGetsCleanup(chanPtr); copiedTotal = -1; + ResetFlag(statePtr, CHANNEL_BLOCKED); goto done; } goto gotEOL; @@ -4759,7 +4618,11 @@ Tcl_GetsObj( * self-modifying reflected transforms. */ - chanPtr = statePtr->topChanPtr; + if (chanPtr != statePtr->topChanPtr) { + Tcl_Release(chanPtr); + chanPtr = statePtr->topChanPtr; + Tcl_Preserve(chanPtr); + } bufPtr = gs.bufPtr; if (bufPtr == NULL) { @@ -4793,16 +4656,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) { + Tcl_Release(chanPtr); + chanPtr = statePtr->topChanPtr; + Tcl_Preserve(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); @@ -4835,10 +4700,13 @@ Tcl_GetsObj( * Regenerate the top channel, in case it was changed due to * self-modifying reflected transforms. */ - - chanPtr = statePtr->topChanPtr; - + if (chanPtr != statePtr->topChanPtr) { + Tcl_Release(chanPtr); + chanPtr = statePtr->topChanPtr; + Tcl_Preserve(chanPtr); + } UpdateInterest(chanPtr); + Tcl_Release(chanPtr); return copiedTotal; } @@ -4884,6 +4752,7 @@ TclGetsObjBinary( */ chanPtr = statePtr->topChanPtr; + Tcl_Preserve(chanPtr); bufPtr = statePtr->inQueueHead; @@ -4930,17 +4799,13 @@ TclGetsObjBinary( * 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; + } } dst = (unsigned char *) RemovePoint(bufPtr); @@ -4995,10 +4860,15 @@ 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. @@ -5053,12 +4923,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); @@ -5087,6 +4957,7 @@ TclGetsObjBinary( done: UpdateInterest(chanPtr); + Tcl_Release(chanPtr); return copiedTotal; } @@ -5115,6 +4986,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; +} /* *--------------------------------------------------------------------------- @@ -5148,7 +5034,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 @@ -5182,14 +5068,6 @@ 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 (GetInput(chanPtr) != 0) { gsPtr->charsWrote = 0; gsPtr->rawRead = 0; @@ -5197,6 +5075,11 @@ FilterInputBytes( } bufPtr = statePtr->inQueueTail; gsPtr->bufPtr = bufPtr; + if (bufPtr == NULL) { + gsPtr->charsWrote = 0; + gsPtr->rawRead = 0; + return -1; + } } /* @@ -5205,8 +5088,7 @@ FilterInputBytes( * string rep if we need more space. */ - rawStart = RemovePoint(bufPtr); - raw = rawStart; + raw = RemovePoint(bufPtr); rawLen = BytesLeft(bufPtr); dst = *gsPtr->dstPtr; @@ -5273,9 +5155,15 @@ 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. */ + if (GotFlag(statePtr, CHANNEL_NONBLOCKING|CHANNEL_BLOCKED) + == (CHANNEL_NONBLOCKING|CHANNEL_BLOCKED)) { + gsPtr->charsWrote = 0; + gsPtr->rawRead = 0; + return -1; + } goto read; } } else { @@ -5514,134 +5402,77 @@ 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; 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. - */ - - if (nread < (bytesToRead - copied)) { - SetFlag(statePtr, CHANNEL_BLOCKED); - } - -#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING - if (nread <= (bytesToRead - copied)) { - /* - * [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)) { - if (copied > 0) { - /* - * Information that was copied earlier has precedence - * over EAGAIN/WOULDBLOCK handling. - */ + /* Go to the driver if more data needed. */ - return copied; - } + if (bytesToRead > 0) { - SetFlag(statePtr, CHANNEL_BLOCKED); - result = EAGAIN; - } + int nread = ChanRead(chanPtr, readBuf, bytesToRead); - Tcl_SetErrno(result); - return -1; + if (nread > 0) { + /* Successful read (short is OK) - add to bytes copied */ + 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. + */ + if (!GotFlag(statePtr, CHANNEL_BLOCKED) || copied == 0) { + copied = -1; } - - return copied + nread; + } else if (copied > 0) { + /* + * nread == 0. Driver is at EOF, but if copied>0 bytes + * from pushback, then we should not signal it yet. + */ + ResetFlag(statePtr, CHANNEL_EOF); } } - - done: return copied; } @@ -5738,8 +5569,9 @@ DoReadChars( ChannelState *statePtr = chanPtr->state; /* State info for channel */ ChannelBuffer *bufPtr; - int offset, factor, copied, copiedNow, result; + int factor, copied, copiedNow, result; Tcl_Encoding encoding; + int binaryMode; #define UTF_EXPANSION_FACTOR 1024 /* @@ -5749,9 +5581,14 @@ DoReadChars( chanPtr = statePtr->topChanPtr; encoding = statePtr->encoding; factor = UTF_EXPANSION_FACTOR; + Tcl_Preserve(chanPtr); + + 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); @@ -5760,27 +5597,23 @@ 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); - } } + /* Must clear the BLOCKED flag here since we check before reading */ + ResetFlag(statePtr, CHANNEL_BLOCKED); 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); } /* @@ -5803,19 +5636,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) { + Tcl_Release(chanPtr); + chanPtr = statePtr->topChanPtr; + Tcl_Preserve(chanPtr); + } if (result != 0) { - if (result == EAGAIN) { - break; + if (!GotFlag(statePtr, CHANNEL_BLOCKED)) { + copied = -1; } - copied = -1; - goto done; + break; } } else { copied += copiedNow; @@ -5823,27 +5658,31 @@ 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. */ + if (toRead == 0) { + ResetFlag(statePtr, CHANNEL_BLOCKED); + } - done: /* * Regenerate the top channel, in case it was changed due to * self-modifying reflected transforms. */ + if (chanPtr != statePtr->topChanPtr) { + Tcl_Release(chanPtr); + chanPtr = statePtr->topChanPtr; + Tcl_Preserve(chanPtr); + } - chanPtr = statePtr->topChanPtr; - + /* + * Update the notifier state so we don't block while there is still data + * in the buffers. + */ UpdateInterest(chanPtr); + Tcl_Release(chanPtr); return copied; } @@ -5861,13 +5700,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. * *--------------------------------------------------------------------------- */ @@ -5880,72 +5717,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; + ChannelBuffer *bufPtr = statePtr->inQueueHead; + int srcLen = BytesLeft(bufPtr); + int toRead = bytesToRead>srcLen || bytesToRead<0 ? srcLen : bytesToRead; - 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--; - } - - 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; } /* @@ -5989,262 +5776,351 @@ 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 dstLimit, 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 * expand when converted to UTF-8 chars. This guess comes from analyzing * how many characters were produced by the previous pass. */ + + int factor = *factorPtr; + int dstNeeded = TCL_UTF_MAX - 1 + toRead * factor / UTF_EXPANSION_FACTOR; - 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); - - 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, dstNeeded); 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. - */ - - dstNeeded = spaceLeft; + unsigned int size; + dst = TclGetStringStorage(objPtr, &size) + numBytes; + dstNeeded = 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. + * 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. * - * 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. - * - * 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)) { + dstLimit = dstNeeded + 1; + while (1) { + int dstDecoded, dstRead, dstWrote, srcRead, numChars; + /* - * 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. */ - statePtr->inputEncodingFlags &= ~TCL_ENCODING_END; - encEndFlagSuppressed = 1; - } + int code = Tcl_ExternalToUtf(NULL, encoding, src, srcLen, + statePtr->inputEncodingFlags & (bufPtr->nextPtr + ? ~0 : ~TCL_ENCODING_END), &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 + 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 + 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 + 2]; + int read, decoded, count; + + /* + * Didn't get everything the buffer could offer + */ + + statePtr->flags = savedFlags; + statePtr->inputEncodingFlags = savedIEFlags; + statePtr->inputEncodingState = savedState; + + Tcl_ExternalToUtf(NULL, encoding, src, srcLen, + statePtr->inputEncodingFlags & (bufPtr->nextPtr + ? ~0 : ~TCL_ENCODING_END), &statePtr->inputEncodingState, + buffer, TCL_UTF_MAX + 2, &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; + } + + dst[1] = '\0'; + statePtr->inputEncodingFlags &= ~TCL_ENCODING_START; + + Tcl_SetObjLength(objPtr, numBytes + 1); + return 1; + } + + } else if (statePtr->flags & CHANNEL_EOF) { - 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. + * 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. - */ + /* + * We read more chars than allowed. Reset limits to + * prevent that and try again. Don't forget the extra + * padding of TCL_UTF_MAX - 1 bytes demanded by the + * Tcl_ExternalToUtf() call! + */ - if (dstWrote == 0) { - return -1; + dstLimit = Tcl_UtfAtIndex(dst, charsToRead + 1) + + TCL_UTF_MAX - 1 - dst; + statePtr->flags = savedFlags; + statePtr->inputEncodingFlags = savedIEFlags; + statePtr->inputEncodingState = savedState; + continue; } - 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. - */ + if (dstWrote == 0) { + ChannelBuffer *nextPtr; - numChars -= dstRead - dstWrote; + /* We were not able to read any chars. */ - if ((unsigned) numChars > (unsigned) toRead) { - /* - * Got too many chars. - */ + assert (numChars == 0); - const char *eof = Tcl_UtfAtIndex(dst, toRead); + /* + * 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. + */ - 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; + if (dst[0] == '\n') { + assert(statePtr->inputTranslation == TCL_TRANSLATE_AUTO); + assert(dstRead == 1); + + 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. + */ - bufPtr->nextRemoved += srcRead; - if (dstWrote > srcRead + 1) { - *factorPtr = dstWrote * UTF_EXPANSION_FACTOR / srcRead; + 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->inputEncodingFlags &= ~TCL_ENCODING_START; + + consume: + bufPtr->nextRemoved += srcRead; + /* + * If this read contained multibyte characters, revise factorPtr + * so the next read will allocate bigger buffers. + */ + if (numChars && numChars < srcRead) { + *factorPtr = srcRead * UTF_EXPANSION_FACTOR / numChars; + } + Tcl_SetObjLength(objPtr, numBytes + dstWrote); + return numChars; } - *offsetPtr += dstWrote; - return numChars; } /* @@ -6265,7 +6141,7 @@ ReadChars( *--------------------------------------------------------------------------- */ -static int +static void TranslateInputEOL( ChannelState *statePtr, /* Channel being read, for EOL translation and * EOF character. */ @@ -6274,132 +6150,138 @@ 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; + const char *crFound, *src = srcStart; + char *dst = dstStart; + int lesser; - dst = dstStart; - src = srcStart; - srcEnd = srcStart + dstLen; - srcMax = srcStart + *srcLenPtr; - - 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 @@ -6408,12 +6290,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, INPUT_SAW_CR); } - - *srcLenPtr = srcLen; - return 0; } /* @@ -6467,16 +6345,11 @@ 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; - } - ResetFlag(statePtr, CHANNEL_BLOCKED | CHANNEL_EOF); + ResetFlag(statePtr, + CHANNEL_BLOCKED | CHANNEL_STICKY_EOF | CHANNEL_EOF | INPUT_SAW_CR); bufPtr = AllocChannelBuffer(len); memcpy(InsertPoint(bufPtr), str, (size_t) len); @@ -6541,14 +6414,6 @@ Tcl_Flush( return -1; } - /* - * Force current output buffer to be output also. - */ - - if ((statePtr->curOutPtr != NULL) && IsBufferReady(statePtr->curOutPtr)) { - SetFlag(statePtr, BUFFER_READY); - } - result = FlushChannel(NULL, chanPtr, 0); if (result != 0) { return TCL_ERROR; @@ -6599,7 +6464,7 @@ DiscardInputQueued( */ if (discardSavedBuffers && statePtr->saveInBufPtr != NULL) { - ckfree(statePtr->saveInBufPtr); + ReleaseChannelBuffer(statePtr->saveInBufPtr); statePtr->saveInBufPtr = NULL; } } @@ -6611,6 +6476,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. @@ -6643,21 +6511,28 @@ GetInput( return EINVAL; } + /* + * For a channel at EOF do not bother allocating buffers; there's + * nothing more to read. Avoid calling the driver inputproc in + * case some of them do not react well to additional calls after + * they've reported an eof state.. + * TODO: Candidate for a can't happen panic. + */ + + if (GotFlag(statePtr, CHANNEL_EOF)) { + return 0; + } + /* * 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; - } + + assert(statePtr->inQueueHead == NULL); statePtr->inQueueHead = chanPtr->inQueueHead; statePtr->inQueueTail = chanPtr->inQueueTail; @@ -6678,21 +6553,20 @@ 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 + * Saved buffers of the wrong size are squashed. This is done * to honor dynamic changes of the buffersize made by the user. */ if ((bufPtr != NULL) - && (bufPtr->bufLength - BUFFER_PADDING < statePtr->bufSize)) { - ckfree(bufPtr); + && (bufPtr->bufLength - BUFFER_PADDING != statePtr->bufSize)) { + ReleaseChannelBuffer(bufPtr); bufPtr = NULL; } @@ -6701,21 +6575,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; @@ -6723,75 +6584,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; } /* @@ -6919,15 +6727,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 @@ -7251,17 +7050,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; @@ -7477,14 +7266,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; } } @@ -7920,6 +7721,7 @@ Tcl_SetChannelOption( return TCL_ERROR; } Tcl_SetChannelBufferSize(chan, newBufferSize); + return TCL_OK; } else if (HaveOpt(2, "-encoding")) { Tcl_Encoding encoding; @@ -7937,7 +7739,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); @@ -7950,6 +7753,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; @@ -8110,33 +7914,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; } @@ -8228,21 +8005,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. @@ -8302,8 +8064,9 @@ 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; + } } /* @@ -8371,6 +8134,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. @@ -8478,29 +8246,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; @@ -9283,9 +9030,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); } /* @@ -9440,12 +9187,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. @@ -9456,538 +9214,152 @@ 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. */ - - /* - * 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); - - /* - * Update the notifier state so we don't block while there is still data - * in the buffers. - */ - - 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 (statePtr->inQueueHead == NULL) { - return 0; - } - bufPtr = statePtr->inQueueHead; - bytesInBuffer = BytesLeft(bufPtr); - - copied = 0; - switch (statePtr->inputTranslation) { - case TCL_TRANSLATE_LF: - if (bytesInBuffer == 0) { - return 0; - } + char *p = dst; + Tcl_Preserve(chanPtr); + while (bytesToRead) { /* - * Copy the current chunk into the result buffer. + * Each pass through the loop is intended to process up to + * one channel 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; - } + int bytesRead, bytesWritten; + ChannelBuffer *bufPtr = statePtr->inQueueHead; /* - * Copy the current chunk into the result buffer, then replace all \r - * with \n. + * When there's no buffered data to read, and we're at EOF, + * escape to the caller. */ - if (bytesInBuffer < space) { - space = bytesInBuffer; + if (statePtr->flags & CHANNEL_EOF + && (bufPtr == NULL || IsBufferEmpty(bufPtr))) { + break; } - memcpy(result, RemovePoint(bufPtr), (size_t) space); - bufPtr->nextRemoved += space; - copied = space; - for (end = result + copied; result < end; result++) { - if (*result == '\r') { - *result = '\n'; - } - } - break; - } - case TCL_TRANSLATE_CRLF: { - char *src, *end, *dst; - int curByte; + /* If there is no full buffer, attempt to create and/or fill one. */ - /* - * If there is a held-back "\r" at EOF, produce it now. - */ + while (!IsBufferFull(bufPtr)) { + int code; - 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; - } - - /* - * Copy the current chunk and replace "\r\n" with "\n" (but not - * standalone "\r"!). - */ + moreData: + code = GetInput(chanPtr); + bufPtr = statePtr->inQueueHead; - if (bytesInBuffer < space) { - space = bytesInBuffer; - } - memcpy(result, RemovePoint(bufPtr), (size_t) space); - bufPtr->nextRemoved += space; - copied = space; + assert (bufPtr != NULL); - 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 (statePtr->flags & (CHANNEL_EOF|CHANNEL_BLOCKED)) { + /* Further reads cannot do any more */ + break; } - if (curByte == '\r') { - SetFlag(statePtr, INPUT_SAW_CR); - } else { - *dst = (char) curByte; - dst++; + + if (code) { + /* Read error */ + UpdateInterest(chanPtr); + Tcl_Release(chanPtr); + return -1; } - } - copied = dst - result; - break; - } - case TCL_TRANSLATE_AUTO: { - char *src, *end, *dst; - int curByte; - if (bytesInBuffer == 0) { - return 0; + assert (IsBufferFull(bufPtr)); } - /* - * 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; + bytesRead = BytesLeft(bufPtr); + bytesWritten = bytesToRead; - 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); - } - } - copied = dst - result; - break; - } - default: - Tcl_Panic("unknown eol translation mode"); - } + TranslateInputEOL(statePtr, p, RemovePoint(bufPtr), + &bytesWritten, &bytesRead); + bufPtr->nextRemoved += bytesRead; + p += bytesWritten; + bytesToRead -= bytesWritten; - /* - * 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) { - /* - * Set sticky EOF so that no further input is presented to the - * caller. - */ + 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. + */ - SetFlag(statePtr, CHANNEL_EOF | CHANNEL_STICKY_EOF); - statePtr->inputEncodingFlags |= TCL_ENCODING_END; - copied = i; + if (bytesToRead == 0) { + UpdateInterest(chanPtr); break; } - } - } - - /* - * If the current buffer is empty recycle it. - */ - - if (IsBufferEmpty(bufPtr)) { - statePtr->inQueueHead = bufPtr->nextPtr; - if (statePtr->inQueueHead == NULL) { - statePtr->inQueueTail = NULL; - } - 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. - */ - 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; - } - - /* - * 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; - - /* - * 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. - */ - - /* - * If the current buffer is empty recycle it. - */ - - if (IsBufferEmpty(bufPtr)) { - chanPtr->inQueueHead = bufPtr->nextPtr; - if (chanPtr->inQueueHead == NULL) { - chanPtr->inQueueTail = NULL; - } - RecycleBuffer(chanPtr->state, bufPtr, 0); - } - - /* - * Return the number of characters copied into the result buffer. - */ - - 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. - * - *---------------------------------------------------------------------- - */ - -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 we are in network (or windows) translation mode, record the fact - * that we have not yet sent a CR to the channel. - */ - - crsent = 0; - - /* - * Loop filling buffers and flushing them until all output has been - * consumed. - */ + /* + * 1) We're @EOF because we saw eof char. + */ - srcCopied = 0; - totalDestCopied = 0; + if (statePtr->inEofChar + && RemovePoint(bufPtr)[0] == statePtr->inEofChar) { + UpdateInterest(chanPtr); + break; + } - while (srcLen > 0) { - /* - * Make sure there is a current output buffer to accept output. - */ + /* + * 2) The buffer holds a \r while in CRLF translation, + * followed by the end of the buffer. + */ - if (statePtr->curOutPtr == NULL) { - statePtr->curOutPtr = AllocChannelBuffer(statePtr->bufSize); - } + assert(statePtr->inputTranslation == TCL_TRANSLATE_CRLF); + assert(RemovePoint(bufPtr)[0] == '\r'); + assert(BytesLeft(bufPtr) == 1); - outBufPtr = statePtr->curOutPtr; + if (bufPtr->nextPtr == NULL) { + /* There's no more buffered data.... */ - destCopied = SpaceLeft(outBufPtr); - if (destCopied > srcLen) { - destCopied = srcLen; - } + if (statePtr->flags & CHANNEL_EOF) { + /* ...and there never will be. */ - destPtr = InsertPoint(outBufPtr); - switch (statePtr->outputTranslation) { - case TCL_TRANSLATE_LF: - srcCopied = destCopied; - memcpy(destPtr, src, (size_t) destCopied); - 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--; - } + *p++ = '\r'; + bytesToRead--; + bufPtr->nextRemoved++; + } else if (statePtr->flags & CHANNEL_BLOCKED) { + /* ...and we cannot get more now. */ + SetFlag(statePtr, CHANNEL_NEED_MORE_DATA); + UpdateInterest(chanPtr); + break; } else { - *dPtr = *sPtr; + /* ... so we need to get some. */ + goto moreData; } } - 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. - */ + if (bufPtr->nextPtr) { + /* There's a next buffer. Shift orphan \r to it. */ - 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); + ChannelBuffer *nextPtr = bufPtr->nextPtr; + + nextPtr->nextRemoved -= 1; + RemovePoint(nextPtr)[0] = '\r'; + bufPtr->nextRemoved++; } } - totalDestCopied += srcCopied; - src += srcCopied; - srcLen -= srcCopied; - - if (GotFlag(statePtr, BUFFER_READY)) { - if (FlushChannel(NULL, chanPtr, 0) != 0) { - return -1; + if (IsBufferEmpty(bufPtr)) { + statePtr->inQueueHead = bufPtr->nextPtr; + if (statePtr->inQueueHead == NULL) { + statePtr->inQueueTail = NULL; } + RecycleBuffer(statePtr, bufPtr, 0); } - } /* Closes "while" */ - return totalDestCopied; + if ((GotFlag(statePtr, CHANNEL_NONBLOCKING) || allowShortReads) + && GotFlag(statePtr, CHANNEL_BLOCKED)) { + break; + } + } + if (bytesToRead == 0) { + ResetFlag(statePtr, CHANNEL_BLOCKED); + } + + Tcl_Release(chanPtr); + return (int)(p - dst); } /* @@ -10107,12 +9479,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) { @@ -11215,12 +10590,11 @@ DupChannelIntRep( * currently have an internal rep.*/ { ChannelState *statePtr = GET_CHANNELSTATE(srcPtr); - Interp *interpPtr = GET_CHANNELINTERP(srcPtr); SET_CHANNELSTATE(copyPtr, statePtr); - SET_CHANNELINTERP(copyPtr, interpPtr); + SET_CHANNELINTERP(copyPtr, GET_CHANNELINTERP(srcPtr)); Tcl_Preserve(statePtr); - copyPtr->typePtr = &tclChannelType; + copyPtr->typePtr = srcPtr->typePtr; } /* @@ -11246,43 +10620,30 @@ SetChannelFromAny( register Tcl_Obj *objPtr) /* The object to convert. */ { ChannelState *statePtr; - Interp *interpPtr; if (interp == NULL) { return TCL_ERROR; } - if (objPtr->typePtr == &tclChannelType) { + if (objPtr->typePtr == &chanObjType) { /* + * TODO: TAINT Flag and dup'd channel values? * 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) { + } else if (interp != GET_CHANNELINTERP(objPtr)) { Tcl_Release(statePtr); - UpdateStringOfChannel(objPtr); objPtr->typePtr = NULL; } } - if (objPtr->typePtr != &tclChannelType) { - Tcl_Channel chan; + if (objPtr->typePtr != &chanObjType) { + Tcl_Channel chan = Tcl_GetChannel(interp, TclGetString(objPtr), NULL); - /* - * 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; } @@ -11292,7 +10653,7 @@ SetChannelFromAny( Tcl_Preserve(statePtr); SET_CHANNELSTATE(objPtr, statePtr); SET_CHANNELINTERP(objPtr, interp); - objPtr->typePtr = &tclChannelType; + objPtr->typePtr = &chanObjType; } return TCL_OK; } @@ -11300,45 +10661,6 @@ SetChannelFromAny( /* *---------------------------------------------------------------------- * - * 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; - } - } -} - -/* - *---------------------------------------------------------------------- - * * FreeChannelIntRep -- * * Release statePtr storage. @@ -11381,20 +10703,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 1e89878..097cd61 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -30,32 +30,13 @@ #endif /* - * The following structure encapsulates the state for a background channel - * copy. Note that the data buffer for the copy will be appended to this - * structure. - */ - -typedef struct CopyState { - struct Channel *readPtr; /* Pointer to input channel. */ - struct Channel *writePtr; /* Pointer to output channel. */ - int readFlags; /* Original read channel flags. */ - int writeFlags; /* Original write channel flags. */ - Tcl_WideInt toRead; /* Number of bytes to copy, or -1. */ - Tcl_WideInt total; /* Total bytes transferred (written). */ - Tcl_Interp *interp; /* Interp that started the copy. */ - Tcl_Obj *cmdPtr; /* Command to be invoked at completion. */ - int bufSize; /* Size of appended buffer. */ - char buffer[1]; /* Copy buffer, this must be the last - * field. */ -} CopyState; - -/* * struct ChannelBuffer: * * Buffers data being sent to or from a channel. */ 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 @@ -86,19 +67,6 @@ typedef struct ChannelBuffer { #define CHANNELBUFFER_DEFAULT_SIZE (1024 * 4) /* - * Structure to record a close callback. One such record exists for each close - * callback registered for a channel. - */ - -typedef struct CloseCallback { - Tcl_CloseProc *proc; /* The procedure to call. */ - ClientData clientData; /* Arbitrary one-word data to pass to the - * callback. */ - struct CloseCallback *nextPtr; - /* For chaining close callbacks. */ -} CloseCallback; - -/* * The following structure describes the information saved from a call to * "fileevent". This is used later when the event being waited for to invoke * the saved script in the interpreter designed in this record. @@ -195,7 +163,8 @@ typedef struct ChannelState { * value is the POSIX error code. */ int refCount; /* How many interpreters hold references to * this IO channel? */ - CloseCallback *closeCbPtr; /* Callbacks registered to be called when the + struct CloseCallback *closeCbPtr; + /* Callbacks registered to be called when the * channel is closed. */ char *outputStage; /* Temporary staging buffer used when * translating EOL before converting from @@ -217,8 +186,10 @@ typedef struct ChannelState { * handlers ("fileevent") on this channel. */ int bufSize; /* What size buffers to allocate? */ Tcl_TimerToken timer; /* Handle to wakeup timer for this channel. */ - CopyState *csPtrR; /* State of background copy for which channel is input, or NULL. */ - CopyState *csPtrW; /* State of background copy for which channel is output, or NULL. */ + struct CopyState *csPtrR; /* State of background copy for which channel + * is input, or NULL. */ + struct CopyState *csPtrW; /* State of background copy for which channel + * is output, or NULL. */ Channel *topChanPtr; /* Refers to topmost channel in a stack. Never * NULL. */ Channel *bottomChanPtr; /* Refers to bottommost channel in a stack. @@ -256,11 +227,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. */ @@ -282,9 +248,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 @@ -304,29 +267,6 @@ 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 @@ -342,89 +282,6 @@ typedef struct ChannelState { * the channel is allowed. */ /* - * For each channel handler registered in a call to Tcl_CreateChannelHandler, - * there is one record of the following type. All of records for a specific - * channel are chained together in a singly linked list which is stored in the - * channel structure. - */ - -typedef struct ChannelHandler { - Channel *chanPtr; /* The channel structure for this channel. */ - int mask; /* Mask of desired events. */ - Tcl_ChannelProc *proc; /* Procedure to call in the type of - * Tcl_CreateChannelHandler. */ - ClientData clientData; /* Argument to pass to procedure. */ - struct ChannelHandler *nextPtr; - /* Next one in list of registered handlers. */ -} ChannelHandler; - -/* - * This structure keeps track of the current ChannelHandler being invoked in - * the current invocation of ChannelHandlerEventProc. There is a potential - * problem if a ChannelHandler is deleted while it is the current one, since - * ChannelHandlerEventProc needs to look at the nextPtr field. To handle this - * problem, structures of the type below indicate the next handler to be - * processed for any (recursively nested) dispatches in progress. The - * nextHandlerPtr field is updated if the handler being pointed to is deleted. - * The nextPtr field is used to chain together all recursive invocations, so - * that Tcl_DeleteChannelHandler can find all the recursively nested - * invocations of ChannelHandlerEventProc and compare the handler being - * deleted against the NEXT handler to be invoked in that invocation; when it - * finds such a situation, Tcl_DeleteChannelHandler updates the nextHandlerPtr - * field of the structure to the next handler. - */ - -typedef struct NextChannelHandler { - ChannelHandler *nextHandlerPtr; - /* The next handler to be invoked in this - * invocation. */ - struct NextChannelHandler *nestedHandlerPtr; - /* Next nested invocation of - * ChannelHandlerEventProc. */ -} NextChannelHandler; - -/* - * The following structure describes the event that is added to the Tcl event - * queue by the channel handler check procedure. - */ - -typedef struct ChannelHandlerEvent { - Tcl_Event header; /* Standard header for all events. */ - Channel *chanPtr; /* The channel that is ready. */ - int readyMask; /* Events that have occurred. */ -} ChannelHandlerEvent; - -/* - * The following structure is used by Tcl_GetsObj() to encapsulates the state - * for a "gets" operation. - */ - -typedef struct GetsState { - Tcl_Obj *objPtr; /* The object to which UTF-8 characters will - * be appended. */ - char **dstPtr; /* Pointer into objPtr's string rep where next - * character should be stored. */ - Tcl_Encoding encoding; /* The encoding to use to convert raw bytes to - * UTF-8. */ - ChannelBuffer *bufPtr; /* The current buffer of raw bytes being - * emptied. */ - Tcl_EncodingState state; /* The encoding state just before the last - * external to UTF-8 conversion in - * FilterInputBytes(). */ - int rawRead; /* The number of bytes removed from bufPtr in - * the last call to FilterInputBytes(). */ - int bytesWrote; /* The number of bytes of UTF-8 data appended - * to objPtr during the last call to - * FilterInputBytes(). */ - int charsWrote; /* The corresponding number of UTF-8 - * characters appended to objPtr during the - * last call to FilterInputBytes(). */ - int totalChars; /* The total number of UTF-8 characters - * appended to objPtr so far, just before the - * last call to FilterInputBytes(). */ -} GetsState; - -/* * The length of time to wait between synthetic timer events. Must be zero or * bad things tend to happen. */ diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 1673bce..3368a76 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -181,6 +181,7 @@ Tcl_PutsObjCmd( return TCL_ERROR; } + Tcl_Preserve(chan); result = Tcl_WriteObj(chan, string); if (result < 0) { goto error; @@ -191,6 +192,7 @@ Tcl_PutsObjCmd( goto error; } } + Tcl_Release(chan); return TCL_OK; /* @@ -205,6 +207,7 @@ Tcl_PutsObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf("error writing \"%s\": %s", TclGetString(chanObjPtr), Tcl_PosixError(interp))); } + Tcl_Release(chan); return TCL_ERROR; } @@ -252,6 +255,7 @@ Tcl_FlushObjCmd( return TCL_ERROR; } + Tcl_Preserve(chan); if (Tcl_Flush(chan) != TCL_OK) { /* * TIP #219. @@ -265,8 +269,10 @@ Tcl_FlushObjCmd( "error flushing \"%s\": %s", TclGetString(chanObjPtr), Tcl_PosixError(interp))); } + Tcl_Release(chan); return TCL_ERROR; } + Tcl_Release(chan); return TCL_OK; } @@ -299,6 +305,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 +322,7 @@ Tcl_GetsObjCmd( return TCL_ERROR; } + Tcl_Preserve(chan); linePtr = Tcl_NewObj(); lineLen = Tcl_GetsObj(chan, linePtr); if (lineLen < 0) { @@ -333,20 +341,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: + Tcl_Release(chan); + return code; } /* @@ -453,6 +465,7 @@ Tcl_ReadObjCmd( resultPtr = Tcl_NewObj(); Tcl_IncrRefCount(resultPtr); + Tcl_Preserve(chan); charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0); if (charactersRead < 0) { /* @@ -467,6 +480,7 @@ Tcl_ReadObjCmd( "error reading \"%s\": %s", TclGetString(chanObjPtr), Tcl_PosixError(interp))); } + Tcl_Release(chan); Tcl_DecrRefCount(resultPtr); return TCL_ERROR; } @@ -485,6 +499,7 @@ Tcl_ReadObjCmd( } } Tcl_SetObjResult(interp, resultPtr); + Tcl_Release(chan); Tcl_DecrRefCount(resultPtr); return TCL_OK; } @@ -544,6 +559,7 @@ Tcl_SeekObjCmd( mode = modeArray[optionIndex]; } + Tcl_Preserve(chan); result = Tcl_Seek(chan, offset, mode); if (result == Tcl_LongAsWide(-1)) { /* @@ -558,8 +574,10 @@ Tcl_SeekObjCmd( "error during seek on \"%s\": %s", TclGetString(objv[1]), Tcl_PosixError(interp))); } + Tcl_Release(chan); return TCL_ERROR; } + Tcl_Release(chan); return TCL_OK; } @@ -590,6 +608,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 +624,7 @@ Tcl_TellObjCmd( return TCL_ERROR; } + Tcl_Preserve(chan); newLoc = Tcl_Tell(chan); /* @@ -613,7 +633,10 @@ Tcl_TellObjCmd( * them into the regular interpreter result. */ - if (TclChanCaughtErrorBypass(interp, chan)) { + + code = TclChanCaughtErrorBypass(interp, chan); + Tcl_Release(chan); + if (code) { return TCL_ERROR; } @@ -896,7 +919,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 +933,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; } @@ -1673,7 +1696,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..9c4347d 100644 --- a/generic/tclIOGT.c +++ b/generic/tclIOGT.c @@ -210,7 +210,27 @@ struct TransformChannelData { * a transformation of incoming data. Also * serves as buffer of all data not yet * consumed by the reader. */ + int refCount; }; + +static void +PreserveData( + TransformChannelData *dataPtr) +{ + dataPtr->refCount++; +} + +static void +ReleaseData( + TransformChannelData *dataPtr) +{ + if (--dataPtr->refCount) { + return; + } + ResultClear(&dataPtr->result); + Tcl_DecrRefCount(dataPtr->command); + ckfree(dataPtr); +} /* *---------------------------------------------------------------------- @@ -240,6 +260,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 +268,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,6 +288,7 @@ TclChannelTransform( dataPtr = ckalloc(sizeof(TransformChannelData)); + dataPtr->refCount = 1; Tcl_DStringInit(&ds); Tcl_GetChannelOption(interp, chan, "-blocking", &ds); dataPtr->readIsFlushed = 0; @@ -270,7 +298,6 @@ TclChannelTransform( } Tcl_DStringFree(&ds); - dataPtr->self = chan; dataPtr->watchMask = 0; dataPtr->mode = mode; dataPtr->timer = NULL; @@ -286,19 +313,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 +335,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 +380,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 +394,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 +415,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 +437,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 +466,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); + Tcl_ResetResult(eval); if (preserve == P_PRESERVE) { - (void) Tcl_RestoreInterpState(dataPtr->interp, state); - } - return res; - - cleanup: - 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 +559,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 +579,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,7 +622,7 @@ TransformInputProc( * Should assert(dataPtr->mode & TCL_READABLE); */ - if (toRead == 0) { + if (toRead == 0 || dataPtr->self == NULL) { /* * Catch a no-op. */ @@ -606,6 +632,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 +650,7 @@ TransformInputProc( * break out of the loop and return to the caller. */ - return gotBytes; + break; } /* @@ -647,7 +674,7 @@ TransformInputProc( } } /* else: 'maxRead < 0' == Accept the current value of toRead. */ if (toRead <= 0) { - return gotBytes; + break; } /* @@ -656,43 +683,40 @@ 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; } + /* + * 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. + */ + *errorCodePtr = Tcl_GetErrno(); - return -1; + gotBytes = -1; + break; } 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. + * Zero returned from Tcl_ReadRaw() always indicates EOF + * on the down channel. */ - 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. */ - return gotBytes; + break; } dataPtr->readIsFlushed = 1; @@ -704,7 +728,7 @@ TransformInputProc( * We had nothing to flush. */ - return gotBytes; + break; } continue; /* at: while (toRead > 0) */ @@ -718,9 +742,11 @@ 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 */ + ReleaseData(dataPtr); return gotBytes; } @@ -762,11 +788,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 +847,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); @@ -830,6 +859,7 @@ TransformSeekProc( ResultClear(&dataPtr->result); dataPtr->readIsFlushed = 0; } + ReleaseData(dataPtr); return parentSeekProc(Tcl_GetChannelInstanceData(parent), offset, mode, errorCodePtr); @@ -890,6 +920,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); @@ -901,6 +932,7 @@ TransformWideSeekProc( ResultClear(&dataPtr->result); dataPtr->readIsFlushed = 0; } + ReleaseData(dataPtr); /* * If we have a wide seek capability, we should stick with that. @@ -1055,6 +1087,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..ff602c6 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -99,31 +99,9 @@ typedef struct { 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 @@ -450,9 +428,8 @@ 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); @@ -467,16 +444,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 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 +558,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 +571,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) { @@ -683,7 +654,11 @@ TclChanCreateObjCmd( * Everything is fine now. */ - rcPtr->methods = methods; + chan = Tcl_CreateChannel(&tclRChannelType, TclGetString(rcId), rcPtr, + mode); + rcPtr->chan = chan; + Tcl_Preserve(chan); + chanPtr = (Channel *) chan; if ((methods & NULLABLE_METHODS) != NULLABLE_METHODS) { /* @@ -744,12 +719,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((char*) rcPtr); return TCL_ERROR; #undef MODE @@ -1138,6 +1111,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()) { /* @@ -1172,21 +1146,15 @@ ReflectClose( if (result != TCL_OK) { FreeReceivedError(&p); } + return EOK; } #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((char *)tctPtr); + ((Channel *)rcPtr->chan)->typePtr = NULL; + } Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); return EOK; } @@ -1208,14 +1176,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); } @@ -1253,6 +1219,11 @@ ReflectClose( } #endif + tctPtr = ((Channel *)rcPtr->chan)->typePtr; + if (tctPtr && tctPtr != &tclRChannelType) { + ckfree((char *)tctPtr); + ((Channel *)rcPtr->chan)->typePtr = NULL; + } Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); #ifdef TCL_THREADS } @@ -1290,18 +1261,6 @@ 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? */ @@ -1339,7 +1298,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,18 +1364,6 @@ 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? */ @@ -1450,11 +1397,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 +1414,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; @@ -1495,6 +1451,7 @@ ReflectOutput( stop: Tcl_DecrRefCount(bufObj); Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ + Tcl_Release(rcPtr->interp); Tcl_Release(rcPtr); return written; invalid: @@ -1568,7 +1525,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 +1596,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. @@ -1683,7 +1638,7 @@ ReflectWatch( 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); @@ -1742,7 +1697,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 { @@ -1854,7 +1809,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,7 +1854,7 @@ 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? @@ -1938,14 +1893,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); } @@ -2159,16 +2114,13 @@ 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 @@ -2177,54 +2129,17 @@ NewReflectedChannel( 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 +2186,15 @@ 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; - } - - FreeReflectedChannelArgs(rcPtr); - - ckfree(rcPtr->argv); + Tcl_Release(chanPtr); + Tcl_DecrRefCount(rcPtr->name); + Tcl_DecrRefCount(rcPtr->methods); + Tcl_DecrRefCount(rcPtr->cmd); ckfree(rcPtr); } @@ -2340,16 +2225,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 +2257,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 +2275,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 +2287,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,7 +2316,6 @@ InvokeTclMethod( */ if (result != TCL_ERROR) { - Tcl_Obj *cmd = Tcl_NewListObj(cmdc, rcPtr->argv); int cmdLen; const char *cmdString = Tcl_GetStringFromObj(cmd, &cmdLen); @@ -2451,25 +2329,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). @@ -2657,6 +2527,11 @@ 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; @@ -2666,6 +2541,9 @@ DeleteReflectedChannelMap( continue; } paramPtr = evPtr->param; + if (!evPtr) { + continue; + } evPtr->resultPtr = NULL; resultPtr->evPtr = NULL; @@ -2700,7 +2578,6 @@ DeleteReflectedChannelMap( } rcPtr->dead = 1; - FreeReflectedChannelArgs(rcPtr); Tcl_DeleteHashEntry(hPtr); } #endif @@ -2797,6 +2674,11 @@ 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; @@ -2806,6 +2688,9 @@ DeleteThreadReflectedChannelMap( continue; } paramPtr = evPtr->param; + if (!evPtr) { + continue; + } evPtr->resultPtr = NULL; resultPtr->evPtr = NULL; @@ -2840,7 +2725,6 @@ DeleteThreadReflectedChannelMap( ReflectedChannel *rcPtr = Tcl_GetChannelInstanceData(chan); rcPtr->dead = 1; - FreeReflectedChannelArgs(rcPtr); Tcl_DeleteHashEntry(hPtr); } ckfree(rcmPtr); @@ -3018,17 +2902,19 @@ ForwardProc( * call upon for the driver. */ - case ForwardedClose: + case ForwardedClose: { /* * No parameters/results. */ - if (InvokeTclMethod(rcPtr, "finalize", NULL, NULL, &resObj)!=TCL_OK) { + const Tcl_ChannelType *tctPtr; + + 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 * @@ -3047,15 +2933,21 @@ ForwardProc( Tcl_GetChannelName(rcPtr->chan)); Tcl_DeleteHashEntry(hPtr); - FreeReflectedChannelArgs(rcPtr); + tctPtr = ((Channel *)rcPtr->chan)->typePtr; + if (tctPtr && tctPtr != &tclRChannelType) { + ckfree((char *)tctPtr); + ((Channel *)rcPtr->chan)->typePtr = NULL; + } + Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); 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 +2987,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 +3030,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 +3066,7 @@ ForwardProc( /* assert maskObj.refCount == 1 */ Tcl_Preserve(rcPtr); - (void) InvokeTclMethod(rcPtr, "watch", maskObj, NULL, NULL); + (void) InvokeTclMethod(rcPtr, METH_WATCH, maskObj, NULL, NULL); Tcl_DecrRefCount(maskObj); Tcl_Release(rcPtr); break; @@ -3185,7 +3077,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 +3093,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 +3112,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 +3128,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 { /* diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index 1de635f..45ee08d 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -457,8 +457,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); @@ -1063,6 +1062,7 @@ ReflectInput( { ReflectedTransform *rtPtr = clientData; int gotBytes, copied, readBytes; + Tcl_Obj *bufObj; /* * The following check can be done before thread redirection, because we @@ -1078,6 +1078,9 @@ ReflectInput( Tcl_Preserve(rtPtr); + /* TODO: Consider a more appropriate buffer size. */ + bufObj = Tcl_NewByteArrayObj(NULL, toRead); + Tcl_IncrRefCount(bufObj); gotBytes = 0; while (toRead > 0) { /* @@ -1129,52 +1132,40 @@ 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; } @@ -1198,13 +1189,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 +1198,20 @@ 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: + Tcl_DecrRefCount(bufObj); Tcl_Release(rtPtr); return gotBytes; @@ -2010,6 +2003,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); /* @@ -2054,6 +2048,7 @@ InvokeTclMethod( Tcl_IncrRefCount(resObj); } Tcl_RestoreInterpState(rtPtr->interp, sr); + Tcl_Release(rtPtr->interp); Tcl_Release(rtPtr); /* @@ -2230,6 +2225,9 @@ DeleteReflectedTransformMap( */ evPtr = resultPtr->evPtr; + if (evPtr == NULL) { + continue; + } paramPtr = evPtr->param; evPtr->resultPtr = NULL; @@ -2355,6 +2353,9 @@ DeleteThreadReflectedTransformMap( */ evPtr = resultPtr->evPtr; + if (evPtr == NULL) { + continue; + } paramPtr = evPtr->param; evPtr->resultPtr = NULL; @@ -3065,10 +3066,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 */ @@ -3081,8 +3080,8 @@ TransformRead( 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 +3101,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 +3111,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; } @@ -3184,7 +3178,7 @@ TransformWrite( } if (res < 0) { - *errorCodePtr = EINVAL; + *errorCodePtr = Tcl_GetErrno(); return 0; } @@ -3294,7 +3288,7 @@ TransformFlush( } if (res < 0) { - *errorCodePtr = EINVAL; + *errorCodePtr = Tcl_GetErrno(); return 0; } diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index f523e8f..d2919fc 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -18,13 +18,18 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#include <sys/stat.h> #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 -- * @@ -793,7 +798,7 @@ TclFinalizeFilesystem(void) * filesystem is likely to fail. */ -#ifdef __WIN32__ +#ifdef _WIN32 TclWinEncodingsCleanup(); #endif } @@ -820,7 +825,7 @@ TclResetFilesystem(void) filesystemList = &nativeFilesystemRecord; theFilesystemEpoch++; -#ifdef __WIN32__ +#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. @@ -3111,6 +3116,82 @@ 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. + */ + +int +TclSkipUnlink (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; + + 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. */ @@ -3226,6 +3307,9 @@ Tcl_LoadFile( */ copyToPtr = TclpTempFileNameForLibrary(interp, pathPtr); + if (copyToPtr == NULL) { + return TCL_ERROR; + } Tcl_IncrRefCount(copyToPtr); copyFsPtr = Tcl_FSGetFileSystemForPath(copyToPtr); @@ -3253,7 +3337,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 @@ -3298,7 +3382,9 @@ Tcl_LoadFile( * avoids any worries about leaving the copy laying around on exit. */ - if (Tcl_FSDeleteFile(copyToPtr) == TCL_OK) { + if ( + !TclSkipUnlink (copyToPtr) && + (Tcl_FSDeleteFile(copyToPtr) == TCL_OK)) { Tcl_DecrRefCount(copyToPtr); /* diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 512f5ba..ce8b9fb 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -53,7 +53,7 @@ static const Tcl_ObjType indexType = { /* * The definition of the internal representation of the "index" object; The - * internalRep.otherValuePtr field of an object of "index" type will be a + * internalRep.twoPtrValue.ptr1 field of an object of "index" type will be a * pointer to one of these structures. * * Keep this structure declaration in sync with tclTestObj.c @@ -69,12 +69,12 @@ typedef struct { * The following macros greatly simplify moving through a table... */ -#define STRING_AT(table, offset, index) \ - (*((const char *const *)(((char *)(table)) + ((offset) * (index))))) +#define STRING_AT(table, offset) \ + (*((const char *const *)(((char *)(table)) + (offset)))) #define NEXT_ENTRY(table, offset) \ - (&(STRING_AT(table, offset, 1))) + (&(STRING_AT(table, offset))) #define EXPAND_OF(indexRep) \ - STRING_AT((indexRep)->tablePtr, (indexRep)->offset, (indexRep)->index) + STRING_AT((indexRep)->tablePtr, (indexRep)->offset*(indexRep)->index) /* *---------------------------------------------------------------------- @@ -101,6 +101,7 @@ typedef struct { *---------------------------------------------------------------------- */ +#undef Tcl_GetIndexFromObj int Tcl_GetIndexFromObj( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ @@ -121,7 +122,7 @@ Tcl_GetIndexFromObj( */ if (objPtr->typePtr == &indexType) { - IndexRep *indexRep = objPtr->internalRep.otherValuePtr; + IndexRep *indexRep = objPtr->internalRep.twoPtrValue.ptr1; /* * Here's hoping we don't get hit by unfortunate packing constraints @@ -238,7 +239,7 @@ GetIndexFromObjList( * a proper match, then TCL_ERROR is returned and an error message is * left in interp's result (unless interp is NULL). The msg argument is * used in the error message; for example, if msg has the value "option" - * then the error message will say something flag 'bad option "foo": must + * then the error message will say something like 'bad option "foo": must * be ...' * * Side effects: @@ -270,12 +271,16 @@ Tcl_GetIndexFromObjStruct( Tcl_Obj *resultPtr; IndexRep *indexRep; + /* Protect against invalid values, like -1 or 0. */ + if (offset < (int)sizeof(char *)) { + offset = (int)sizeof(char *); + } /* * See if there is a valid cached result from a previous lookup. */ if (objPtr->typePtr == &indexType) { - indexRep = objPtr->internalRep.otherValuePtr; + indexRep = objPtr->internalRep.twoPtrValue.ptr1; if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) { *indexPtr = indexRep->index; return TCL_OK; @@ -336,11 +341,11 @@ Tcl_GetIndexFromObjStruct( */ if (objPtr->typePtr == &indexType) { - indexRep = objPtr->internalRep.otherValuePtr; + indexRep = objPtr->internalRep.twoPtrValue.ptr1; } else { TclFreeIntRep(objPtr); indexRep = ckalloc(sizeof(IndexRep)); - objPtr->internalRep.otherValuePtr = indexRep; + objPtr->internalRep.twoPtrValue.ptr1 = indexRep; objPtr->typePtr = &indexType; } indexRep->tablePtr = (void *) tablePtr; @@ -443,7 +448,7 @@ static void UpdateStringOfIndex( Tcl_Obj *objPtr) { - IndexRep *indexRep = objPtr->internalRep.otherValuePtr; + IndexRep *indexRep = objPtr->internalRep.twoPtrValue.ptr1; register char *buf; register unsigned len; register const char *indexStr = EXPAND_OF(indexRep); @@ -478,11 +483,11 @@ DupIndex( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { - IndexRep *srcIndexRep = srcPtr->internalRep.otherValuePtr; + IndexRep *srcIndexRep = srcPtr->internalRep.twoPtrValue.ptr1; IndexRep *dupIndexRep = ckalloc(sizeof(IndexRep)); memcpy(dupIndexRep, srcIndexRep, sizeof(IndexRep)); - dupPtr->internalRep.otherValuePtr = dupIndexRep; + dupPtr->internalRep.twoPtrValue.ptr1 = dupIndexRep; dupPtr->typePtr = &indexType; } @@ -507,7 +512,7 @@ static void FreeIndex( Tcl_Obj *objPtr) { - ckfree(objPtr->internalRep.otherValuePtr); + ckfree(objPtr->internalRep.twoPtrValue.ptr1); objPtr->typePtr = NULL; } @@ -948,13 +953,13 @@ Tcl_WrongNumArgs( if (origObjv[i]->typePtr == &indexType) { register IndexRep *indexRep = - origObjv[i]->internalRep.otherValuePtr; + origObjv[i]->internalRep.twoPtrValue.ptr1; elementStr = EXPAND_OF(indexRep); elemLen = strlen(elementStr); } else if (origObjv[i]->typePtr == &tclEnsembleCmdType) { register EnsembleCmdRep *ecrPtr = - origObjv[i]->internalRep.otherValuePtr; + origObjv[i]->internalRep.twoPtrValue.ptr1; elementStr = ecrPtr->fullSubcmdName; elemLen = strlen(elementStr); @@ -1003,12 +1008,12 @@ Tcl_WrongNumArgs( */ if (objv[i]->typePtr == &indexType) { - register IndexRep *indexRep = objv[i]->internalRep.otherValuePtr; + register IndexRep *indexRep = objv[i]->internalRep.twoPtrValue.ptr1; Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), NULL); } else if (objv[i]->typePtr == &tclEnsembleCmdType) { register EnsembleCmdRep *ecrPtr = - objv[i]->internalRep.otherValuePtr; + objv[i]->internalRep.twoPtrValue.ptr1; Tcl_AppendStringsToObj(objPtr, ecrPtr->fullSubcmdName, NULL); } else { diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 58dab42..9f7b106 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -626,14 +626,14 @@ declare 156 { declare 157 { Var *TclVarTraceExists(Tcl_Interp *interp, const char *varName) } -# REMOVED - use public Tcl_SetStartupScript() -#declare 158 { -# void TclSetStartupScriptFileName(const char *filename) -#} -# REMOVED - use public Tcl_GetStartupScript() -#declare 159 { -# const char *TclGetStartupScriptFileName(void) -#} +# REMOVED (except from stub table) - use public Tcl_SetStartupScript() +declare 158 { + void TclSetStartupScriptFileName(const char *filename) +} +# REMOVED (except from stub table) - use public Tcl_GetStartupScript() +declare 159 { + const char *TclGetStartupScriptFileName(void) +} #declare 160 { # int TclpMatchFilesTypes(Tcl_Interp *interp, char *separators, # Tcl_DString *dirPtr, char *pattern, char *tail, @@ -678,14 +678,14 @@ declare 166 { } # VFS-aware versions of Tcl*StartupScriptFileName (158 and 159 above) -# REMOVED - use public Tcl_SetStartupScript() -#declare 167 { -# void TclSetStartupScriptPath(Tcl_Obj *pathPtr) -#} -# REMOVED - use public Tcl_GetStartupScript() -#declare 168 { -# Tcl_Obj *TclGetStartupScriptPath(void) -#} +# REMOVED (except from stub table) - use public Tcl_SetStartupScript() +declare 167 { + void TclSetStartupScriptPath(Tcl_Obj *pathPtr) +} +# REMOVED (except from stub table) - use public Tcl_GetStartupScript() +declare 168 { + Tcl_Obj *TclGetStartupScriptPath(void) +} # variant of Tcl_UtfNCmp that takes n as bytes, not chars declare 169 { int TclpUtfNcmp2(const char *s1, const char *s2, unsigned long n) @@ -1006,6 +1006,12 @@ declare 249 { declare 250 { void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags, int force) } + +# Allow extensions for optimization +declare 251 { + int TclRegisterLiteral(void *envPtr, + char *bytes, int length, int flags) +} ############################################################################## diff --git a/generic/tclInt.h b/generic/tclInt.h index 18768d9..9a2e8dd 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -23,7 +23,6 @@ * Some numerics configuration options. */ -#undef NO_WIDE_TYPE #undef ACCEPT_NAN /* @@ -31,8 +30,7 @@ * here, so that system-dependent personalizations for the include files only * have to be made in once place. This results in a few extra includes, but * greater modularity. The order of the three groups of #includes is - * important. For example, stdio.h is needed by tcl.h, and the _ANSI_ARGS_ - * declaration in tcl.h is needed by stdlib.h in some configurations. + * important. For example, stdio.h is needed by tcl.h. */ #include "tclPort.h" @@ -96,14 +94,6 @@ typedef int ptrdiff_t; #endif /* - * When Tcl_WideInt and long are the same type, there's no value in - * having a tclWideIntType separate from the tclIntType. - */ -#ifdef TCL_WIDE_INT_IS_LONG -#define NO_WIDE_TYPE -#endif - -/* * Macros used to cast between pointers and integers (e.g. when storing an int * in ClientData), on 64-bit architectures they avoid gcc warning about "cast * to/from pointer from/to integer of different size". @@ -128,6 +118,10 @@ typedef int ptrdiff_t; # endif #endif +#if defined(_WIN32) && defined(_MSC_VER) +# define vsnprintf _vsnprintf +#endif + /* * The following procedures allow namespaces to be customized to support * special name resolution rules for commands/variables. @@ -396,7 +390,7 @@ struct NamespacePathEntry { /* * The data cached in an ensemble subcommand's Tcl_Obj rep (reference in - * otherValuePtr field). This structure is not shared between Tcl_Objs + * twoPtrValue.ptr1 field). This structure is not shared between Tcl_Objs * referring to the same subcommand, even where one is a duplicate of another. */ @@ -589,30 +583,6 @@ typedef struct ActiveVarTrace { } ActiveVarTrace; /* - * The following structure describes an enumerative search in progress on an - * array variable; this are invoked with options to the "array" command. - */ - -typedef struct ArraySearch { - int id; /* Integer id used to distinguish among - * multiple concurrent searches for the same - * array. */ - struct Var *varPtr; /* Pointer to array variable that's being - * searched. */ - Tcl_HashSearch search; /* Info kept by the hash module about progress - * through the array. */ - Tcl_HashEntry *nextEntry; /* Non-null means this is the next element to - * be enumerated (it's leftover from the - * Tcl_FirstHashEntry call or from an "array - * anymore" command). NULL means must call - * Tcl_NextHashEntry to get value to - * return. */ - struct ArraySearch *nextPtr;/* Next in list of all active searches for - * this variable, or NULL if this is the last - * one. */ -} ArraySearch; - -/* * The structure below defines a variable, which associates a string name with * a Tcl_Obj value. These structures are kept in procedure call frames (for * local variables recognized by the compiler) or in the heap (for global @@ -1205,29 +1175,27 @@ typedef struct CmdFrame { * * EXECUTION CONTEXTS and usage of CmdFrame * - * Field TEBC EvalEx EvalObjEx - * ======= ==== ====== ========= - * level yes yes yes - * type BC/PREBC SRC/EVAL EVAL_LIST - * line0 yes yes yes - * framePtr yes yes yes - * ======= ==== ====== ========= + * Field TEBC EvalEx + * ======= ==== ====== + * level yes yes + * type BC/PREBC SRC/EVAL + * line0 yes yes + * framePtr yes yes + * ======= ==== ====== * - * ======= ==== ====== ========= union data - * line1 - yes - - * line3 - yes - - * path - yes - - * ------- ---- ------ --------- - * codePtr yes - - - * pc yes - - - * ======= ==== ====== ========= + * ======= ==== ========= union data + * line1 - yes + * line3 - yes + * path - yes + * ------- ---- ------ + * codePtr yes - + * pc yes - + * ======= ==== ====== * - * ======= ==== ====== ========= | union cmd - * listPtr - - yes | - * ------- ---- ------ --------- | - * cmd yes yes - | - * cmdlen yes yes - | - * ------- ---- ------ --------- | + * ======= ==== ========= union cmd + * str.cmd yes yes + * str.len yes yes + * ------- ---- ------ */ union { @@ -1240,15 +1208,9 @@ typedef struct CmdFrame { const char *pc; /* ... and instruction pointer. */ } tebc; } data; - union { - struct { - const char *cmd; /* The executed command, if possible... */ - int len; /* ... and its length. */ - } str; - Tcl_Obj *listPtr; /* Tcl_EvalObjEx, cmd list. */ - } cmd; - int numLevels; /* Value of interp's numLevels when the frame - * was pushed. */ + Tcl_Obj *cmdObj; + const char *cmd; /* The executed command, if possible... */ + int len; /* ... and its length. */ const struct CFWordBC *litarg; /* Link to set of literal arguments which have * ben pushed on the lineLABCPtr stack by @@ -1312,8 +1274,6 @@ typedef struct ContLineLoc { * location data referenced via the 'baseLocPtr'. * * TCL_LOCATION_EVAL : Frame is for a script evaluated by EvalEx. - * TCL_LOCATION_EVAL_LIST : Frame is for a script evaluated by the list - * optimization path of EvalObjEx. * TCL_LOCATION_BC : Frame is for bytecode. * TCL_LOCATION_PREBC : Frame is for precompiled bytecode. * TCL_LOCATION_SOURCE : Frame is for a script evaluated by EvalEx, from a @@ -1325,8 +1285,6 @@ typedef struct ContLineLoc { */ #define TCL_LOCATION_EVAL (0) /* Location in a dynamic eval script. */ -#define TCL_LOCATION_EVAL_LIST (1) /* Location in a dynamic eval script, - * list-path. */ #define TCL_LOCATION_BC (2) /* Location in byte code. */ #define TCL_LOCATION_PREBC (3) /* Location in precompiled byte code, no * location. */ @@ -1714,6 +1672,9 @@ typedef struct Command { * CMD_HAS_EXEC_TRACES - 1 means that this command has at least one * execution trace (as opposed to simple * delete/rename traces) in its tracePtr list. + * CMD_COMPILES_EXPANDED - 1 means that this command has a compiler that + * can handle expansion (provided it is not the + * first word). * TCL_TRACE_RENAME - A rename trace is in progress. Further * recursive renames will not be traced. * TCL_TRACE_DELETE - A delete trace is in progress. Further @@ -1724,6 +1685,8 @@ typedef struct Command { #define CMD_IS_DELETED 0x1 #define CMD_TRACE_ACTIVE 0x2 #define CMD_HAS_EXEC_TRACES 0x4 +#define CMD_COMPILES_EXPANDED 0x8 +#define CMD_REDEF_IN_PROGRESS 0x10 /* *---------------------------------------------------------------- @@ -1847,7 +1810,14 @@ typedef struct Interp { ClientData interpInfo; /* Information used by tclInterp.c to keep * track of master/slave interps on a * per-interp basis. */ - Tcl_HashTable unused2; /* No longer used (was mathFuncTable) */ + union { + void (*optimizer)(void *envPtr); + Tcl_HashTable unused2; /* No longer used (was mathFuncTable). The + * unused space in interp was repurposed for + * pluggable bytecode optimizers. The core + * contains one optimizer, which can be + * selectively overriden by extensions. */ + } extra; /* * Information related to procedures and variables. See tclProc.c and @@ -2202,17 +2172,6 @@ typedef struct Interp { (iPtr)->flags &= (~(CANCELED | TCL_CANCEL_UNWIND)) /* - * General list of interpreters. Doubly linked for easier removal of items - * deep in the list. - */ - -typedef struct InterpList { - Interp *interpPtr; - struct InterpList *prevPtr; - struct InterpList *nextPtr; -} InterpList; - -/* * Macros for splicing into and out of doubly linked lists. They assume * existence of struct items 'prevPtr' and 'nextPtr'. * @@ -2247,9 +2206,10 @@ typedef struct InterpList { * other than these should be turned into errors. */ -#define TCL_ALLOW_EXCEPTIONS 4 -#define TCL_EVAL_FILE 2 -#define TCL_EVAL_CTX 8 +#define TCL_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: @@ -2317,35 +2277,6 @@ typedef struct InterpList { #define MAX_NESTING_DEPTH 1000 /* - * TIP#143 limit handler internal representation. - */ - -struct LimitHandler { - int flags; /* The state of this particular handler. */ - Tcl_LimitHandlerProc *handlerProc; - /* The handler callback. */ - ClientData clientData; /* Opaque argument to the handler callback. */ - Tcl_LimitHandlerDeleteProc *deleteProc; - /* How to delete the clientData. */ - LimitHandler *prevPtr; /* Previous item in linked list of - * handlers. */ - LimitHandler *nextPtr; /* Next item in linked list of handlers. */ -}; - -/* - * Values for the LimitHandler flags field. - * LIMIT_HANDLER_ACTIVE - Whether the handler is currently being - * processed; handlers are never to be entered reentrantly. - * LIMIT_HANDLER_DELETED - Whether the handler has been deleted. This - * should not normally be observed because when a handler is - * deleted it is also spliced out of the list of handlers, but - * even so we will be careful. - */ - -#define LIMIT_HANDLER_ACTIVE 0x01 -#define LIMIT_HANDLER_DELETED 0x02 - -/* * The macro below is used to modify a "char" value (e.g. by casting it to an * unsigned character) so that it can be used safely with macros such as * isspace. @@ -2522,6 +2453,30 @@ typedef struct List { #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); + */ + +#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 */ + +/* * Flag values for TclTraceDictPath(). * * DICT_PATH_READ indicates that all entries on the path must exist but no @@ -2709,6 +2664,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. @@ -2735,7 +2692,7 @@ MODULE_SCOPE const Tcl_ObjType tclProcBodyType; MODULE_SCOPE const Tcl_ObjType tclStringType; MODULE_SCOPE const Tcl_ObjType tclArraySearchType; MODULE_SCOPE const Tcl_ObjType tclEnsembleCmdType; -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG MODULE_SCOPE const Tcl_ObjType tclWideIntType; #endif MODULE_SCOPE const Tcl_ObjType tclRegexpType; @@ -2803,6 +2760,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRInvoke; MODULE_SCOPE void TclSetTailcall(Tcl_Interp *interp, Tcl_Obj *tailcallPtr); MODULE_SCOPE void TclPushTailcallPoint(Tcl_Interp *interp); @@ -2894,7 +2852,7 @@ MODULE_SCOPE void TclArgumentRelease(Tcl_Interp *interp, Tcl_Obj *objv[], int objc); MODULE_SCOPE void TclArgumentBCEnter(Tcl_Interp *interp, Tcl_Obj *objv[], int objc, - void *codePtr, CmdFrame *cfPtr, int pc); + void *codePtr, CmdFrame *cfPtr, int cmd, int pc); MODULE_SCOPE void TclArgumentBCRelease(Tcl_Interp *interp, CmdFrame *cfPtr); MODULE_SCOPE void TclArgumentGet(Tcl_Interp *interp, Tcl_Obj *obj, @@ -2923,6 +2881,10 @@ MODULE_SCOPE void TclContinuationsCopy(Tcl_Obj *objPtr, MODULE_SCOPE int TclConvertElement(const char *src, int length, char *dst, int flags); MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr); +MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp, + const char *dict, int dictLength, + const char **elementPtr, const char **nextPtr, + int *sizePtr, int *literalPtr); /* TIP #280 - Modified token based evulation, with line information. */ MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script, int numBytes, int flags, int line, @@ -2962,6 +2924,7 @@ MODULE_SCOPE void TclFinalizeObjects(void); MODULE_SCOPE void TclFinalizePreserve(void); MODULE_SCOPE void TclFinalizeSynchronization(void); MODULE_SCOPE void TclFinalizeThreadAlloc(void); +MODULE_SCOPE void TclFinalizeThreadAllocThread(void); MODULE_SCOPE void TclFinalizeThreadData(void); MODULE_SCOPE void TclFinalizeThreadObjects(void); MODULE_SCOPE double TclFloor(const mp_int *a); @@ -2985,7 +2948,10 @@ 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 TclGlob(Tcl_Interp *interp, char *pattern, Tcl_Obj *unquotedPrefix, int globFlags, Tcl_GlobTypeData *types); @@ -3134,6 +3100,7 @@ MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp, Tcl_Obj *cmdPrefix); MODULE_SCOPE void TclSetBignumIntRep(Tcl_Obj *objPtr, mp_int *bignumValue); +MODULE_SCOPE int TclSetBooleanFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); MODULE_SCOPE void TclSetCmdNameObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Command *cmdPtr); MODULE_SCOPE void TclSetDuplicateObj(Tcl_Obj *dupPtr, Tcl_Obj *objPtr); @@ -3162,6 +3129,7 @@ MODULE_SCOPE int TclTrimLeft(const char *bytes, int numBytes, const char *trim, int numTrim); MODULE_SCOPE int TclTrimRight(const char *bytes, int numBytes, const char *trim, int numTrim); +MODULE_SCOPE int TclUtfCasecmp(const char *cs, const char *ct); MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(ClientData clientData); MODULE_SCOPE Tcl_Obj * TclpFilesystemPathType(Tcl_Obj *pathPtr); MODULE_SCOPE int TclpDlopen(Tcl_Interp *interp, Tcl_Obj *pathPtr, @@ -3508,6 +3476,9 @@ MODULE_SCOPE int TclCompileBreakCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileCatchCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileConcatCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileContinueCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); @@ -3607,6 +3578,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); @@ -3631,6 +3605,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); @@ -3646,6 +3623,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); @@ -3673,6 +3656,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); @@ -3688,6 +3674,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); @@ -3718,6 +3725,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); @@ -3931,6 +3941,8 @@ MODULE_SCOPE int TclPtrUnsetVar(Tcl_Interp *interp, Var *varPtr, Tcl_Obj *part2Ptr, const int flags, int index); MODULE_SCOPE void TclInvalidateNsPath(Namespace *nsPtr); +MODULE_SCOPE void TclFindArrayPtrElements(Var *arrayPtr, + Tcl_HashTable *tablePtr); /* * The new extended interface to the variable traces. @@ -4088,7 +4100,7 @@ MODULE_SCOPE void TclpFreeAllocCache(void *); (objPtr) = TclThreadAllocObj(); \ } else { \ (objPtr) = cachePtr->firstObjPtr; \ - cachePtr->firstObjPtr = (objPtr)->internalRep.otherValuePtr; \ + cachePtr->firstObjPtr = (objPtr)->internalRep.twoPtrValue.ptr1; \ --cachePtr->numObjects; \ } \ } while (0) @@ -4101,7 +4113,7 @@ MODULE_SCOPE void TclpFreeAllocCache(void *); (cachePtr->numObjects >= ALLOC_NOBJHIGH))) { \ TclThreadFreeObj(objPtr); \ } else { \ - (objPtr)->internalRep.otherValuePtr = cachePtr->firstObjPtr; \ + (objPtr)->internalRep.twoPtrValue.ptr1 = cachePtr->firstObjPtr; \ cachePtr->firstObjPtr = objPtr; \ ++cachePtr->numObjects; \ } \ @@ -4129,14 +4141,14 @@ MODULE_SCOPE Tcl_Mutex tclObjMutex; } \ (objPtr) = tclFreeObjList; \ tclFreeObjList = (Tcl_Obj *) \ - tclFreeObjList->internalRep.otherValuePtr; \ + tclFreeObjList->internalRep.twoPtrValue.ptr1; \ Tcl_MutexUnlock(&tclObjMutex); \ } while (0) # define TclFreeObjStorageEx(interp, objPtr) \ do { \ Tcl_MutexLock(&tclObjMutex); \ - (objPtr)->internalRep.otherValuePtr = (void *) tclFreeObjList; \ + (objPtr)->internalRep.twoPtrValue.ptr1 = (void *) tclFreeObjList; \ tclFreeObjList = (objPtr); \ Tcl_MutexUnlock(&tclObjMutex); \ } while (0) @@ -4471,7 +4483,7 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; *---------------------------------------------------------------- */ -#define TclSetIntObj(objPtr, i) \ +#define TclSetLongObj(objPtr, i) \ do { \ TclInvalidateStringRep(objPtr); \ TclFreeIntRep(objPtr); \ @@ -4479,8 +4491,8 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; (objPtr)->typePtr = &tclIntType; \ } while (0) -#define TclSetLongObj(objPtr, l) \ - TclSetIntObj((objPtr), (l)) +#define TclSetIntObj(objPtr, l) \ + TclSetLongObj(objPtr, l) /* * NOTE: There is to be no such thing as a "pure" boolean. Boolean values set @@ -4490,9 +4502,9 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; */ #define TclSetBooleanObj(objPtr, b) \ - TclSetIntObj((objPtr), ((b)? 1 : 0)); + TclSetLongObj(objPtr, (b)!=0); -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG #define TclSetWideIntObj(objPtr, w) \ do { \ TclInvalidateStringRep(objPtr); \ @@ -4528,7 +4540,7 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; */ #ifndef TCL_MEM_DEBUG -#define TclNewIntObj(objPtr, i) \ +#define TclNewLongObj(objPtr, i) \ do { \ TclIncrObjsAllocated(); \ TclAllocObjStorage(objPtr); \ @@ -4539,15 +4551,15 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; TCL_DTRACE_OBJ_CREATE(objPtr); \ } while (0) -#define TclNewLongObj(objPtr, l) \ - TclNewIntObj((objPtr), (l)) +#define TclNewIntObj(objPtr, l) \ + TclNewLongObj(objPtr, l) /* * NOTE: There is to be no such thing as a "pure" boolean. * See comment above TclSetBooleanObj macro above. */ #define TclNewBooleanObj(objPtr, b) \ - TclNewIntObj((objPtr), ((b)? 1 : 0)) + TclNewLongObj((objPtr), (b)!=0) #define TclNewDoubleObj(objPtr, d) \ do { \ diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 092225e..f95f999 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -52,6 +52,10 @@ /* !BEGIN!: Do not edit below this line. */ +#ifdef __cplusplus +extern "C" { +#endif + /* * Exported function declarations: */ @@ -396,8 +400,10 @@ EXTERN void TclRegError(Tcl_Interp *interp, const char *msg, /* 157 */ EXTERN Var * TclVarTraceExists(Tcl_Interp *interp, const char *varName); -/* Slot 158 is reserved */ -/* Slot 159 is reserved */ +/* 158 */ +EXTERN void TclSetStartupScriptFileName(const char *filename); +/* 159 */ +EXTERN const char * TclGetStartupScriptFileName(void); /* Slot 160 is reserved */ /* 161 */ EXTERN int TclChannelTransform(Tcl_Interp *interp, @@ -415,8 +421,10 @@ EXTERN void TclpSetInitialEncodings(void); EXTERN int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr); -/* Slot 167 is reserved */ -/* Slot 168 is reserved */ +/* 167 */ +EXTERN void TclSetStartupScriptPath(Tcl_Obj *pathPtr); +/* 168 */ +EXTERN Tcl_Obj * TclGetStartupScriptPath(void); /* 169 */ EXTERN int TclpUtfNcmp2(const char *s1, const char *s2, unsigned long n); @@ -606,6 +614,9 @@ EXTERN char * TclDoubleDigits(double dv, int ndigits, int flags, /* 250 */ EXTERN void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags, int force); +/* 251 */ +EXTERN int TclRegisterLiteral(void *envPtr, char *bytes, + int length, int flags); typedef struct TclIntStubs { int magic; @@ -769,8 +780,8 @@ typedef struct TclIntStubs { void (*reserved155)(void); void (*tclRegError) (Tcl_Interp *interp, const char *msg, int status); /* 156 */ Var * (*tclVarTraceExists) (Tcl_Interp *interp, const char *varName); /* 157 */ - void (*reserved158)(void); - void (*reserved159)(void); + void (*tclSetStartupScriptFileName) (const char *filename); /* 158 */ + const char * (*tclGetStartupScriptFileName) (void); /* 159 */ void (*reserved160)(void); int (*tclChannelTransform) (Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr); /* 161 */ void (*tclChannelEventScriptInvoker) (ClientData clientData, int flags); /* 162 */ @@ -778,8 +789,8 @@ typedef struct TclIntStubs { void (*tclExpandCodeArray) (void *envPtr); /* 164 */ void (*tclpSetInitialEncodings) (void); /* 165 */ int (*tclListObjSetElement) (Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr); /* 166 */ - void (*reserved167)(void); - void (*reserved168)(void); + void (*tclSetStartupScriptPath) (Tcl_Obj *pathPtr); /* 167 */ + Tcl_Obj * (*tclGetStartupScriptPath) (void); /* 168 */ int (*tclpUtfNcmp2) (const char *s1, const char *s2, unsigned long n); /* 169 */ int (*tclCheckInterpTraces) (Tcl_Interp *interp, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 170 */ int (*tclCheckExecutionTraces) (Tcl_Interp *interp, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 171 */ @@ -862,12 +873,11 @@ typedef struct TclIntStubs { int (*tclCopyChannel) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr); /* 248 */ char * (*tclDoubleDigits) (double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 249 */ void (*tclSetSlaveCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */ + int (*tclRegisterLiteral) (void *envPtr, char *bytes, int length, int flags); /* 251 */ } TclIntStubs; -#ifdef __cplusplus -extern "C" { -#endif extern const TclIntStubs *tclIntStubsPtr; + #ifdef __cplusplus } #endif @@ -1135,8 +1145,10 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclRegError) /* 156 */ #define TclVarTraceExists \ (tclIntStubsPtr->tclVarTraceExists) /* 157 */ -/* Slot 158 is reserved */ -/* Slot 159 is reserved */ +#define TclSetStartupScriptFileName \ + (tclIntStubsPtr->tclSetStartupScriptFileName) /* 158 */ +#define TclGetStartupScriptFileName \ + (tclIntStubsPtr->tclGetStartupScriptFileName) /* 159 */ /* Slot 160 is reserved */ #define TclChannelTransform \ (tclIntStubsPtr->tclChannelTransform) /* 161 */ @@ -1150,8 +1162,10 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclpSetInitialEncodings) /* 165 */ #define TclListObjSetElement \ (tclIntStubsPtr->tclListObjSetElement) /* 166 */ -/* Slot 167 is reserved */ -/* Slot 168 is reserved */ +#define TclSetStartupScriptPath \ + (tclIntStubsPtr->tclSetStartupScriptPath) /* 167 */ +#define TclGetStartupScriptPath \ + (tclIntStubsPtr->tclGetStartupScriptPath) /* 168 */ #define TclpUtfNcmp2 \ (tclIntStubsPtr->tclpUtfNcmp2) /* 169 */ #define TclCheckInterpTraces \ @@ -1289,6 +1303,8 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclDoubleDigits) /* 249 */ #define TclSetSlaveCancelFlags \ (tclIntStubsPtr->tclSetSlaveCancelFlags) /* 250 */ +#define TclRegisterLiteral \ + (tclIntStubsPtr->tclRegisterLiteral) /* 251 */ #endif /* defined(USE_TCL_STUBS) */ @@ -1297,6 +1313,10 @@ 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) @@ -1344,4 +1364,7 @@ extern const TclIntStubs *tclIntStubsPtr; (tclStubsPtr->tcl_GetCommandFullName) /* 517 */ #endif +#undef TclCopyChannelOld +#undef TclSockMinimumBuffersOld + #endif /* _TCLINTDECLS */ diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index dcf1753..ac06787 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -13,7 +13,7 @@ #ifndef _TCLINTPLATDECLS #define _TCLINTPLATDECLS -#ifdef __WIN32__ +#ifdef _WIN32 # define Tcl_DirEntry void # define DIR void #endif @@ -37,11 +37,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); @@ -100,7 +104,7 @@ 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 */ @@ -254,7 +258,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 */ @@ -287,7 +291,7 @@ typedef struct TclIntPlatStubs { int (*tclWinCPUID) (unsigned int index, unsigned 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 */ @@ -355,10 +359,8 @@ typedef struct TclIntPlatStubs { #endif /* MACOSX */ } TclIntPlatStubs; -#ifdef __cplusplus -extern "C" { -#endif extern const TclIntPlatStubs *tclIntPlatStubsPtr; + #ifdef __cplusplus } #endif @@ -369,7 +371,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 +420,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 \ @@ -545,10 +547,18 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #undef TclpGmtime_unix #undef TclWinConvertWSAError #define TclWinConvertWSAError TclWinConvertError +#undef TclpInetNtoa +#define TclpInetNtoa inet_ntoa -#if defined(__WIN32__) || defined(__CYGWIN__) +#if defined(_WIN32) # undef TclWinNToHS +# undef TclWinGetServByName +# undef TclWinGetSockOpt +# undef TclWinSetSockOpt # define TclWinNToHS ntohs +# define TclWinGetServByName getservbyname +# define TclWinGetSockOpt getsockopt +# define TclWinSetSockOpt setsockopt #else # undef TclpGetPid # define TclpGetPid(pid) ((unsigned long) (pid)) diff --git a/generic/tclInterp.c b/generic/tclInterp.c index d5d43ed..0da5d47 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -179,6 +179,37 @@ typedef struct ScriptLimitCallbackKey { } ScriptLimitCallbackKey; /* + * TIP#143 limit handler internal representation. + */ + +struct LimitHandler { + int flags; /* The state of this particular handler. */ + Tcl_LimitHandlerProc *handlerProc; + /* The handler callback. */ + ClientData clientData; /* Opaque argument to the handler callback. */ + Tcl_LimitHandlerDeleteProc *deleteProc; + /* How to delete the clientData. */ + LimitHandler *prevPtr; /* Previous item in linked list of + * handlers. */ + LimitHandler *nextPtr; /* Next item in linked list of handlers. */ +}; + +/* + * Values for the LimitHandler flags field. + * LIMIT_HANDLER_ACTIVE - Whether the handler is currently being + * processed; handlers are never to be entered reentrantly. + * LIMIT_HANDLER_DELETED - Whether the handler has been deleted. This + * should not normally be observed because when a handler is + * deleted it is also spliced out of the list of handlers, but + * even so we will be careful. + */ + +#define LIMIT_HANDLER_ACTIVE 0x01 +#define LIMIT_HANDLER_DELETED 0x02 + + + +/* * Prototypes for local static functions: */ @@ -248,6 +279,12 @@ static void DeleteScriptLimitCallback(ClientData clientData); static void RunLimitHandlers(LimitHandler *handlerPtr, Tcl_Interp *interp); static void TimeLimitCallback(ClientData clientData); + +/* NRE enabling */ +static Tcl_NRPostProc NRPostInvokeHidden; +static Tcl_ObjCmdProc NRInterpCmd; +static Tcl_ObjCmdProc NRSlaveCmd; + /* *---------------------------------------------------------------------- @@ -450,7 +487,8 @@ TclInterpInit( slavePtr->interpCmd = NULL; Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); - Tcl_CreateObjCommand(interp, "interp", Tcl_InterpObjCmd, NULL, NULL); + Tcl_NRCreateCommand(interp, "interp", Tcl_InterpObjCmd, NRInterpCmd, + NULL, NULL); Tcl_CallWhenDeleted(interp, InterpInfoDeleteProc, NULL); return TCL_OK; @@ -559,6 +597,16 @@ Tcl_InterpObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + return Tcl_NRCallObjProc(interp, NRInterpCmd, clientData, objc, objv); +} + +static int +NRInterpCmd( + ClientData clientData, /* Unused. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ Tcl_Interp *slaveInterp; int index; static const char *const options[] = { @@ -2341,8 +2389,8 @@ SlaveCreate( slavePtr->masterInterp = masterInterp; slavePtr->slaveEntryPtr = hPtr; slavePtr->slaveInterp = slaveInterp; - slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, path, - SlaveObjCmd, slaveInterp, SlaveObjCmdDeleteProc); + slavePtr->interpCmd = Tcl_NRCreateCommand(masterInterp, path, + SlaveObjCmd, NRSlaveCmd, slaveInterp, SlaveObjCmdDeleteProc); Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); Tcl_SetHashValue(hPtr, slavePtr); Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); @@ -2431,6 +2479,16 @@ SlaveObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + return Tcl_NRCallObjProc(interp, NRSlaveCmd, clientData, objc, objv); +} + +static int +NRSlaveCmd( + ClientData clientData, /* Slave interpreter. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ Tcl_Interp *slaveInterp = clientData; int index; static const char *const options[] = { @@ -3021,7 +3079,11 @@ SlaveInvokeHidden( Tcl_AllowExceptions(slaveInterp); if (namespaceName == NULL) { - result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN); + NRE_callback *rootPtr = TOP_CB(slaveInterp); + + Tcl_NRAddCallback(interp, NRPostInvokeHidden, slaveInterp, + rootPtr, NULL, NULL); + return TclNRInvoke(NULL, slaveInterp, objc, objv); } else { Namespace *nsPtr, *dummy1, *dummy2; const char *tail; @@ -3040,6 +3102,23 @@ SlaveInvokeHidden( Tcl_Release(slaveInterp); return result; } + +static int +NRPostInvokeHidden( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_Interp *slaveInterp = (Tcl_Interp *)data[0]; + NRE_callback *rootPtr = (NRE_callback *)data[1]; + + if (interp != slaveInterp) { + result = TclNRRunCallbacks(slaveInterp, result, rootPtr); + Tcl_TransferResult(slaveInterp, result, interp); + } + Tcl_Release(slaveInterp); + return result; +} /* *---------------------------------------------------------------------- diff --git a/generic/tclLink.c b/generic/tclLink.c index a3b42bd..2735256 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -112,8 +112,8 @@ Tcl_LinkVar( Link *linkPtr; int code; - linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY, - LinkTraceProc, (ClientData) NULL); + linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL, + TCL_GLOBAL_ONLY, LinkTraceProc, (ClientData) NULL); if (linkPtr != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "variable '%s' is already linked", varName)); @@ -138,8 +138,9 @@ Tcl_LinkVar( ckfree(linkPtr); return TCL_ERROR; } - code = Tcl_TraceVar(interp, varName, TCL_GLOBAL_ONLY|TCL_TRACE_READS - |TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, linkPtr); + code = Tcl_TraceVar2(interp, varName, NULL, + TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + LinkTraceProc, linkPtr); if (code != TCL_OK) { Tcl_DecrRefCount(linkPtr->varName); ckfree(linkPtr); @@ -170,13 +171,13 @@ Tcl_UnlinkVar( Tcl_Interp *interp, /* Interpreter containing variable to unlink */ const char *varName) /* Global variable in interp to unlink. */ { - Link *linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, + Link *linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL, TCL_GLOBAL_ONLY, LinkTraceProc, NULL); if (linkPtr == NULL) { return; } - Tcl_UntraceVar(interp, varName, + Tcl_UntraceVar2(interp, varName, NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, linkPtr); Tcl_DecrRefCount(linkPtr->varName); @@ -207,7 +208,7 @@ Tcl_UpdateLinkedVar( Tcl_Interp *interp, /* Interpreter containing variable. */ const char *varName) /* Name of global variable that is linked. */ { - Link *linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, + Link *linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL, TCL_GLOBAL_ONLY, LinkTraceProc, NULL); int savedFlag; @@ -221,8 +222,8 @@ Tcl_UpdateLinkedVar( /* * Callback may have unlinked the variable. [Bug 1740631] */ - linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY, - LinkTraceProc, NULL); + linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL, + TCL_GLOBAL_ONLY, LinkTraceProc, NULL); if (linkPtr != NULL) { linkPtr->flags = (linkPtr->flags & ~LINK_BEING_UPDATED) | savedFlag; } @@ -278,7 +279,7 @@ LinkTraceProc( } else if (flags & TCL_TRACE_DESTROYED) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); - Tcl_TraceVar(interp, Tcl_GetString(linkPtr->varName), + Tcl_TraceVar2(interp, Tcl_GetString(linkPtr->varName), NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES |TCL_TRACE_UNSETS, LinkTraceProc, linkPtr); } diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 2d1defa..bd2dbc4 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -237,7 +237,7 @@ Tcl_NewListObj( * Now create the object. */ - Tcl_InvalidateStringRep(listPtr); + TclInvalidateStringRep(listPtr); ListSetIntRep(listPtr, listRepPtr); return listPtr; } @@ -302,7 +302,7 @@ Tcl_DbNewListObj( * Now create the object. */ - Tcl_InvalidateStringRep(listPtr); + TclInvalidateStringRep(listPtr); ListSetIntRep(listPtr, listRepPtr); return listPtr; @@ -362,7 +362,7 @@ Tcl_SetListObj( */ TclFreeIntRep(objPtr); - Tcl_InvalidateStringRep(objPtr); + TclInvalidateStringRep(objPtr); /* * Set the object's type to "list" and initialize the internal rep. @@ -697,7 +697,7 @@ Tcl_ListObjAppendElement( * representation has changed. */ - Tcl_InvalidateStringRep(listPtr); + TclInvalidateStringRep(listPtr); return TCL_OK; } @@ -1057,7 +1057,7 @@ Tcl_ListObjReplace( * reflects the list's internal representation. */ - Tcl_InvalidateStringRep(listPtr); + TclInvalidateStringRep(listPtr); return TCL_OK; } @@ -1523,7 +1523,7 @@ TclLsetFlat( * containing lists. */ - Tcl_InvalidateStringRep(objPtr); + TclInvalidateStringRep(objPtr); } /* @@ -1559,7 +1559,7 @@ TclLsetFlat( } else { TclListObjSetElement(NULL, subListPtr, index, valuePtr); } - Tcl_InvalidateStringRep(subListPtr); + TclInvalidateStringRep(subListPtr); Tcl_IncrRefCount(retValuePtr); return retValuePtr; } @@ -1736,8 +1736,6 @@ FreeListInternalRep( ckfree(listRepPtr); } - listPtr->internalRep.twoPtrValue.ptr1 = NULL; - listPtr->internalRep.twoPtrValue.ptr2 = NULL; listPtr->typePtr = NULL; } diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index 441ea91..2b0cc7e 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -32,6 +32,10 @@ static int AddLocalLiteralEntry(CompileEnv *envPtr, Tcl_Obj *objPtr, int localHash); static void ExpandLocalLiteralArray(CompileEnv *envPtr); static unsigned HashString(const char *string, int length); +#ifdef TCL_COMPILE_DEBUG +static LiteralEntry * LookupLiteralEntry(Tcl_Interp *interp, + Tcl_Obj *objPtr); +#endif static void RebuildLiteralTable(LiteralTable *tablePtr); /* @@ -239,7 +243,7 @@ TclCreateLiteral( } #ifdef TCL_COMPILE_DEBUG - if (TclLookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) { + if (LookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) { Tcl_Panic("%s: literal \"%.*s\" found globally but shouldn't be", "TclRegisterLiteral", (length>60? 60 : length), bytes); } @@ -301,6 +305,33 @@ TclCreateLiteral( /* *---------------------------------------------------------------------- * + * TclFetchLiteral -- + * + * Fetch from a CompileEnv the literal value identified by an index + * value, as returned by a prior call to TclRegisterLiteral(). + * + * Results: + * The literal value, or NULL if the index is out of range. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclFetchLiteral( + CompileEnv *envPtr, /* Points to the CompileEnv from which to + * fetch the registered literal value. */ + unsigned int index) /* Index of the desired literal, as returned + * by prior call to TclRegisterLiteral() */ +{ + if (index >= (unsigned int) envPtr->literalArrayNext) { + return NULL; + } + return envPtr->literalArrayPtr[index].objPtr; +} + +/* + *---------------------------------------------------------------------- + * * TclRegisterLiteral -- * * Find, or if necessary create, an object in a CompileEnv literal array @@ -327,7 +358,7 @@ TclCreateLiteral( int TclRegisterLiteral( - CompileEnv *envPtr, /* Points to the CompileEnv in whose object + void *ePtr, /* Points to the CompileEnv in whose object * array an object is found or created. */ register char *bytes, /* Points to string for which to find or * create an object in CompileEnv's object @@ -341,6 +372,7 @@ TclRegisterLiteral( * the literal should not be shared accross * namespaces. */ { + CompileEnv *envPtr = ePtr; Interp *iPtr = envPtr->iPtr; LiteralTable *localTablePtr = &envPtr->localLitTable; LiteralEntry *globalPtr, *localPtr; @@ -414,10 +446,11 @@ TclRegisterLiteral( return objIndex; } +#ifdef TCL_COMPILE_DEBUG /* *---------------------------------------------------------------------- * - * TclLookupLiteralEntry -- + * LookupLiteralEntry -- * * Finds the LiteralEntry that corresponds to a literal Tcl object * holding a literal. @@ -431,8 +464,8 @@ TclRegisterLiteral( *---------------------------------------------------------------------- */ -LiteralEntry * -TclLookupLiteralEntry( +static LiteralEntry * +LookupLiteralEntry( Tcl_Interp *interp, /* Interpreter for which objPtr was created to * hold a literal. */ register Tcl_Obj *objPtr) /* Points to a Tcl object holding a literal @@ -456,6 +489,7 @@ TclLookupLiteralEntry( return NULL; } +#endif /* *---------------------------------------------------------------------- * @@ -750,11 +784,16 @@ TclReleaseLiteral( * TclRegisterLiteral. */ { Interp *iPtr = (Interp *) interp; - LiteralTable *globalTablePtr = &iPtr->literalTable; + LiteralTable *globalTablePtr; register LiteralEntry *entryPtr, *prevPtr; const char *bytes; int length, index; + if (iPtr == NULL) { + goto done; + } + + globalTablePtr = &iPtr->literalTable; bytes = TclGetStringFromObj(objPtr, &length); index = (HashString(bytes, length) & globalTablePtr->mask); @@ -798,6 +837,7 @@ TclReleaseLiteral( * Remove the reference corresponding to the local literal table entry. */ + done: Tcl_DecrRefCount(objPtr); } @@ -971,8 +1011,13 @@ TclInvalidateCmdLiteral( Tcl_Obj *literalObjPtr = TclCreateLiteral(iPtr, (char *) name, strlen(name), -1, NULL, nsPtr, 0, NULL); - if (literalObjPtr != NULL && literalObjPtr->typePtr == &tclCmdNameType) { - TclFreeIntRep(literalObjPtr); + if (literalObjPtr != NULL) { + if (literalObjPtr->typePtr == &tclCmdNameType) { + TclFreeIntRep(literalObjPtr); + } + /* Balance the refcount effects of TclCreateLiteral() above */ + Tcl_IncrRefCount(literalObjPtr); + TclReleaseLiteral(interp, literalObjPtr); } } @@ -1090,7 +1135,7 @@ TclVerifyLocalLiteralTable( "TclVerifyLocalLiteralTable", (length>60? 60 : length), bytes, localPtr->refCount); } - if (TclLookupLiteralEntry((Tcl_Interp *) envPtr->iPtr, + if (LookupLiteralEntry((Tcl_Interp *) envPtr->iPtr, localPtr->objPtr) == NULL) { bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length); Tcl_Panic("%s: local literal \"%.*s\" is not global", diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 5cacab1..7c70e03 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -830,7 +830,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 @@ -1151,7 +1151,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 f030d89..c22c4c4 100644 --- a/generic/tclLoadNone.c +++ b/generic/tclLoadNone.c @@ -82,6 +82,39 @@ TclGuessPackageName( } /* + * These functions are fallbacks if we somehow determine that the platform can + * do loading from memory but the user wishes to disable it. They just report + * (gracefully) that they fail. + */ + +#ifdef TCL_LOAD_FROM_MEMORY + +MODULE_SCOPE void * +TclpLoadMemoryGetBuffer( + Tcl_Interp *interp, /* Dummy: unused by this implementation */ + int size) /* Dummy: unused by this implementation */ +{ + return NULL; +} + +MODULE_SCOPE int +TclpLoadMemory( + Tcl_Interp *interp, /* Used for error reporting. */ + void *buffer, /* Dummy: unused by this implementation */ + int size, /* Dummy: unused by this implementation */ + int codeSize, /* Dummy: unused by this implementation */ + Tcl_LoadHandle *loadHandle, /* Dummy: unused by this implementation */ + Tcl_FSUnloadFileProc **unloadProcPtr) + /* Dummy: unused by this implementation */ +{ + Tcl_SetObjResult(interp, Tcl_NewStringObj("dynamic loading from memory " + "is not available on this system", -1)); + return TCL_ERROR; +} + +#endif /* TCL_LOAD_FROM_MEMORY */ + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclMain.c b/generic/tclMain.c index f445383..360f5e9 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 @@ -313,6 +313,9 @@ Tcl_MainEx( Tcl_Channel chan; InteractiveState is; + TclpSetInitialEncodings(); + TclpFindExecutable((const char *)argv[0]); + Tcl_InitMemory(interp); is.interp = interp; @@ -640,7 +643,6 @@ Tcl_Main( * function to call after most initialization * but before starting to execute commands. */ { - Tcl_FindExecutable(argv[0]); Tcl_MainEx(argc, argv, appInitProc, Tcl_CreateInterp()); } #endif /* TCL_MAJOR_VERSION == 8 && !UNICODE */ diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 304487b..8f2f10e 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -171,7 +171,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}, @@ -505,9 +505,9 @@ EstablishErrorCodeTraces( const char *name2, int flags) { - Tcl_TraceVar(interp, "errorCode", TCL_GLOBAL_ONLY | TCL_TRACE_READS, + Tcl_TraceVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS, ErrorCodeRead, NULL); - Tcl_TraceVar(interp, "errorCode", TCL_GLOBAL_ONLY | TCL_TRACE_UNSETS, + Tcl_TraceVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_UNSETS, EstablishErrorCodeTraces, NULL); return NULL; } @@ -579,9 +579,9 @@ EstablishErrorInfoTraces( const char *name2, int flags) { - Tcl_TraceVar(interp, "errorInfo", TCL_GLOBAL_ONLY | TCL_TRACE_READS, + Tcl_TraceVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS, ErrorInfoRead, NULL); - Tcl_TraceVar(interp, "errorInfo", TCL_GLOBAL_ONLY | TCL_TRACE_UNSETS, + Tcl_TraceVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_UNSETS, EstablishErrorInfoTraces, NULL); return NULL; } @@ -673,6 +673,10 @@ Tcl_CreateNamespace( Tcl_DString *namePtr, *buffPtr; int newEntry, nameLen; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + const char *nameStr; + Tcl_DString tmpBuffer; + + Tcl_DStringInit(&tmpBuffer); /* * If there is no active namespace, the interpreter is being initialized. @@ -686,50 +690,78 @@ Tcl_CreateNamespace( parentPtr = NULL; simpleName = ""; - } else if (*name == '\0') { + goto doCreate; + } + + /* + * Ensure that there are no trailing colons as that causes chaos when a + * deleteProc is specified. [Bug d614d63989] + */ + + if (deleteProc != NULL) { + nameStr = name + strlen(name) - 2; + if (nameStr >= name && nameStr[1] == ':' && nameStr[0] == ':') { + Tcl_DStringAppend(&tmpBuffer, name, -1); + while ((nameLen = Tcl_DStringLength(&tmpBuffer)) > 0 + && Tcl_DStringValue(&tmpBuffer)[nameLen-1] == ':') { + Tcl_DStringSetLength(&tmpBuffer, nameLen-1); + } + name = Tcl_DStringValue(&tmpBuffer); + } + } + + /* + * If we've ended up with an empty string now, we're attempting to create + * the global namespace despite the global namespace existing. That's + * naughty! + */ + + if (*name == '\0') { Tcl_SetObjResult(interp, Tcl_NewStringObj("can't create namespace" " \"\": only global namespace can have empty name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", "CREATEGLOBAL", NULL); + Tcl_DStringFree(&tmpBuffer); return NULL; - } else { - /* - * Find the parent for the new namespace. - */ + } - TclGetNamespaceForQualName(interp, name, NULL, - /*flags*/ (TCL_CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG), - &parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName); + /* + * Find the parent for the new namespace. + */ - /* - * If the unqualified name at the end is empty, there were trailing - * "::"s after the namespace's name which we ignore. The new namespace - * was already (recursively) created and is pointed to by parentPtr. - */ + TclGetNamespaceForQualName(interp, name, NULL, TCL_CREATE_NS_IF_UNKNOWN, + &parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName); - if (*simpleName == '\0') { - return (Tcl_Namespace *) parentPtr; - } + /* + * If the unqualified name at the end is empty, there were trailing "::"s + * after the namespace's name which we ignore. The new namespace was + * already (recursively) created and is pointed to by parentPtr. + */ - /* - * Check for a bad namespace name and make sure that the name does not - * already exist in the parent namespace. - */ + if (*simpleName == '\0') { + Tcl_DStringFree(&tmpBuffer); + return (Tcl_Namespace *) parentPtr; + } - if ( + /* + * Check for a bad namespace name and make sure that the name does not + * already exist in the parent namespace. + */ + + if ( #ifndef BREAK_NAMESPACE_COMPAT - Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL + Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL #else - parentPtr->childTablePtr != NULL && - Tcl_FindHashEntry(parentPtr->childTablePtr, simpleName) != NULL + parentPtr->childTablePtr != NULL && + Tcl_FindHashEntry(parentPtr->childTablePtr, simpleName) != NULL #endif - ) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't create namespace \"%s\": already exists", name)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", - "CREATEEXISTING", NULL); - return NULL; - } + ) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create namespace \"%s\": already exists", name)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", + "CREATEEXISTING", NULL); + Tcl_DStringFree(&tmpBuffer); + return NULL; } /* @@ -737,6 +769,7 @@ Tcl_CreateNamespace( * of namespaces created. */ + doCreate: nsPtr = ckalloc(sizeof(Namespace)); nameLen = strlen(simpleName) + 1; nsPtr->name = ckalloc(nameLen); @@ -832,6 +865,7 @@ Tcl_CreateNamespace( Tcl_DStringFree(&buffer1); Tcl_DStringFree(&buffer2); + Tcl_DStringFree(&tmpBuffer); /* * If compilation of commands originating from the parent NS is @@ -1330,8 +1364,7 @@ Tcl_Export( * Check that the pattern doesn't have namespace qualifiers. */ - TclGetNamespaceForQualName(interp, pattern, nsPtr, - /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), + TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY, &exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) { @@ -1545,8 +1578,7 @@ Tcl_Import( Tcl_SetErrorCode(interp, "TCL", "IMPORT", "EMPTY", NULL); return TCL_ERROR; } - TclGetNamespaceForQualName(interp, pattern, nsPtr, - /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), + TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY, &importNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if (importNsPtr == NULL) { @@ -1791,8 +1823,7 @@ Tcl_ForgetImport( * simple pattern. */ - TclGetNamespaceForQualName(interp, pattern, nsPtr, - /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), + TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY, &sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if (sourceNsPtr == NULL) { @@ -1946,7 +1977,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); } static int @@ -3435,10 +3466,7 @@ NamespaceExportCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); - const char *pattern, *string; - int resetListFirst = 0; - int firstArg, patternCt, i, result; + int firstArg, i; if (objc < 1) { Tcl_WrongNumArgs(interp, 1, objv, "?-clear? ?pattern pattern...?"); @@ -3446,42 +3474,27 @@ NamespaceExportCmd( } /* - * Process the optional "-clear" argument. + * If no pattern arguments are given, and "-clear" isn't specified, return + * the namespace's current export pattern list. */ - firstArg = 1; - if (firstArg < objc) { - string = TclGetString(objv[firstArg]); - if (strcmp(string, "-clear") == 0) { - resetListFirst = 1; - firstArg++; - } + if (objc == 1) { + Tcl_Obj *listPtr = Tcl_NewObj(); + + (void) Tcl_AppendExportList(interp, NULL, listPtr); + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; } /* - * If no pattern arguments are given, and "-clear" isn't specified, return - * the namespace's current export pattern list. + * Process the optional "-clear" argument. */ - patternCt = objc - firstArg; - if (patternCt == 0) { - if (firstArg > 1) { - return TCL_OK; - } else { - /* - * Create list with export patterns. - */ - - Tcl_Obj *listPtr = Tcl_NewListObj(0, NULL); - - result = Tcl_AppendExportList(interp, (Tcl_Namespace *) currNsPtr, - listPtr); - if (result != TCL_OK) { - return result; - } - Tcl_SetObjResult(interp, listPtr); - return TCL_OK; - } + firstArg = 1; + if (strcmp("-clear", Tcl_GetString(objv[firstArg])) == 0) { + Tcl_Export(interp, NULL, "::", 1); + Tcl_ResetResult(interp); + firstArg++; } /* @@ -3489,9 +3502,7 @@ NamespaceExportCmd( */ for (i = firstArg; i < objc; i++) { - pattern = TclGetString(objv[i]); - result = Tcl_Export(interp, (Tcl_Namespace *) currNsPtr, pattern, - ((i == firstArg)? resetListFirst : 0)); + int result = Tcl_Export(interp, NULL, Tcl_GetString(objv[i]), 0); if (result != TCL_OK) { return result; } diff --git a/generic/tclNotify.c b/generic/tclNotify.c index a6523fc..e76bca8 100644 --- a/generic/tclNotify.c +++ b/generic/tclNotify.c @@ -813,11 +813,7 @@ Tcl_SetMaxBlockTime( */ if (!tsdPtr->inTraversal) { - if (tsdPtr->blockTimeSet) { - Tcl_SetTimer(&tsdPtr->blockTime); - } else { - Tcl_SetTimer(NULL); - } + Tcl_SetTimer(&tsdPtr->blockTime); } } diff --git a/generic/tclOO.c b/generic/tclOO.c index d6d2d6a..de00733 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -271,7 +271,7 @@ TclOOInit( return TCL_ERROR; } - return Tcl_PkgProvideEx(interp, "TclOO", TCLOO_VERSION, + return Tcl_PkgProvideEx(interp, "TclOO", TCLOO_PATCHLEVEL, (ClientData) &tclOOStubs); } @@ -437,10 +437,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; @@ -843,7 +845,7 @@ ObjectRenamedTrace( result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr, 0, NULL); if (result != TCL_OK) { - Tcl_BackgroundError(interp); + Tcl_BackgroundException(interp, result); } Tcl_RestoreInterpState(interp, state); TclOODeleteContext(contextPtr); diff --git a/generic/tclOO.decls b/generic/tclOO.decls index 31d1113..265ba88 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, @@ -116,7 +128,9 @@ declare 28 { } ###################################################################### -# private API, exposed to support advanced OO systems that plug in on top +# Private API, exposed to support advanced OO systems that plug in on top of +# TclOO; not intended for general use and does not have any commitment to +# long-term support. # interface tclOOInt diff --git a/generic/tclOO.h b/generic/tclOO.h index cf253b1..a6e8a22 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -12,21 +12,6 @@ #ifndef TCLOO_H_INCLUDED #define TCLOO_H_INCLUDED -#include "tcl.h" - -#ifndef TCLOOAPI -# if defined(BUILD_tcl) || defined(BUILD_TclOO) -# define TCLOOAPI MODULE_SCOPE -# else -# define TCLOOAPI extern -# undef USE_TCLOO_STUBS -# define USE_TCLOO_STUBS 1 -# endif -#endif - -extern const char *TclOOInitializeStubs( - Tcl_Interp *, const char *version); -#define Tcl_OOInitStubs(interp) TclOOInitializeStubs((interp), TCLOO_VERSION) /* * Be careful when it comes to versioning; need to make sure that the @@ -39,9 +24,27 @@ extern const char *TclOOInitializeStubs( * win/tclooConfig.sh */ -#define TCLOO_VERSION "1.0" +#define TCLOO_VERSION "1.0.1" #define TCLOO_PATCHLEVEL TCLOO_VERSION +#include "tcl.h" + +/* + * For C++ compilers, use extern "C" + */ + +#ifdef __cplusplus +extern "C" { +#endif + +extern const char *TclOOInitializeStubs( + Tcl_Interp *, const char *version); +#define Tcl_OOInitStubs(interp) \ + TclOOInitializeStubs((interp), TCLOO_VERSION) +#ifndef USE_TCL_STUBS +# define TclOOInitializeStubs(interp, version) (TCLOO_PATCHLEVEL) +#endif + /* * These are opaque types. */ @@ -130,6 +133,9 @@ typedef struct { #include "tclOODecls.h" +#ifdef __cplusplus +} +#endif #endif /* diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 0676618..0b0516b 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; if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -102,6 +97,7 @@ TclOO_Class_Constructor( * Delegate to [oo::define] to do the work. */ + invoke = ckalloc(3 * sizeof(Tcl_Obj *)); invoke[0] = oPtr->fPtr->defineName; invoke[1] = TclOOObjectName(interp, oPtr); invoke[2] = objv[objc-1]; @@ -115,7 +111,7 @@ TclOO_Class_Constructor( Tcl_IncrRefCount(invoke[1]); Tcl_IncrRefCount(invoke[2]); TclNRAddCallback(interp, DecrRefsPostClassConstructor, - invoke[0], invoke[1], invoke[2], NULL); + invoke, NULL, NULL, NULL); /* * Tricky point: do not want the extra reported level in the Tcl stack @@ -131,9 +127,12 @@ DecrRefsPostClassConstructor( Tcl_Interp *interp, int result) { - TclDecrRefCount((Tcl_Obj *) data[0]); - TclDecrRefCount((Tcl_Obj *) data[1]); - TclDecrRefCount((Tcl_Obj *) data[2]); + Tcl_Obj **invoke = data[0]; + + TclDecrRefCount(invoke[0]); + TclDecrRefCount(invoke[1]); + TclDecrRefCount(invoke[2]); + ckfree(invoke); return result; } @@ -687,52 +686,51 @@ TclOO_Object_VarName( int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* The actual arguments. */ { - Interp *iPtr = (Interp *) interp; Var *varPtr, *aryVar; - Tcl_Obj *varNamePtr; + Tcl_Obj *varNamePtr, *argPtr; + const char *arg; if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "varName"); return TCL_ERROR; } + argPtr = objv[objc-1]; + arg = Tcl_GetString(argPtr); /* - * Switch to the object's namespace for the duration of this call. Like - * this, the variable is looked up in the namespace of the object, and not - * in the namespace of the caller. Otherwise this would only work if the - * caller was a method of the object itself, which might not be true if - * the method was exported. This is a bit of a hack, but the simplest way - * to do this (pushing a stack frame would be horribly expensive by - * comparison, and is only done when we'd otherwise interfere with the - * global namespace). + * Convert the variable name to fully-qualified form if it wasn't already. + * This has to be done prior to lookup because we can run into problems + * with resolvers otherwise. [Bug 3603695] + * + * We still need to do the lookup; the variable could be linked to another + * variable and we want the target's name. */ - if (iPtr->varFramePtr == NULL) { - Tcl_CallFrame *dummyFrame; - - TclPushStackFrame(interp, &dummyFrame, - Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context)),0); - varPtr = TclObjLookupVar(interp, objv[objc-1], NULL, - TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to",1,1,&aryVar); - TclPopStackFrame(interp); + if (arg[0] == ':' && arg[1] == ':') { + varNamePtr = argPtr; } else { - Namespace *savedNsPtr; - - savedNsPtr = iPtr->varFramePtr->nsPtr; - iPtr->varFramePtr->nsPtr = (Namespace *) + Tcl_Namespace *namespacePtr = Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context)); - varPtr = TclObjLookupVar(interp, objv[objc-1], NULL, - TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to",1,1,&aryVar); - iPtr->varFramePtr->nsPtr = savedNsPtr; - } + varNamePtr = Tcl_NewStringObj(namespacePtr->fullName, -1); + Tcl_AppendToObj(varNamePtr, "::", 2); + Tcl_AppendObjToObj(varNamePtr, argPtr); + } + Tcl_IncrRefCount(varNamePtr); + varPtr = TclObjLookupVar(interp, varNamePtr, NULL, + TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to", 1, 1, &aryVar); + Tcl_DecrRefCount(varNamePtr); if (varPtr == NULL) { - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", - TclGetString(objv[objc-1]), NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", arg, NULL); return TCL_ERROR; } + /* + * Now that we've pinned down what variable we're really talking about + * (including traversing variable links), convert back to a name. + */ + varNamePtr = Tcl_NewObj(); if (aryVar != NULL) { Tcl_HashEntry *hPtr; @@ -805,7 +803,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); } @@ -823,6 +821,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 @@ -874,8 +873,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, @@ -888,24 +887,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) diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index a79e4fa..26fd09f 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -178,7 +178,7 @@ StashCallChain( callPtr->refCount++; TclFreeIntRep(objPtr); objPtr->typePtr = &methodNameType; - objPtr->internalRep.otherValuePtr = callPtr; + objPtr->internalRep.twoPtrValue.ptr1 = callPtr; } void @@ -205,10 +205,10 @@ DupMethodNameRep( Tcl_Obj *srcPtr, Tcl_Obj *dstPtr) { - register CallChain *callPtr = srcPtr->internalRep.otherValuePtr; + register CallChain *callPtr = srcPtr->internalRep.twoPtrValue.ptr1; dstPtr->typePtr = &methodNameType; - dstPtr->internalRep.otherValuePtr = callPtr; + dstPtr->internalRep.twoPtrValue.ptr1 = callPtr; callPtr->refCount++; } @@ -216,10 +216,9 @@ static void FreeMethodNameRep( Tcl_Obj *objPtr) { - register CallChain *callPtr = objPtr->internalRep.otherValuePtr; + register CallChain *callPtr = objPtr->internalRep.twoPtrValue.ptr1; TclOODeleteChain(callPtr); - objPtr->internalRep.otherValuePtr = NULL; objPtr->typePtr = NULL; } @@ -952,7 +951,7 @@ TclOOGetCallContext( const int reuseMask = ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD); if (cacheInThisObj->typePtr == &methodNameType) { - callPtr = cacheInThisObj->internalRep.otherValuePtr; + callPtr = cacheInThisObj->internalRep.twoPtrValue.ptr1; if (IsStillValid(callPtr, oPtr, flags, reuseMask)) { callPtr->refCount++; goto returnContext; diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index 58871c6..9fd62ec 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -5,99 +5,116 @@ #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, ClientData clientData); /* 12 */ -TCLOOAPI Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, +TCLAPI Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 13 */ -TCLOOAPI Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, +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); typedef struct { @@ -139,10 +156,8 @@ typedef struct TclOOStubs { Tcl_Obj * (*tcl_GetObjectName) (Tcl_Interp *interp, Tcl_Object object); /* 28 */ } TclOOStubs; -#ifdef __cplusplus -extern "C" { -#endif extern const TclOOStubs *tclOOStubsPtr; + #ifdef __cplusplus } #endif @@ -215,4 +230,5 @@ extern const TclOOStubs *tclOOStubsPtr; #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 bacab38..5a6c0ad 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -4,7 +4,7 @@ * This file contains the implementation of the ::oo::define command, * part of the object-system core (NB: not Tcl_Obj, but ::oo). * - * Copyright (c) 2006-2012 by Donal K. Fellows + * Copyright (c) 2006-2013 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -2206,29 +2206,42 @@ ClassSuperSet( /* * Parse the arguments to get the class to use as superclasses. + * + * Note that zero classes is special, as it is equivalent to just the + * class of objects. [Bug 9d61624b3d] */ - for (i=0 ; i<superc ; i++) { - superclasses[i] = GetClassInOuterContext(interp, superv[i], - "only a class can be a superclass"); - if (superclasses[i] == NULL) { - goto failedAfterAlloc; + if (superc == 0) { + superclasses = ckrealloc(superclasses, sizeof(Class *)); + superclasses[0] = oPtr->fPtr->objectCls; + superc = 1; + if (TclOOIsReachable(oPtr->fPtr->classCls, oPtr->classPtr)) { + superclasses[0] = oPtr->fPtr->classCls; } - for (j=0 ; j<i ; j++) { - if (superclasses[j] == superclasses[i]) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "class should only be a direct superclass once", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS", NULL); + } else { + for (i=0 ; i<superc ; i++) { + superclasses[i] = GetClassInOuterContext(interp, superv[i], + "only a class can be a superclass"); + if (superclasses[i] == NULL) { goto failedAfterAlloc; } - } - if (TclOOIsReachable(oPtr->classPtr, superclasses[i])) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to form circular dependency graph", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL); - failedAfterAlloc: - ckfree((char *) superclasses); - return TCL_ERROR; + for (j=0 ; j<i ; j++) { + if (superclasses[j] == superclasses[i]) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "class should only be a direct superclass once", + -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS",NULL); + goto failedAfterAlloc; + } + } + if (TclOOIsReachable(oPtr->classPtr, superclasses[i])) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to form circular dependency graph", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL); + failedAfterAlloc: + ckfree((char *) superclasses); + return TCL_ERROR; + } } } diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index ab54964..c0e4022 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -122,12 +122,6 @@ typedef struct ForwardMethod { Tcl_Obj *prefixObj; /* The list of values to use to replace the * object and method name with. Will be a * non-empty list. */ - int fullyQualified; /* If 1, the command name is fully qualified - * and we should let the default Tcl mechanism - * handle the command lookup because it is - * more efficient. If 0, we need to do a - * specialized lookup based on the current - * object's namespace. */ } ForwardMethod; /* diff --git a/generic/tclOOIntDecls.h b/generic/tclOOIntDecls.h index acafb18..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 28820e0..61215de 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -513,8 +513,8 @@ TclOOMakeProcInstanceMethod( cfPtr->data.eval.path = context.data.eval.path; Tcl_IncrRefCount(cfPtr->data.eval.path); - cfPtr->cmd.str.cmd = NULL; - cfPtr->cmd.str.len = 0; + cfPtr->cmd = NULL; + cfPtr->len = 0; hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr, (char *) procPtr, &isNew); @@ -626,8 +626,8 @@ TclOOMakeProcMethod( cfPtr->data.eval.path = context.data.eval.path; Tcl_IncrRefCount(cfPtr->data.eval.path); - cfPtr->cmd.str.cmd = NULL; - cfPtr->cmd.str.len = 0; + cfPtr->cmd = NULL; + cfPtr->len = 0; hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr, (char *) procPtr, &isNew); @@ -860,7 +860,7 @@ PushMethodCallFrame( if (pmPtr->procPtr->bodyPtr->typePtr == &tclByteCodeType) { ByteCode *codePtr = - pmPtr->procPtr->bodyPtr->internalRep.otherValuePtr; + pmPtr->procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; codePtr->nsPtr = nsPtr; } @@ -1290,11 +1290,57 @@ CloneProcedureMethod( ClientData *newClientData) { ProcedureMethod *pmPtr = clientData; - ProcedureMethod *pm2Ptr = ckalloc(sizeof(ProcedureMethod)); + ProcedureMethod *pm2Ptr; + Tcl_Obj *bodyObj, *argsObj; + CompiledLocal *localPtr; + /* + * Copy the argument list. + */ + + argsObj = Tcl_NewObj(); + for (localPtr=pmPtr->procPtr->firstLocalPtr; localPtr!=NULL; + localPtr=localPtr->nextPtr) { + if (TclIsVarArgument(localPtr)) { + Tcl_Obj *argObj = Tcl_NewObj(); + + Tcl_ListObjAppendElement(NULL, argObj, + Tcl_NewStringObj(localPtr->name, -1)); + if (localPtr->defValuePtr != NULL) { + Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr); + } + Tcl_ListObjAppendElement(NULL, argsObj, argObj); + } + } + + /* + * Must strip the internal representation in order to ensure that any + * bound references to instance variables are removed. [Bug 3609693] + */ + + bodyObj = Tcl_DuplicateObj(pmPtr->procPtr->bodyPtr); + TclFreeIntRep(bodyObj); + + /* + * Create the actual copy of the method record, manufacturing a new proc + * record. + */ + + pm2Ptr = ckalloc(sizeof(ProcedureMethod)); memcpy(pm2Ptr, pmPtr, sizeof(ProcedureMethod)); pm2Ptr->refCount = 1; - pm2Ptr->procPtr->refCount++; + Tcl_IncrRefCount(argsObj); + Tcl_IncrRefCount(bodyObj); + if (TclCreateProc(interp, NULL, "", argsObj, bodyObj, + &pm2Ptr->procPtr) != TCL_OK) { + Tcl_DecrRefCount(argsObj); + Tcl_DecrRefCount(bodyObj); + ckfree(pm2Ptr); + return TCL_ERROR; + } + Tcl_DecrRefCount(argsObj); + Tcl_DecrRefCount(bodyObj); + if (pmPtr->cloneClientdataProc) { pm2Ptr->clientData = pmPtr->cloneClientdataProc(pmPtr->clientData); } @@ -1338,7 +1384,6 @@ TclOONewForwardInstanceMethod( fmPtr = ckalloc(sizeof(ForwardMethod)); fmPtr->prefixObj = prefixObj; Tcl_ListObjIndex(interp, prefixObj, 0, &cmdObj); - fmPtr->fullyQualified = (strncmp(TclGetString(cmdObj), "::", 2) == 0); Tcl_IncrRefCount(prefixObj); return (Method *) Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, nameObj, flags, &fwdMethodType, fmPtr); @@ -1380,7 +1425,6 @@ TclOONewForwardMethod( fmPtr = ckalloc(sizeof(ForwardMethod)); fmPtr->prefixObj = prefixObj; Tcl_ListObjIndex(interp, prefixObj, 0, &cmdObj); - fmPtr->fullyQualified = (strncmp(TclGetString(cmdObj), "::", 2) == 0); Tcl_IncrRefCount(prefixObj); return (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj, flags, &fwdMethodType, fmPtr); @@ -1409,7 +1453,6 @@ InvokeForwardMethod( ForwardMethod *fmPtr = clientData; Tcl_Obj **argObjs, **prefixObjs; int numPrefixes, len, skip = contextPtr->skip; - Command *cmdPtr; /* * Build the real list of arguments to use. Note that we know that the @@ -1421,15 +1464,10 @@ InvokeForwardMethod( Tcl_ListObjGetElements(NULL, fmPtr->prefixObj, &numPrefixes, &prefixObjs); argObjs = InitEnsembleRewrite(interp, objc, objv, skip, numPrefixes, prefixObjs, &len); - - if (fmPtr->fullyQualified) { - cmdPtr = NULL; - } else { - cmdPtr = (Command *) Tcl_FindCommand(interp, TclGetString(argObjs[0]), - contextPtr->oPtr->namespacePtr, 0 /* normal lookup */); - } Tcl_NRAddCallback(interp, FinalizeForwardCall, argObjs, NULL, NULL, NULL); - return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_INVOKE, cmdPtr); + ((Interp *)interp)->lookupNsPtr + = (Namespace *) contextPtr->oPtr->namespacePtr; + return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_NOERR, NULL); } static int @@ -1474,7 +1512,6 @@ CloneForwardMethod( ForwardMethod *fm2Ptr = ckalloc(sizeof(ForwardMethod)); fm2Ptr->prefixObj = fmPtr->prefixObj; - fm2Ptr->fullyQualified = fmPtr->fullyQualified; Tcl_IncrRefCount(fm2Ptr->prefixObj); *newClientData = fm2Ptr; return TCL_OK; diff --git a/generic/tclOOStubLib.c b/generic/tclOOStubLib.c index 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 74cb29e..930e1fd 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -97,7 +97,6 @@ typedef struct ThreadSpecificData { static Tcl_ThreadDataKey dataKey; -static void ContLineLocFree(char *clientData); static void TclThreadFinalizeContLines(ClientData clientData); static ThreadSpecificData *TclGetContLineTable(void); @@ -208,12 +207,11 @@ static Tcl_ThreadDataKey pendingObjDataKey; */ static int ParseBoolean(Tcl_Obj *objPtr); -static int SetBooleanFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static int SetDoubleFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static int SetIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfDouble(Tcl_Obj *objPtr); static void UpdateStringOfInt(Tcl_Obj *objPtr); -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG static void UpdateStringOfWideInt(Tcl_Obj *objPtr); static int SetWideIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); #endif @@ -250,14 +248,14 @@ static const Tcl_ObjType oldBooleanType = { NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ - SetBooleanFromAny /* setFromAnyProc */ + TclSetBooleanFromAny /* setFromAnyProc */ }; const Tcl_ObjType tclBooleanType = { "booleanString", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ - SetBooleanFromAny /* setFromAnyProc */ + TclSetBooleanFromAny /* setFromAnyProc */ }; const Tcl_ObjType tclDoubleType = { "double", /* name */ @@ -273,7 +271,7 @@ const Tcl_ObjType tclIntType = { UpdateStringOfInt, /* updateStringProc */ SetIntFromAny /* setFromAnyProc */ }; -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG const Tcl_ObjType tclWideIntType = { "wideInt", /* name */ NULL, /* freeIntRepProc */ @@ -411,7 +409,7 @@ TclInitObjSubsystem(void) /* For backward compatibility only ... */ Tcl_RegisterObjType(&oldBooleanType); -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG Tcl_RegisterObjType(&tclWideIntType); #endif @@ -806,14 +804,7 @@ TclThreadFinalizeContLines( for (hPtr = Tcl_FirstHashEntry(tsdPtr->lineCLPtr, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { - /* - * We are not using Tcl_EventuallyFree (as in TclFreeObj()) because - * here we can be sure that the compiler will not hold references to - * the data in the hashtable, and using TEF might bork the - * finalization sequence. - */ - - ContLineLocFree(Tcl_GetHashValue(hPtr)); + ckfree(Tcl_GetHashValue(hPtr)); Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(tsdPtr->lineCLPtr); @@ -822,30 +813,6 @@ TclThreadFinalizeContLines( } /* - *---------------------------------------------------------------------- - * - * ContLineLocFree -- - * - * The freProc for continuation line location tables. - * - * Results: - * None. - * - * Side effects: - * Releases memory. - * - * TIP #280 - *---------------------------------------------------------------------- - */ - -static void -ContLineLocFree( - char *clientData) -{ - ckfree(clientData); -} - -/* *-------------------------------------------------------------- * * Tcl_RegisterObjType -- @@ -1006,7 +973,12 @@ Tcl_ConvertToType( */ if (typePtr->setFromAnyProc == NULL) { - Tcl_Panic("may not convert object to type %s", typePtr->name); + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't convert value to type %s", typePtr->name)); + Tcl_SetErrorCode(interp, "TCL", "API_ABUSE", NULL); + } + return TCL_ERROR; } return typePtr->setFromAnyProc(interp, objPtr); @@ -1255,7 +1227,7 @@ Tcl_DbNewObj( * Side effects: * tclFreeObjList, the head of the list of free Tcl_Objs, is set to the * first of a number of free Tcl_Obj's linked together by their - * internalRep.otherValuePtrs. + * internalRep.twoPtrValue.ptr1's. * *---------------------------------------------------------------------- */ @@ -1284,7 +1256,7 @@ TclAllocateFreeObjects(void) prevPtr = NULL; objPtr = (Tcl_Obj *) basePtr; for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) { - objPtr->internalRep.otherValuePtr = prevPtr; + objPtr->internalRep.twoPtrValue.ptr1 = prevPtr; prevPtr = objPtr; objPtr++; } @@ -1329,9 +1301,21 @@ TclFreeObj( ObjInitDeletionContext(context); + /* + * Check for a double free of the same value. This is slightly tricky + * because it is customary to free a Tcl_Obj when its refcount falls + * either from 1 to 0, or from 0 to -1. Falling from -1 to -2, though, + * and so on, is always a sign of a botch in the caller. + */ if (objPtr->refCount < -1) { Tcl_Panic("Reference count for %p was negative", objPtr); } + /* + * Now, in case we just approved drop from 1 to 0 as acceptable, make + * sure we do not accept a second free when falling from 0 to -1. + * Skip that possibility so any double free will trigger the panic. + */ + objPtr->refCount = -1; /* * Invalidate the string rep first so we can use the bytes value for our @@ -1389,7 +1373,7 @@ TclFreeObj( if (tsdPtr->lineCLPtr) { hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); if (hPtr) { - Tcl_EventuallyFree(Tcl_GetHashValue(hPtr), ContLineLocFree); + ckfree(Tcl_GetHashValue(hPtr)); Tcl_DeleteHashEntry(hPtr); } } @@ -1480,7 +1464,7 @@ TclFreeObj( if (tsdPtr->lineCLPtr) { hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); if (hPtr) { - Tcl_EventuallyFree(Tcl_GetHashValue(hPtr), ContLineLocFree); + ckfree(Tcl_GetHashValue(hPtr)); Tcl_DeleteHashEntry(hPtr); } } @@ -1729,8 +1713,8 @@ Tcl_InvalidateStringRep( *---------------------------------------------------------------------- */ -#ifdef TCL_MEM_DEBUG #undef Tcl_NewBooleanObj +#ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_NewBooleanObj( @@ -1778,6 +1762,7 @@ Tcl_NewBooleanObj( *---------------------------------------------------------------------- */ +#undef Tcl_DbNewBooleanObj #ifdef TCL_MEM_DEBUG Tcl_Obj * @@ -1830,6 +1815,7 @@ Tcl_DbNewBooleanObj( *---------------------------------------------------------------------- */ +#undef Tcl_SetBooleanObj void Tcl_SetBooleanObj( register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ @@ -1897,7 +1883,7 @@ Tcl_GetBooleanFromObj( *boolPtr = 1; return TCL_OK; } -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclWideIntType) { *boolPtr = (objPtr->internalRep.wideValue != 0); return TCL_OK; @@ -1911,7 +1897,7 @@ Tcl_GetBooleanFromObj( /* *---------------------------------------------------------------------- * - * SetBooleanFromAny -- + * TclSetBooleanFromAny -- * * Attempt to generate a boolean internal form for the Tcl object * "objPtr". @@ -1928,8 +1914,8 @@ Tcl_GetBooleanFromObj( *---------------------------------------------------------------------- */ -static int -SetBooleanFromAny( +int +TclSetBooleanFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr) /* The object to convert. */ { @@ -1952,7 +1938,7 @@ SetBooleanFromAny( goto badBoolean; } -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclWideIntType) { goto badBoolean; } @@ -2284,7 +2270,7 @@ Tcl_GetDoubleFromObj( *dblPtr = TclBignumToDouble(&big); return TCL_OK; } -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclWideIntType) { *dblPtr = (double) objPtr->internalRep.wideValue; return TCL_OK; @@ -2389,8 +2375,8 @@ UpdateStringOfDouble( *---------------------------------------------------------------------- */ -#ifdef TCL_MEM_DEBUG #undef Tcl_NewIntObj +#ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_NewIntObj( @@ -2430,6 +2416,7 @@ Tcl_NewIntObj( *---------------------------------------------------------------------- */ +#undef Tcl_SetIntObj void Tcl_SetIntObj( register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ @@ -2741,7 +2728,7 @@ Tcl_GetLongFromObj( *longPtr = objPtr->internalRep.longValue; return TCL_OK; } -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclWideIntType) { /* * We return any integer in the range -ULONG_MAX to ULONG_MAX @@ -2799,7 +2786,7 @@ Tcl_GetLongFromObj( return TCL_OK; } } -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG tooLarge: #endif if (interp != NULL) { @@ -2815,7 +2802,7 @@ Tcl_GetLongFromObj( TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG /* *---------------------------------------------------------------------- @@ -2857,7 +2844,7 @@ UpdateStringOfWideInt( memcpy(objPtr->bytes, buffer, len + 1); objPtr->length = len; } -#endif /* !NO_WIDE_TYPE */ +#endif /* !TCL_WIDE_INT_IS_LONG */ /* *---------------------------------------------------------------------- @@ -3012,7 +2999,7 @@ Tcl_SetWideIntObj( && (wideValue <= (Tcl_WideInt) LONG_MAX)) { TclSetLongObj(objPtr, (long) wideValue); } else { -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG TclSetWideIntObj(objPtr, wideValue); #else mp_int big; @@ -3052,7 +3039,7 @@ Tcl_GetWideIntFromObj( /* Place to store resulting long. */ { do { -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclWideIntType) { *wideIntPtr = objPtr->internalRep.wideValue; return TCL_OK; @@ -3112,7 +3099,7 @@ Tcl_GetWideIntFromObj( TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG /* *---------------------------------------------------------------------- @@ -3138,7 +3125,7 @@ SetWideIntFromAny( Tcl_WideInt w; return Tcl_GetWideIntFromObj(interp, objPtr, &w); } -#endif /* !NO_WIDE_TYPE */ +#endif /* !TCL_WIDE_INT_IS_LONG */ /* *---------------------------------------------------------------------- @@ -3386,7 +3373,7 @@ GetBignumFromObj( TclBNInitBignumFromLong(bignumValue, objPtr->internalRep.longValue); return TCL_OK; } -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclWideIntType) { TclBNInitBignumFromWideInt(bignumValue, objPtr->internalRep.wideValue); @@ -3525,7 +3512,7 @@ Tcl_SetBignumObj( return; } tooLargeForLong: -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG if ((size_t) bignumValue->used <= (CHAR_BIT * sizeof(Tcl_WideInt) + DIGIT_BIT - 1) / DIGIT_BIT) { Tcl_WideUInt value = 0; @@ -3637,7 +3624,7 @@ TclGetNumberFromObj( *clientDataPtr = &objPtr->internalRep.longValue; return TCL_OK; } -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclWideIntType) { *typePtr = TCL_NUMBER_WIDE; *clientDataPtr = &objPtr->internalRep.wideValue; @@ -4171,7 +4158,7 @@ Tcl_GetCommandFromObj( * had is invalid one way or another. */ - if (tclCmdNameType.setFromAnyProc(interp, objPtr) != TCL_OK) { + if (SetCmdNameFromAny(interp, objPtr) != TCL_OK) { return NULL; } resPtr = objPtr->internalRep.twoPtrValue.ptr1; @@ -4390,7 +4377,7 @@ SetCmdNameFromAny( if (cmdPtr) { cmdPtr->refCount++; - resPtr = objPtr->internalRep.otherValuePtr; + resPtr = objPtr->internalRep.twoPtrValue.ptr1; if ((objPtr->typePtr == &tclCmdNameType) && resPtr && (resPtr->refCount == 1)) { /* diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c new file mode 100644 index 0000000..827d89d --- /dev/null +++ b/generic/tclOptimize.c @@ -0,0 +1,444 @@ +/* + * tclOptimize.c -- + * + * This file contains the bytecode optimizer. + * + * Copyright (c) 2013 by Donal Fellows. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tclInt.h" +#include "tclCompile.h" +#include <assert.h> + +/* + * Forward declarations. + */ + +static void AdvanceJumps(CompileEnv *envPtr); +static void ConvertZeroEffectToNOP(CompileEnv *envPtr); +static void LocateTargetAddresses(CompileEnv *envPtr, + Tcl_HashTable *tablePtr); +static void TrimUnreachable(CompileEnv *envPtr); + +/* + * Helper macros. + */ + +#define DefineTargetAddress(tablePtr, address) \ + ((void) Tcl_CreateHashEntry((tablePtr), (void *) (address), &isNew)) +#define IsTargetAddress(tablePtr, address) \ + (Tcl_FindHashEntry((tablePtr), (void *) (address)) != NULL) +#define AddrLength(address) \ + (tclInstructionTable[*(unsigned char *)(address)].numBytes) +#define InstLength(instruction) \ + (tclInstructionTable[(unsigned char)(instruction)].numBytes) + +/* + * ---------------------------------------------------------------------- + * + * LocateTargetAddresses -- + * + * Populate a hash table with places that we need to be careful around + * because they're the targets of various kinds of jumps and other + * non-local behavior. + * + * ---------------------------------------------------------------------- + */ + +static void +LocateTargetAddresses( + CompileEnv *envPtr, + Tcl_HashTable *tablePtr) +{ + unsigned char *currentInstPtr, *targetInstPtr; + int isNew, i; + Tcl_HashEntry *hPtr; + Tcl_HashSearch hSearch; + + Tcl_InitHashTable(tablePtr, TCL_ONE_WORD_KEYS); + + /* + * The starts of commands represent target addresses. + */ + + for (i=0 ; i<envPtr->numCommands ; i++) { + DefineTargetAddress(tablePtr, + envPtr->codeStart + envPtr->cmdMapPtr[i].codeOffset); + } + + /* + * Find places where we should be careful about replacing instructions + * because they are the targets of various types of jumps. + */ + + for (currentInstPtr = envPtr->codeStart ; + currentInstPtr < envPtr->codeNext ; + currentInstPtr += AddrLength(currentInstPtr)) { + switch (*currentInstPtr) { + case INST_JUMP1: + case INST_JUMP_TRUE1: + case INST_JUMP_FALSE1: + targetInstPtr = currentInstPtr+TclGetInt1AtPtr(currentInstPtr+1); + goto storeTarget; + case INST_JUMP4: + case INST_JUMP_TRUE4: + case INST_JUMP_FALSE4: + case INST_START_CMD: + targetInstPtr = currentInstPtr+TclGetInt4AtPtr(currentInstPtr+1); + goto storeTarget; + case INST_BEGIN_CATCH4: + targetInstPtr = envPtr->codeStart + envPtr->exceptArrayPtr[ + TclGetUInt4AtPtr(currentInstPtr+1)].codeOffset; + storeTarget: + DefineTargetAddress(tablePtr, targetInstPtr); + break; + case INST_JUMP_TABLE: + hPtr = Tcl_FirstHashEntry( + &JUMPTABLEINFO(envPtr, currentInstPtr+1)->hashTable, + &hSearch); + for (; hPtr ; hPtr = Tcl_NextHashEntry(&hSearch)) { + targetInstPtr = currentInstPtr + + PTR2INT(Tcl_GetHashValue(hPtr)); + DefineTargetAddress(tablePtr, targetInstPtr); + } + break; + case INST_RETURN_CODE_BRANCH: + for (i=TCL_ERROR ; i<TCL_CONTINUE+1 ; i++) { + DefineTargetAddress(tablePtr, currentInstPtr + 2*i - 1); + } + break; + } + } + + /* + * Add a marker *after* the last bytecode instruction. WARNING: points to + * one past the end! + */ + + DefineTargetAddress(tablePtr, currentInstPtr); + + /* + * Enter in the targets of exception ranges. + */ + + for (i=0 ; i<envPtr->exceptArrayNext ; i++) { + ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[i]; + + if (rangePtr->type == CATCH_EXCEPTION_RANGE) { + targetInstPtr = envPtr->codeStart + rangePtr->catchOffset; + DefineTargetAddress(tablePtr, targetInstPtr); + } else { + targetInstPtr = envPtr->codeStart + rangePtr->breakOffset; + DefineTargetAddress(tablePtr, targetInstPtr); + if (rangePtr->continueOffset >= 0) { + targetInstPtr = envPtr->codeStart + rangePtr->continueOffset; + DefineTargetAddress(tablePtr, targetInstPtr); + } + } + } +} + +/* + * ---------------------------------------------------------------------- + * + * TrimUnreachable -- + * + * Converts code that provably can't be executed into NOPs and reduces + * the overall reported length of the bytecode where that is possible. + * + * ---------------------------------------------------------------------- + */ + +static void +TrimUnreachable( + CompileEnv *envPtr) +{ + unsigned char *currentInstPtr; + Tcl_HashTable targets; + + LocateTargetAddresses(envPtr, &targets); + + for (currentInstPtr = envPtr->codeStart ; + currentInstPtr < envPtr->codeNext-1 ; + currentInstPtr += AddrLength(currentInstPtr)) { + int clear = 0; + + if (*currentInstPtr != INST_DONE) { + continue; + } + + while (!IsTargetAddress(&targets, currentInstPtr + 1 + clear)) { + clear += AddrLength(currentInstPtr + 1 + clear); + } + if (currentInstPtr + 1 + clear == envPtr->codeNext) { + envPtr->codeNext -= clear; + } else { + while (clear --> 0) { + *(currentInstPtr + 1 + clear) = INST_NOP; + } + } + } + + Tcl_DeleteHashTable(&targets); +} + +/* + * ---------------------------------------------------------------------- + * + * ConvertZeroEffectToNOP -- + * + * Replace PUSH/POP sequences (when non-hazardous) with NOPs. Also + * replace PUSH empty/STR_CONCAT and TRY_CVT_NUMERIC (when followed by an + * operation that guarantees the check for arithmeticity) and eliminate + * LNOT when we can invert the following JUMP condition. + * + * ---------------------------------------------------------------------- + */ + +static void +ConvertZeroEffectToNOP( + CompileEnv *envPtr) +{ + unsigned char *currentInstPtr; + int size; + Tcl_HashTable targets; + + LocateTargetAddresses(envPtr, &targets); + for (currentInstPtr = envPtr->codeStart ; + currentInstPtr < envPtr->codeNext ; currentInstPtr += size) { + int blank = 0, i, nextInst; + + size = AddrLength(currentInstPtr); + while ((currentInstPtr + size < envPtr->codeNext) + && *(currentInstPtr+size) == INST_NOP) { + if (IsTargetAddress(&targets, currentInstPtr + size)) { + break; + } + size += InstLength(INST_NOP); + } + if (IsTargetAddress(&targets, currentInstPtr + size)) { + continue; + } + nextInst = *(currentInstPtr + size); + switch (*currentInstPtr) { + case INST_PUSH1: + if (nextInst == INST_POP) { + blank = size + InstLength(nextInst); + } else if (nextInst == INST_STR_CONCAT1 + && TclGetUInt1AtPtr(currentInstPtr + size + 1) == 2) { + Tcl_Obj *litPtr = TclFetchLiteral(envPtr, + TclGetUInt1AtPtr(currentInstPtr + 1)); + int numBytes; + + (void) Tcl_GetStringFromObj(litPtr, &numBytes); + if (numBytes == 0) { + blank = size + InstLength(nextInst); + } + } + break; + case INST_PUSH4: + if (nextInst == INST_POP) { + blank = size + 1; + } else if (nextInst == INST_STR_CONCAT1 + && TclGetUInt1AtPtr(currentInstPtr + size + 1) == 2) { + Tcl_Obj *litPtr = TclFetchLiteral(envPtr, + TclGetUInt4AtPtr(currentInstPtr + 1)); + int numBytes; + + (void) Tcl_GetStringFromObj(litPtr, &numBytes); + if (numBytes == 0) { + blank = size + InstLength(nextInst); + } + } + break; + + case INST_LNOT: + switch (nextInst) { + case INST_JUMP_TRUE1: + blank = size; + *(currentInstPtr + size) = INST_JUMP_FALSE1; + break; + case INST_JUMP_FALSE1: + blank = size; + *(currentInstPtr + size) = INST_JUMP_TRUE1; + break; + case INST_JUMP_TRUE4: + blank = size; + *(currentInstPtr + size) = INST_JUMP_FALSE4; + break; + case INST_JUMP_FALSE4: + blank = size; + *(currentInstPtr + size) = INST_JUMP_TRUE4; + break; + } + break; + + case INST_TRY_CVT_TO_NUMERIC: + switch (nextInst) { + case INST_JUMP_TRUE1: + case INST_JUMP_TRUE4: + case INST_JUMP_FALSE1: + case INST_JUMP_FALSE4: + case INST_INCR_SCALAR1: + case INST_INCR_ARRAY1: + case INST_INCR_ARRAY_STK: + case INST_INCR_SCALAR_STK: + case INST_INCR_STK: + case INST_LOR: + case INST_LAND: + case INST_EQ: + case INST_NEQ: + case INST_LT: + case INST_LE: + case INST_GT: + case INST_GE: + case INST_MOD: + case INST_LSHIFT: + case INST_RSHIFT: + case INST_BITOR: + case INST_BITXOR: + case INST_BITAND: + case INST_EXPON: + case INST_ADD: + case INST_SUB: + case INST_DIV: + case INST_MULT: + case INST_LNOT: + case INST_BITNOT: + case INST_UMINUS: + case INST_UPLUS: + case INST_TRY_CVT_TO_NUMERIC: + blank = size; + break; + } + break; + } + + if (blank > 0) { + for (i=0 ; i<blank ; i++) { + *(currentInstPtr + i) = INST_NOP; + } + size = blank; + } + } + Tcl_DeleteHashTable(&targets); +} + +/* + * ---------------------------------------------------------------------- + * + * AdvanceJumps -- + * + * Advance jumps past NOPs and chained JUMPs. After this runs, the only + * JUMPs that jump to a NOP or a JUMP will be length-1 ones that run out + * of room in their opcode to be targeted to where they really belong. + * + * ---------------------------------------------------------------------- + */ + +static void +AdvanceJumps( + CompileEnv *envPtr) +{ + unsigned char *currentInstPtr; + Tcl_HashTable jumps; + + for (currentInstPtr = envPtr->codeStart ; + currentInstPtr < envPtr->codeNext-1 ; + currentInstPtr += AddrLength(currentInstPtr)) { + int offset, delta, isNew; + + switch (*currentInstPtr) { + case INST_JUMP1: + case INST_JUMP_TRUE1: + case INST_JUMP_FALSE1: + offset = TclGetInt1AtPtr(currentInstPtr + 1); + Tcl_InitHashTable(&jumps, TCL_ONE_WORD_KEYS); + for (delta=0 ; offset+delta != 0 ;) { + if (offset + delta < -128 || offset + delta > 127) { + break; + } + Tcl_CreateHashEntry(&jumps, INT2PTR(offset), &isNew); + if (!isNew) { + offset = TclGetInt1AtPtr(currentInstPtr + 1); + break; + } + offset += delta; + switch (*(currentInstPtr + offset)) { + case INST_NOP: + delta = InstLength(INST_NOP); + continue; + case INST_JUMP1: + delta = TclGetInt1AtPtr(currentInstPtr + offset + 1); + continue; + case INST_JUMP4: + delta = TclGetInt4AtPtr(currentInstPtr + offset + 1); + continue; + } + break; + } + Tcl_DeleteHashTable(&jumps); + TclStoreInt1AtPtr(offset, currentInstPtr + 1); + continue; + + case INST_JUMP4: + case INST_JUMP_TRUE4: + case INST_JUMP_FALSE4: + Tcl_InitHashTable(&jumps, TCL_ONE_WORD_KEYS); + Tcl_CreateHashEntry(&jumps, INT2PTR(0), &isNew); + for (offset = TclGetInt4AtPtr(currentInstPtr + 1); offset!=0 ;) { + Tcl_CreateHashEntry(&jumps, INT2PTR(offset), &isNew); + if (!isNew) { + offset = TclGetInt4AtPtr(currentInstPtr + 1); + break; + } + switch (*(currentInstPtr + offset)) { + case INST_NOP: + offset += InstLength(INST_NOP); + continue; + case INST_JUMP1: + offset += TclGetInt1AtPtr(currentInstPtr + offset + 1); + continue; + case INST_JUMP4: + offset += TclGetInt4AtPtr(currentInstPtr + offset + 1); + continue; + } + break; + } + Tcl_DeleteHashTable(&jumps); + TclStoreInt4AtPtr(offset, currentInstPtr + 1); + continue; + } + } +} + +/* + * ---------------------------------------------------------------------- + * + * TclOptimizeBytecode -- + * + * A very simple peephole optimizer for bytecode. + * + * ---------------------------------------------------------------------- + */ + +void +TclOptimizeBytecode( + void *envPtr) +{ + ConvertZeroEffectToNOP(envPtr); + AdvanceJumps(envPtr); + TrimUnreachable(envPtr); +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * tab-width: 8 + * End: + */ diff --git a/generic/tclPanic.c b/generic/tclPanic.c index b87a8df..2a453b9 100644 --- a/generic/tclPanic.c +++ b/generic/tclPanic.c @@ -52,6 +52,10 @@ Tcl_SetPanicProc( #if defined(_WIN32) /* tclWinDebugPanic only installs if there is no panicProc yet. */ if ((proc != tclWinDebugPanic) || (panicProc == NULL)) +#elif defined(__CYGWIN__) + if (proc == NULL) + panicProc = tclWinDebugPanic; + else #endif panicProc = proc; } diff --git a/generic/tclParse.c b/generic/tclParse.c index 08615a7..ee0d4c4 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -15,6 +15,7 @@ #include "tclInt.h" #include "tclParse.h" +#include <assert.h> /* * The following table provides parsing information about each possible 8-bit @@ -1567,6 +1568,7 @@ Tcl_ParseVar( code = TclSubstTokens(interp, parsePtr->tokenPtr, parsePtr->numTokens, NULL, 1, NULL, NULL); + Tcl_FreeParse(parsePtr); TclStackFree(interp, parsePtr); if (code != TCL_OK) { return NULL; @@ -1577,16 +1579,13 @@ Tcl_ParseVar( * At this point we should have an object containing the value of a * variable. Just return the string from that object. * - * This should have returned the object for the user to manage, but - * instead we have some weak reference to the string value in the object, - * which is why we make sure the object exists after resetting the result. - * This isn't ideal, but it's the best we can do with the current - * documented interface. -- hobbs + * Since TclSubstTokens above returned TCL_OK, we know that objPtr + * is shared. It is in both the interp result and the value of the + * variable. Returning the string relies on that to be true. */ - if (!Tcl_IsShared(objPtr)) { - Tcl_IncrRefCount(objPtr); - } + assert( Tcl_IsShared(objPtr) ); + Tcl_ResetResult(interp); return TclGetString(objPtr); } diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 2b9ff87..99d576d 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -109,9 +109,9 @@ typedef struct FsPath { * fields. */ -#define PATHOBJ(pathPtr) ((FsPath *) (pathPtr)->internalRep.otherValuePtr) +#define PATHOBJ(pathPtr) ((FsPath *) (pathPtr)->internalRep.twoPtrValue.ptr1) #define SETPATHOBJ(pathPtr,fsPathPtr) \ - ((pathPtr)->internalRep.otherValuePtr = (void *) (fsPathPtr)) + ((pathPtr)->internalRep.twoPtrValue.ptr1 = (void *) (fsPathPtr)) #define PATHFLAGS(pathPtr) (PATHOBJ(pathPtr)->flags) /* @@ -512,7 +512,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, @@ -1156,7 +1156,7 @@ Tcl_FSConvertToPathType( FreeFsPathInternalRep(pathPtr); } - return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType); + return SetFsPathFromAny(interp, pathPtr); /* * We used to have more complex code here: @@ -1873,7 +1873,7 @@ Tcl_FSGetNormalizedPath( UpdateStringOfFsPath(pathPtr); } FreeFsPathInternalRep(pathPtr); - if (Tcl_ConvertToType(interp, pathPtr, &tclFsPathType) != TCL_OK) { + if (SetFsPathFromAny(interp, pathPtr) != TCL_OK) { return NULL; } fsPathPtr = PATHOBJ(pathPtr); @@ -1956,7 +1956,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 +1969,7 @@ Tcl_FSGetNormalizedPath( return NULL; } pureNormalized = 0; -#endif /* __WIN32__ */ +#endif /* _WIN32 */ } } @@ -2437,19 +2437,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 { diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 5b09ddb..df90cea 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -106,6 +106,7 @@ static const char * PkgRequireCore(Tcl_Interp *interp, const char *name, *---------------------------------------------------------------------- */ +#undef Tcl_PkgProvide int Tcl_PkgProvide( Tcl_Interp *interp, /* Interpreter in which package is now @@ -188,6 +189,7 @@ Tcl_PkgProvideEx( *---------------------------------------------------------------------- */ +#undef Tcl_PkgRequire const char * Tcl_PkgRequire( Tcl_Interp *interp, /* Interpreter in which package is now @@ -670,6 +672,7 @@ PkgRequireCore( *---------------------------------------------------------------------- */ +#undef Tcl_PkgPresent const char * Tcl_PkgPresent( Tcl_Interp *interp, /* Interpreter in which package is now @@ -946,7 +949,7 @@ Tcl_PackageObjCmd( version = TclGetString(objv[3]); } } - Tcl_PkgPresent(interp, name, version, exact); + Tcl_PkgPresentEx(interp, name, version, exact, NULL); return TCL_ERROR; break; } @@ -971,7 +974,7 @@ Tcl_PackageObjCmd( if (CheckVersionAndConvert(interp, argv3, NULL, NULL) != TCL_OK) { return TCL_ERROR; } - return Tcl_PkgProvide(interp, argv2, argv3); + return Tcl_PkgProvideEx(interp, argv2, argv3, NULL); case PKG_REQUIRE: require: if (objc < 3) { diff --git a/generic/tclPlatDecls.h b/generic/tclPlatDecls.h index e9b92fe..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/tclPort.h b/generic/tclPort.h index 7021b8d..12a60db 100644 --- a/generic/tclPort.h +++ b/generic/tclPort.h @@ -19,11 +19,10 @@ #endif #if defined(_WIN32) # include "tclWinPort.h" -#endif -#include "tcl.h" -#if !defined(_WIN32) +#else # include "tclUnixPort.h" #endif +#include "tcl.h" #if !defined(LLONG_MIN) # ifdef TCL_WIDE_INT_IS_LONG diff --git a/generic/tclProc.c b/generic/tclProc.c index 933e7d2..ce1c767 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -271,8 +271,8 @@ Tcl_ProcObjCmd( cfPtr->data.eval.path = contextPtr->data.eval.path; Tcl_IncrRefCount(cfPtr->data.eval.path); - cfPtr->cmd.str.cmd = NULL; - cfPtr->cmd.str.len = 0; + cfPtr->cmd = NULL; + cfPtr->len = 0; hePtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr, procPtr, &isNew); @@ -421,7 +421,7 @@ TclCreateProc( * will be holding a reference to it. */ - procPtr = bodyPtr->internalRep.otherValuePtr; + procPtr = bodyPtr->internalRep.twoPtrValue.ptr1; procPtr->iPtr = iPtr; procPtr->refCount++; precompiled = 1; @@ -837,7 +837,7 @@ TclObjGetFrame( } /* TODO: Consider skipping the typePtr checks */ } else if (objPtr->typePtr == &tclIntType -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG || objPtr->typePtr == &tclWideIntType #endif ) { @@ -1197,7 +1197,7 @@ TclInitCompiledLocals( if (bodyPtr->typePtr != &tclByteCodeType) { Tcl_Panic("body object for proc attached to frame is not a byte code type"); } - codePtr = bodyPtr->internalRep.otherValuePtr; + codePtr = bodyPtr->internalRep.twoPtrValue.ptr1; if (framePtr->numCompiledLocals) { if (!codePtr->localCachePtr) { @@ -1347,17 +1347,9 @@ TclFreeLocalCache( for (i = 0; i < localCachePtr->numVars; i++, namePtrPtr++) { register Tcl_Obj *objPtr = *namePtrPtr; - /* - * Note that this can be called with interp==NULL, on interp deletion. - * In that case, the literal table and objects go away on their own. - */ - if (objPtr) { - if (interp) { - TclReleaseLiteral(interp, objPtr); - } else { - Tcl_DecrRefCount(objPtr); - } + /* TclReleaseLiteral calls Tcl_DecrRefCount for us */ + TclReleaseLiteral(interp, objPtr); } } ckfree(localCachePtr); @@ -1368,7 +1360,7 @@ InitLocalCache( Proc *procPtr) { Interp *iPtr = procPtr->iPtr; - ByteCode *codePtr = procPtr->bodyPtr->internalRep.otherValuePtr; + ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; int localCt = procPtr->numCompiledLocals; int numArgs = procPtr->numArgs, i = 0; @@ -1445,7 +1437,7 @@ InitArgsAndLocals( { CallFrame *framePtr = ((Interp *)interp)->varFramePtr; register Proc *procPtr = framePtr->procPtr; - ByteCode *codePtr = procPtr->bodyPtr->internalRep.otherValuePtr; + ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; register Var *varPtr, *defPtr; int localCt = procPtr->numCompiledLocals, numArgs, argCt, i, imax; Tcl_Obj *const *argObjs; @@ -1632,7 +1624,7 @@ PushProcCallFrame( * commands and/or resolver changes are considered). */ - codePtr = procPtr->bodyPtr->internalRep.otherValuePtr; + codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != nsPtr) @@ -1833,7 +1825,7 @@ TclNRInterpProcCore( */ procPtr->refCount++; - codePtr = procPtr->bodyPtr->internalRep.otherValuePtr; + codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; TclNRAddCallback(interp, InterpProcNR2, procNameObj, errorProc, NULL, NULL); @@ -1863,9 +1855,39 @@ InterpProcNR2( } /* - * 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: /* @@ -1900,46 +1922,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; } /* @@ -1975,7 +1959,7 @@ TclProcCompileProc( { Interp *iPtr = (Interp *) interp; Tcl_CallFrame *framePtr; - ByteCode *codePtr = bodyPtr->internalRep.otherValuePtr; + ByteCode *codePtr = bodyPtr->internalRep.twoPtrValue.ptr1; /* * If necessary, compile the procedure's body. The compiler will allocate @@ -2095,7 +2079,7 @@ TclProcCompileProc( iPtr->invokeWord = 0; iPtr->invokeCmdFramePtr = (hePtr ? Tcl_GetHashValue(hePtr) : NULL); - tclByteCodeType.setFromAnyProc(interp, bodyPtr); + TclSetByteCodeFromAny(interp, bodyPtr, NULL, NULL); iPtr->invokeCmdFramePtr = NULL; TclPopStackFrame(interp); } else if (codePtr->nsEpoch != nsPtr->resolverEpoch) { @@ -2365,7 +2349,7 @@ TclNewProcBodyObj( TclNewObj(objPtr); if (objPtr) { objPtr->typePtr = &tclProcBodyType; - objPtr->internalRep.otherValuePtr = procPtr; + objPtr->internalRep.twoPtrValue.ptr1 = procPtr; procPtr->refCount++; } @@ -2395,10 +2379,10 @@ ProcBodyDup( Tcl_Obj *srcPtr, /* Object to copy. */ Tcl_Obj *dupPtr) /* Target object for the duplication. */ { - Proc *procPtr = srcPtr->internalRep.otherValuePtr; + Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1; dupPtr->typePtr = &tclProcBodyType; - dupPtr->internalRep.otherValuePtr = procPtr; + dupPtr->internalRep.twoPtrValue.ptr1 = procPtr; procPtr->refCount++; } @@ -2425,10 +2409,9 @@ static void ProcBodyFree( Tcl_Obj *objPtr) /* The object to clean up. */ { - Proc *procPtr = objPtr->internalRep.otherValuePtr; + Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1; - procPtr->refCount--; - if (procPtr->refCount <= 0) { + if (procPtr->refCount-- < 2) { TclProcCleanupProc(procPtr); } } @@ -2604,8 +2587,8 @@ SetLambdaFromAny( cfPtr->data.eval.path = contextPtr->data.eval.path; Tcl_IncrRefCount(cfPtr->data.eval.path); - cfPtr->cmd.str.cmd = NULL; - cfPtr->cmd.str.len = 0; + cfPtr->cmd = NULL; + cfPtr->len = 0; } /* @@ -2721,7 +2704,6 @@ TclNRApplyObjCmd( else { /* * Joe English's suggestion to allow cmdNames to function as lambdas. - * Also requires making tclCmdNameType non-static in tclObj.c */ Tcl_Obj *elemPtr; @@ -2961,10 +2943,9 @@ Tcl_DisassembleObjCmd( Tcl_WrongNumArgs(interp, 2, objv, "script"); return TCL_ERROR; } - if (objv[2]->typePtr != &tclByteCodeType) { - if (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK){ - return TCL_ERROR; - } + if ((objv[2]->typePtr != &tclByteCodeType) + && (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK)) { + return TCL_ERROR; } codeObjPtr = objv[2]; break; @@ -3061,7 +3042,7 @@ Tcl_DisassembleObjCmd( * Do the actual disassembly. */ - if (((ByteCode *) codeObjPtr->internalRep.otherValuePtr)->flags + if (((ByteCode *) codeObjPtr->internalRep.twoPtrValue.ptr1)->flags & TCL_BYTECODE_PRECOMPILED) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "may not disassemble prebuilt bytecode", -1)); diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c index 6c1dc08..6348e4a 100644 --- a/generic/tclRegexp.c +++ b/generic/tclRegexp.c @@ -578,7 +578,7 @@ Tcl_GetRegExpFromObj( * TclRegexp* when the type is tclRegexpType. */ - regexpPtr = objPtr->internalRep.otherValuePtr; + regexpPtr = objPtr->internalRep.twoPtrValue.ptr1; if ((objPtr->typePtr != &tclRegexpType) || (regexpPtr->flags != flags)) { pattern = TclGetStringFromObj(objPtr, &length); @@ -601,7 +601,7 @@ Tcl_GetRegExpFromObj( */ TclFreeIntRep(objPtr); - objPtr->internalRep.otherValuePtr = regexpPtr; + objPtr->internalRep.twoPtrValue.ptr1 = regexpPtr; objPtr->typePtr = &tclRegexpType; } return (Tcl_RegExp) regexpPtr; @@ -749,7 +749,7 @@ static void FreeRegexpInternalRep( Tcl_Obj *objPtr) /* Regexp object with internal rep to free. */ { - TclRegexp *regexpRepPtr = objPtr->internalRep.otherValuePtr; + TclRegexp *regexpRepPtr = objPtr->internalRep.twoPtrValue.ptr1; /* * If this is the last reference to the regexp, free it. @@ -783,10 +783,10 @@ DupRegexpInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - TclRegexp *regexpPtr = srcPtr->internalRep.otherValuePtr; + TclRegexp *regexpPtr = srcPtr->internalRep.twoPtrValue.ptr1; regexpPtr->refCount++; - copyPtr->internalRep.otherValuePtr = srcPtr->internalRep.otherValuePtr; + copyPtr->internalRep.twoPtrValue.ptr1 = srcPtr->internalRep.twoPtrValue.ptr1; copyPtr->typePtr = &tclRegexpType; } diff --git a/generic/tclResult.c b/generic/tclResult.c index 9707f20..2f2563a 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -230,6 +230,7 @@ Tcl_DiscardInterpState( *---------------------------------------------------------------------- */ +#undef Tcl_SaveResult void Tcl_SaveResult( Tcl_Interp *interp, /* Interpreter to save. */ @@ -304,6 +305,7 @@ Tcl_SaveResult( *---------------------------------------------------------------------- */ +#undef Tcl_RestoreResult void Tcl_RestoreResult( Tcl_Interp *interp, /* Interpreter being restored. */ @@ -372,6 +374,7 @@ Tcl_RestoreResult( *---------------------------------------------------------------------- */ +#undef Tcl_DiscardResult void Tcl_DiscardResult( Tcl_SavedResult *statePtr) /* State returned by Tcl_SaveResult. */ @@ -1109,6 +1112,7 @@ Tcl_SetObjErrorCode( *---------------------------------------------------------------------- */ +#undef Tcl_GetErrorLine int Tcl_GetErrorLine( Tcl_Interp *interp) @@ -1126,6 +1130,7 @@ Tcl_GetErrorLine( *---------------------------------------------------------------------- */ +#undef Tcl_SetErrorLine void Tcl_SetErrorLine( Tcl_Interp *interp, @@ -1587,7 +1592,7 @@ Tcl_GetReturnOptions( } if (result == TCL_ERROR) { - Tcl_AddObjErrorInfo(interp, "", -1); + Tcl_AddErrorInfo(interp, ""); Tcl_DictObjPut(NULL, options, keys[KEY_ERRORSTACK], iPtr->errorStack); } if (iPtr->errorCode) { diff --git a/generic/tclScan.c b/generic/tclScan.c index ef7eedf..4dfc2d6 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -406,11 +406,14 @@ ValidateFormat( */ case 'd': case 'e': + case 'E': case 'f': case 'g': + case 'G': case 'i': case 'o': case 'x': + case 'X': case 'b': break; case 'u': @@ -743,6 +746,7 @@ Tcl_ScanObjCmd( parseFlag |= TCL_PARSE_OCTAL_ONLY | TCL_PARSE_SCAN_PREFIXES; break; case 'x': + case 'X': op = 'i'; parseFlag |= TCL_PARSE_HEXADECIMAL_ONLY; break; @@ -758,7 +762,9 @@ Tcl_ScanObjCmd( case 'f': case 'e': + case 'E': case 'g': + case 'G': op = 'f'; break; diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 2d534a68..883e2ea 100755 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -1239,7 +1239,7 @@ TclParseNumber( if (!octalSignificandOverflow) { if (octalSignificandWide > (Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) { -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG if (octalSignificandWide <= (MOST_BITS + signum)) { objPtr->typePtr = &tclWideIntType; if (signum) { @@ -1286,7 +1286,7 @@ TclParseNumber( if (!significandOverflow) { if (significandWide > (Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) { -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG if (significandWide <= MOST_BITS+signum) { objPtr->typePtr = &tclWideIntType; if (signum) { diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 04cf4ee..c04944d 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -140,9 +140,9 @@ typedef struct String { #define stringAttemptRealloc(ptr, numChars) \ (String *) attemptckrealloc((ptr), (unsigned) STRING_SIZE(numChars) ) #define GET_STRING(objPtr) \ - ((String *) (objPtr)->internalRep.otherValuePtr) + ((String *) (objPtr)->internalRep.twoPtrValue.ptr1) #define SET_STRING(objPtr, stringPtr) \ - ((objPtr)->internalRep.otherValuePtr = (void *) (stringPtr)) + ((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (stringPtr)) /* * TCL STRING GROWTH ALGORITHM @@ -1123,7 +1123,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; } /* @@ -1281,23 +1282,43 @@ Tcl_AppendObjToObj( if ((TclIsPureByteArray(objPtr) || objPtr->bytes == tclEmptyStringRep) && TclIsPureByteArray(appendObjPtr)) { - unsigned char *bytesSrc; - int lengthSrc, lengthTotal; /* - * We do not assume that objPtr and appendObjPtr must be distinct! - * This makes this code a bit more complex than it otherwise would be, - * but in turn makes it much safer. + * 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. */ + /* Get 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; } @@ -1415,7 +1436,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 +1458,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; @@ -1577,7 +1600,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 +1628,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; } @@ -2638,6 +2663,38 @@ Tcl_ObjPrintf( /* *--------------------------------------------------------------------------- * + * 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; +} +/* + *--------------------------------------------------------------------------- + * * TclStringObjReverse -- * * Implements the [string reverse] operation. @@ -2828,7 +2885,11 @@ ExtendUnicodeRepWithString( } 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); } 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 1d1fe15..7a84cba 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -42,6 +42,11 @@ #undef TclpGetPid #undef TclSockMinimumBuffers #define TclBackgroundException Tcl_BackgroundException +#undef Tcl_SetIntObj +#undef TclpInetNtoa +#undef TclWinGetServByName +#undef TclWinGetSockOpt +#undef TclWinSetSockOpt /* See bug 510001: TclSockMinimumBuffers needs plat imp */ #ifdef _WIN64 @@ -54,6 +59,31 @@ static int TclSockMinimumBuffersOld(int sock, int size) } #endif +#define TclSetStartupScriptPath setStartupScriptPath +static void TclSetStartupScriptPath(Tcl_Obj *path) +{ + Tcl_SetStartupScript(path, NULL); +} +#define TclGetStartupScriptPath getStartupScriptPath +static Tcl_Obj *TclGetStartupScriptPath(void) +{ + return Tcl_GetStartupScript(NULL); +} +#define TclSetStartupScriptFileName setStartupScriptFileName +static void TclSetStartupScriptFileName( + const char *fileName) +{ + Tcl_SetStartupScript(Tcl_NewStringObj(fileName,-1), NULL); +} +#define TclGetStartupScriptFileName getStartupScriptFileName +static const char *TclGetStartupScriptFileName(void) +{ + Tcl_Obj *path = Tcl_GetStartupScript(NULL); + if (path == NULL) { + return NULL; + } + return Tcl_GetStringFromObj(path, NULL); +} #if defined(_WIN32) || defined(__CYGWIN__) #undef TclWinNToHS @@ -63,7 +93,7 @@ static unsigned short TclWinNToHS(unsigned short ns) { } #endif -#ifdef __WIN32__ +#ifdef _WIN32 # define TclUnixWaitForFile 0 # define TclUnixCopyFile 0 # define TclUnixOpenTemporaryFile 0 @@ -84,7 +114,8 @@ TclpIsAtty(int fd) return isatty(fd); } -int +#define TclWinGetPlatformId winGetPlatformId +static int TclWinGetPlatformId() { /* Don't bother to determine the real platform on cygwin, @@ -100,27 +131,31 @@ void *TclWinGetTclInstance() return hInstance; } -int +#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); } -char * +#define TclWinNoBackslash winNoBackslash +static char * TclWinNoBackslash(char *path) { char *p; @@ -171,6 +206,89 @@ Tcl_WinTCharToUtf( string, len, dsPtr); } +#if defined(TCL_WIDE_INT_IS_LONG) +/* On Cygwin64, long is 64-bit while on Win64 long is 32-bit. Therefore + * we have to make sure that all stub entries on Cygwin64 follow the Win64 + * signature. Tcl 9 must find a better solution, but that cannot be done + * without introducing a binary incompatibility. + */ +#define Tcl_DbNewLongObj ((Tcl_Obj*(*)(long,const char*,int))dbNewLongObj) +static Tcl_Obj *dbNewLongObj( + int intValue, + const char *file, + int line +) { +#ifdef TCL_MEM_DEBUG + register Tcl_Obj *objPtr; + + TclDbNewObj(objPtr, file, line); + objPtr->bytes = NULL; + + objPtr->internalRep.longValue = (long) intValue; + objPtr->typePtr = &tclIntType; + return objPtr; +#else + return Tcl_NewIntObj(intValue); +#endif +} +#define Tcl_GetLongFromObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))Tcl_GetIntFromObj +#define Tcl_NewLongObj (Tcl_Obj*(*)(long))Tcl_NewIntObj +#define Tcl_SetLongObj (void(*)(Tcl_Obj*,long))Tcl_SetIntObj +static int exprInt(Tcl_Interp *interp, const char *expr, int *ptr){ + long longValue; + int result = Tcl_ExprLong(interp, expr, &longValue); + if (result == TCL_OK) { + if ((longValue >= -(long)(UINT_MAX)) + && (longValue <= (long)(UINT_MAX))) { + *ptr = (int)longValue; + } else { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "integer value too large to represent as non-long integer", -1)); + result = TCL_ERROR; + } + } + return result; +} +#define Tcl_ExprLong (int(*)(Tcl_Interp*,const char*,long*))exprInt +static int exprIntObj(Tcl_Interp *interp, Tcl_Obj*expr, int *ptr){ + long longValue; + int result = Tcl_ExprLongObj(interp, expr, &longValue); + if (result == TCL_OK) { + if ((longValue >= -(long)(UINT_MAX)) + && (longValue <= (long)(UINT_MAX))) { + *ptr = (int)longValue; + } else { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "integer value too large to represent as non-long integer", -1)); + result = TCL_ERROR; + } + } + return result; +} +#define Tcl_ExprLongObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))exprIntObj +static int uniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned int n){ + return Tcl_UniCharNcmp(ucs, uct, (unsigned long)n); +} +#define Tcl_UniCharNcmp (int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long))uniCharNcmp +static int utfNcmp(const char *s1, const char *s2, unsigned int n){ + return Tcl_UtfNcmp(s1, s2, (unsigned long)n); +} +#define Tcl_UtfNcmp (int(*)(const char*,const char*,unsigned long))utfNcmp +static int utfNcasecmp(const char *s1, const char *s2, unsigned int n){ + return Tcl_UtfNcasecmp(s1, s2, (unsigned long)n); +} +#define Tcl_UtfNcasecmp (int(*)(const char*,const char*,unsigned long))utfNcasecmp +static int uniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned int n){ + return Tcl_UniCharNcasecmp(ucs, uct, (unsigned long)n); +} +#define Tcl_UniCharNcasecmp (int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long))uniCharNcasecmp +static int formatInt(char *buffer, int n){ + return TclFormatInt(buffer, (long)n); +} +#define TclFormatInt (int(*)(char *, long))formatInt + +#endif + #else /* UNIX and MAC */ # define TclpLocaltime_unix TclpLocaltime # define TclpGmtime_unix TclpGmtime @@ -348,8 +466,8 @@ static const TclIntStubs tclIntStubs = { 0, /* 155 */ TclRegError, /* 156 */ TclVarTraceExists, /* 157 */ - 0, /* 158 */ - 0, /* 159 */ + TclSetStartupScriptFileName, /* 158 */ + TclGetStartupScriptFileName, /* 159 */ 0, /* 160 */ TclChannelTransform, /* 161 */ TclChannelEventScriptInvoker, /* 162 */ @@ -357,8 +475,8 @@ static const TclIntStubs tclIntStubs = { TclExpandCodeArray, /* 164 */ TclpSetInitialEncodings, /* 165 */ TclListObjSetElement, /* 166 */ - 0, /* 167 */ - 0, /* 168 */ + TclSetStartupScriptPath, /* 167 */ + TclGetStartupScriptPath, /* 168 */ TclpUtfNcmp2, /* 169 */ TclCheckInterpTraces, /* 170 */ TclCheckExecutionTraces, /* 171 */ @@ -441,12 +559,13 @@ static const TclIntStubs tclIntStubs = { TclCopyChannel, /* 248 */ TclDoubleDigits, /* 249 */ TclSetSlaveCancelFlags, /* 250 */ + TclRegisterLiteral, /* 251 */ }; 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 */ @@ -479,7 +598,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 */ @@ -550,7 +669,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 */ @@ -647,19 +766,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 */ @@ -821,10 +940,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 */ diff --git a/generic/tclTest.c b/generic/tclTest.c index 297fe4d..a27c95a 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -19,7 +19,6 @@ #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif -#include <sys/stat.h> #include "tclInt.h" #include "tclOO.h" #include <math.h> @@ -328,10 +327,12 @@ static int TestreturnObjCmd(ClientData dummy, Tcl_Obj *const objv[]); static void TestregexpXflags(const char *string, int length, int *cflagsPtr, int *eflagsPtr); +#ifndef TCL_NO_DEPRECATED static int TestsaveresultCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static void TestsaveresultFree(char *blockPtr); +#endif /* TCL_NO_DEPRECATED */ static int TestsetassocdataCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestsetCmd(ClientData dummy, @@ -413,7 +414,7 @@ static int TestNRELevels(ClientData clientData, 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[]); @@ -524,7 +525,9 @@ int Tcltest_Init( Tcl_Interp *interp) /* Interpreter for application. */ { +#ifndef TCL_NO_DEPRECATED Tcl_ValueType t3ArgTypes[2]; +#endif /* TCL_NO_DEPRECATED */ Tcl_Obj *listPtr; Tcl_Obj **objv; @@ -643,8 +646,10 @@ Tcltest_Init( NULL, NULL); Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd, NULL, NULL); +#ifndef TCL_NO_DEPRECATED Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd, NULL, NULL); +#endif /* TCL_NO_DEPRECATED */ Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd, @@ -666,22 +671,26 @@ Tcltest_Init( Tcl_CreateCommand(interp, "testtranslatefilename", TesttranslatefilenameCmd, NULL, NULL); Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, NULL, NULL); +#ifndef TCL_NO_DEPRECATED Tcl_CreateMathFunc(interp, "T1", 0, NULL, TestMathFunc, (ClientData) 123); Tcl_CreateMathFunc(interp, "T2", 0, NULL, TestMathFunc, (ClientData) 345); +#endif /* TCL_NO_DEPRECATED */ Tcl_CreateCommand(interp, "testmainthread", TestmainthreadCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetmainloop", TestsetmainloopCmd, 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, "testnrelevels", TestNRELevels, NULL, NULL); @@ -1546,14 +1555,14 @@ DelCallbackProc( * * TestdelCmd -- * - * This procedure implements the "testdcall" command. It is used - * to test Tcl_CallWhenDeleted. + * This procedure implements the "testdel" command. It is used + * to test calling of command deletion callbacks. * * Results: * A standard Tcl result. * * Side effects: - * Creates and deletes interpreters. + * Creates a command. * *---------------------------------------------------------------------- */ @@ -1847,7 +1856,7 @@ TestdstringCmd( if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) { return TCL_ERROR; } - Tcl_DStringTrunc(&dstring, count); + Tcl_DStringSetLength(&dstring, count); } else if (strcmp(argv[1], "start") == 0) { if (argc != 2) { goto wrongNumArgs; @@ -4399,8 +4408,26 @@ TestseterrorcodeCmd( Tcl_SetResult(interp, "too many args", TCL_STATIC); return TCL_ERROR; } - Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], - argv[5], NULL); + switch (argc) { + case 1: + Tcl_SetErrorCode(interp, "NONE", NULL); + break; + case 2: + Tcl_SetErrorCode(interp, argv[1], NULL); + break; + case 3: + Tcl_SetErrorCode(interp, argv[1], argv[2], NULL); + break; + case 4: + Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], NULL); + break; + case 5: + Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], NULL); + break; + case 6: + Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], + argv[5], NULL); + } return TCL_ERROR; } @@ -5004,6 +5031,7 @@ Testset2Cmd( } } +#ifndef TCL_NO_DEPRECATED /* *---------------------------------------------------------------------- * @@ -5137,6 +5165,7 @@ TestsaveresultFree( { freeCount++; } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -6171,7 +6200,7 @@ TestReport( * API, but there you go. We should convert it to objects. */ - Tcl_SavedResult savedResult; + Tcl_Obj *savedResult; Tcl_DString ds; Tcl_DStringInit(&ds); @@ -6185,11 +6214,15 @@ TestReport( Tcl_DStringAppendElement(&ds, Tcl_GetString(arg2)); } Tcl_DStringEndSublist(&ds); - Tcl_SaveResult(interp, &savedResult); + savedResult = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(savedResult); + Tcl_SetObjResult(interp, Tcl_NewObj()); Tcl_Eval(interp, Tcl_DStringValue(&ds)); Tcl_DStringFree(&ds); - Tcl_RestoreResult(interp, &savedResult); - } + Tcl_ResetResult(interp); + Tcl_SetObjResult(interp, savedResult); + Tcl_DecrRefCount(savedResult); + } } static int @@ -6615,7 +6648,7 @@ TestNumUtfCharsCmd( return TCL_OK; } -#if defined(HAVE_CPUID) || defined(__WIN32__) +#if defined(HAVE_CPUID) || defined(_WIN32) /* *---------------------------------------------------------------------- * diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index 4bddc42..f36b07f 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -555,7 +555,7 @@ TestindexobjCmd( } Tcl_GetIndexFromObj(NULL, objv[1], tablePtr, "token", 0, &index); - indexRep = objv[1]->internalRep.otherValuePtr; + indexRep = objv[1]->internalRep.twoPtrValue.ptr1; indexRep->index = index2; result = Tcl_GetIndexFromObj(NULL, objv[1], tablePtr, "token", 0, &index); @@ -592,7 +592,7 @@ TestindexobjCmd( if (objv[3]->typePtr != NULL && !strcmp("index", objv[3]->typePtr->name)) { - indexRep = objv[3]->internalRep.otherValuePtr; + indexRep = objv[3]->internalRep.twoPtrValue.ptr1; if (indexRep->tablePtr == (void *) argv) { TclFreeIntRep(objv[3]); } @@ -1250,7 +1250,7 @@ TeststringobjCmd( if (varPtr[varIndex] != NULL) { Tcl_ConvertToType(NULL, varPtr[varIndex], Tcl_GetObjType("string")); - strPtr = varPtr[varIndex]->internalRep.otherValuePtr; + strPtr = varPtr[varIndex]->internalRep.twoPtrValue.ptr1; length = (int) strPtr->allocated; } else { length = -1; @@ -1304,7 +1304,7 @@ TeststringobjCmd( if (varPtr[varIndex] != NULL) { Tcl_ConvertToType(NULL, varPtr[varIndex], Tcl_GetObjType("string")); - strPtr = varPtr[varIndex]->internalRep.otherValuePtr; + strPtr = varPtr[varIndex]->internalRep.twoPtrValue.ptr1; length = strPtr->maxChars; } else { length = -1; diff --git a/generic/tclThread.c b/generic/tclThread.c index d1f2691..8c972a8 100644 --- a/generic/tclThread.c +++ b/generic/tclThread.c @@ -339,8 +339,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. @@ -355,6 +356,9 @@ void TclFinalizeThreadData(void) { TclFinalizeThreadDataThread(); +#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) + TclFinalizeThreadAllocThread(); +#endif } /* diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c index e4261d6..ddf888a 100644 --- a/generic/tclThreadAlloc.c +++ b/generic/tclThreadAlloc.c @@ -573,7 +573,7 @@ TclThreadAllocObj(void) } while (--numMove >= 0) { objPtr = &newObjsPtr[numMove]; - objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr; + objPtr->internalRep.twoPtrValue.ptr1 = cachePtr->firstObjPtr; cachePtr->firstObjPtr = objPtr; } } @@ -584,7 +584,7 @@ TclThreadAllocObj(void) */ objPtr = cachePtr->firstObjPtr; - cachePtr->firstObjPtr = objPtr->internalRep.otherValuePtr; + cachePtr->firstObjPtr = objPtr->internalRep.twoPtrValue.ptr1; cachePtr->numObjects--; return objPtr; } @@ -621,7 +621,7 @@ TclThreadFreeObj( * Get this thread's list and push on the free Tcl_Obj. */ - objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr; + objPtr->internalRep.twoPtrValue.ptr1 = cachePtr->firstObjPtr; cachePtr->firstObjPtr = objPtr; cachePtr->numObjects++; @@ -722,16 +722,16 @@ MoveObjs( */ while (--numMove) { - objPtr = objPtr->internalRep.otherValuePtr; + objPtr = objPtr->internalRep.twoPtrValue.ptr1; } - fromPtr->firstObjPtr = objPtr->internalRep.otherValuePtr; + fromPtr->firstObjPtr = objPtr->internalRep.twoPtrValue.ptr1; /* * Move all objects as a block - they are already linked to each other, we * just have to update the first and last. */ - objPtr->internalRep.otherValuePtr = toPtr->firstObjPtr; + objPtr->internalRep.twoPtrValue.ptr1 = toPtr->firstObjPtr; toPtr->firstObjPtr = fromFirstObjPtr; } @@ -1023,6 +1023,33 @@ TclFinalizeThreadAlloc(void) TclpFreeAllocCache(NULL); } +/* + *---------------------------------------------------------------------- + * + * TclFinalizeThreadAllocThread -- + * + * This procedure is used to destroy single thread private resources used + * in this file. + * Called in TclpFinalizeThreadData when a thread exits (Tcl_FinalizeThread). + * + * 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/tclThreadTest.c b/generic/tclThreadTest.c index b90e33d..02ee038 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -337,7 +337,7 @@ ThreadObjCmd( */ if (objc == 2) { - idObj = Tcl_NewLongObj((long)(size_t)Tcl_GetCurrentThread()); + idObj = Tcl_NewWideIntObj((Tcl_WideInt)(size_t)Tcl_GetCurrentThread()); } else if (objc == 3 && strcmp("-main", Tcl_GetString(objv[2])) == 0) { Tcl_MutexLock(&threadMutex); @@ -355,14 +355,14 @@ ThreadObjCmd( return TCL_ERROR; } case THREAD_JOIN: { - long id; + Tcl_WideInt id; int result, status; if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "id"); return TCL_ERROR; } - if (Tcl_GetLongFromObj(interp, objv[2], &id) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[2], &id) != TCL_OK) { return TCL_ERROR; } @@ -372,7 +372,7 @@ ThreadObjCmd( } else { char buf[20]; - TclFormatInt(buf, id); + sprintf(buf, "%" TCL_LL_MODIFIER "d", id); Tcl_AppendResult(interp, "cannot join thread ", buf, NULL); } return result; @@ -384,7 +384,7 @@ ThreadObjCmd( } return ThreadList(interp); case THREAD_SEND: { - long id; + Tcl_WideInt id; const char *script; int wait, arg; @@ -403,7 +403,7 @@ ThreadObjCmd( wait = 1; arg = 2; } - if (Tcl_GetLongFromObj(interp, objv[arg], &id) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[arg], &id) != TCL_OK) { return TCL_ERROR; } arg++; @@ -523,7 +523,7 @@ ThreadCreate( Tcl_ConditionWait(&ctrl.condWait, &threadMutex, NULL); Tcl_MutexUnlock(&threadMutex); Tcl_ConditionFinalize(&ctrl.condWait); - Tcl_SetObjResult(interp, Tcl_NewLongObj((long)(size_t)id)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)(size_t)id)); return TCL_OK; } @@ -655,7 +655,7 @@ ThreadErrorProc( char *script; char buf[TCL_DOUBLE_SPACE+1]; - TclFormatInt(buf, (size_t) Tcl_GetCurrentThread()); + sprintf(buf, "%" TCL_LL_MODIFIER "d", (Tcl_WideInt)(size_t)Tcl_GetCurrentThread()); errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); if (errorProcString == NULL) { @@ -773,7 +773,7 @@ ThreadList( Tcl_MutexLock(&threadMutex); for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) { Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewLongObj((long)(size_t)tsdPtr->threadId)); + Tcl_NewWideIntObj((Tcl_WideInt)(size_t)tsdPtr->threadId)); } Tcl_MutexUnlock(&threadMutex); Tcl_SetObjResult(interp, listPtr); @@ -926,10 +926,11 @@ ThreadSend( ckfree(resultPtr->errorInfo); } } - Tcl_SetResult(interp, resultPtr->result, TCL_DYNAMIC); + Tcl_AppendResult(interp, resultPtr->result, NULL); Tcl_ConditionFinalize(&resultPtr->done); code = resultPtr->code; + ckfree(resultPtr->result); ckfree(resultPtr); return code; diff --git a/generic/tclTimer.c b/generic/tclTimer.c index 6b17825..c10986a 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -819,7 +819,7 @@ Tcl_AfterObjCmd( */ if (objv[1]->typePtr == &tclIntType -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG || objv[1]->typePtr == &tclWideIntType #endif || objv[1]->typePtr == &tclBignumType diff --git a/generic/tclTomMathDecls.h b/generic/tclTomMathDecls.h index ef22153..69b095c 100644 --- a/generic/tclTomMathDecls.h +++ b/generic/tclTomMathDecls.h @@ -134,6 +134,10 @@ /* !BEGIN!: Do not edit below this line. */ +#ifdef __cplusplus +extern "C" { +#endif + /* * Exported function declarations: */ @@ -346,10 +350,8 @@ typedef struct TclTomMathStubs { int (*tclBN_mp_cnt_lsb) (const mp_int *a); /* 63 */ } TclTomMathStubs; -#ifdef __cplusplus -extern "C" { -#endif extern const TclTomMathStubs *tclTomMathStubsPtr; + #ifdef __cplusplus } #endif diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 519f201..c0cde49 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -155,8 +155,8 @@ typedef struct StringTraceData { #define FOREACH_VAR_TRACE(interp, name, clientData) \ (clientData) = NULL; \ - while (((clientData) = Tcl_VarTraceInfo((interp), (name), 0, \ - TraceVarProc, (clientData))) != NULL) + while (((clientData) = Tcl_VarTraceInfo2((interp), (name), NULL, \ + 0, TraceVarProc, (clientData))) != NULL) #define FOREACH_COMMAND_TRACE(interp, name, clientData) \ (clientData) = NULL; \ @@ -1322,7 +1322,7 @@ TraceCommandProc( Tcl_DStringLength(&cmd), 0); if (code != TCL_OK) { /* We ignore errors in these traced commands */ - /*** QUESTION: Use Tcl_BackgroundError(interp); instead? ***/ + /*** QUESTION: Use Tcl_BackgroundException(interp, code); instead? ***/ } Tcl_DStringFree(&cmd); } @@ -1485,7 +1485,11 @@ TclCheckExecutionTraces( } iPtr->activeCmdTracePtr = active.nextPtr; if (state) { - Tcl_RestoreInterpState(interp, state); + if (traceCode == TCL_OK) { + (void) Tcl_RestoreInterpState(interp, state); + } else { + Tcl_DiscardInterpState(state); + } } return traceCode; @@ -2811,6 +2815,7 @@ DisposeTraceResult( *---------------------------------------------------------------------- */ +#undef Tcl_UntraceVar void Tcl_UntraceVar( Tcl_Interp *interp, /* Interpreter containing variable. */ @@ -2979,6 +2984,7 @@ Tcl_UntraceVar2( *---------------------------------------------------------------------- */ +#undef Tcl_VarTraceInfo ClientData Tcl_VarTraceInfo( Tcl_Interp *interp, /* Interpreter containing variable. */ @@ -3087,6 +3093,7 @@ Tcl_VarTraceInfo2( *---------------------------------------------------------------------- */ +#undef Tcl_TraceVar int Tcl_TraceVar( Tcl_Interp *interp, /* Interpreter in which variable is to be diff --git a/generic/tclUniData.c b/generic/tclUniData.c index 5c88639..78e7d17 100644 --- a/generic/tclUniData.c +++ b/generic/tclUniData.c @@ -30,35 +30,35 @@ static const unsigned short pageMap[] = { 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, + 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, 2784, 2912, 2944, 2976, 3008, 3040, 3072, 3104, 3136, 3168, + 3200, 1792, 3232, 3264, 3296, 1792, 3328, 3360, 3392, 3424, 3456, 3488, + 3520, 1792, 1344, 3552, 3584, 3616, 3648, 3680, 3712, 3744, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 3776, 1344, 3808, 3840, + 3872, 1344, 3904, 1344, 3936, 3968, 4000, 1344, 1344, 4032, 4064, 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, 4096, 4128, 1344, 1344, 4160, 4192, 4224, + 4256, 4288, 1344, 4320, 4352, 4384, 4416, 1344, 4448, 4480, 1344, 4512, + 1344, 4544, 4576, 4608, 4640, 4672, 1344, 4704, 4736, 4768, 4800, 1344, + 4832, 4864, 4896, 4928, 1792, 1792, 4960, 4992, 5024, 5056, 5088, 5120, + 1344, 5152, 1344, 5184, 5216, 5248, 1792, 1792, 5280, 5312, 5344, 5376, + 5408, 5440, 5472, 5408, 704, 5504, 224, 224, 224, 224, 5536, 224, 224, + 224, 5568, 5600, 5632, 5664, 5696, 5728, 5760, 5792, 5824, 5856, 5888, + 5920, 5952, 5984, 6016, 6048, 6080, 6112, 6144, 6176, 6208, 6240, 6272, + 6304, 6336, 6336, 6336, 6336, 6336, 6336, 6336, 6336, 6368, 6400, 4768, + 6432, 6464, 6496, 6528, 6560, 4768, 6592, 6624, 6656, 6688, 6720, 6752, + 6784, 4768, 4768, 4768, 4768, 4768, 6816, 6848, 6880, 4768, 4768, 4768, + 6912, 4768, 4768, 4768, 4768, 4768, 4768, 4768, 6944, 6976, 4768, 7008, + 7040, 4768, 4768, 4768, 4768, 4768, 4768, 4768, 4768, 6336, 6336, 6336, + 6336, 7072, 6336, 7104, 7136, 6336, 6336, 6336, 6336, 6336, 6336, 6336, + 6336, 4768, 7168, 7200, 7232, 7264, 7296, 7328, 1792, 7360, 7392, 7424, + 7456, 224, 224, 224, 7488, 7520, 7552, 1344, 7584, 7616, 7648, 7648, + 704, 7680, 7712, 7744, 1792, 7776, 4768, 4768, 7808, 4768, 4768, 4768, + 4768, 4768, 4768, 7840, 7872, 7904, 7936, 3136, 1344, 7968, 4064, 1344, + 8000, 8032, 8064, 1344, 1344, 8096, 8128, 4768, 8160, 8192, 8224, 8256, + 4768, 8224, 8288, 4768, 8192, 4768, 4768, 4768, 4768, 4768, 4768, 4768, + 4768, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 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, 4544, 4768, 4768, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 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,16 +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, 8320, + 1792, 8352, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 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, 8384, 4768, 8416, 5248, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 8448, 8480, 224, 8512, 8544, 1344, 1344, 8576, 8608, 8640, 224, + 8672, 8704, 8736, 1792, 8768, 8800, 8832, 1344, 8864, 8896, 8928, 8960, + 8992, 1632, 9024, 9056, 9088, 1888, 9120, 9152, 9184, 1344, 9216, 9248, + 9280, 1344, 9312, 9344, 9376, 9408, 9440, 9472, 9504, 1792, 1792, 1344, + 9536, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 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,73 +167,72 @@ 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, 9568, 9600, 9632, 9664, 9664, 9664, 9664, 9664, 9664, 9664, + 9664, 9664, 9664, 9664, 9664, 9664, 9664, 9664, 9664, 9664, 9664, 9664, + 9664, 9664, 9664, 9664, 9664, 9664, 9664, 9664, 9664, 9664, 9664, 9664, + 9664, 9664, 9664, 9664, 9664, 9664, 9664, 9664, 9664, 9664, 9664, 9664, + 9664, 9664, 9664, 9664, 9664, 9664, 9664, 9664, 9664, 9664, 9664, 9664, + 9664, 9664, 9664, 9664, 9664, 9664, 9664, 9664, 9664, 9696, 9696, 9696, + 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, + 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, + 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, + 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, + 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, + 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, + 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, + 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, + 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, + 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, + 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, + 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, + 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, + 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, + 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, + 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, 9696, + 9696, 9696, 9696, 9696, 9696, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 9728, 1344, 1344, 9760, 1792, 9792, 9824, 9856, + 1344, 1344, 9888, 9920, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 9952, 9984, 1344, 10016, 1344, 10048, 10080, 10112, 10144, + 10176, 10208, 1344, 1344, 1344, 10240, 10272, 64, 10304, 10336, 10368, + 4576, 10400, 10432 #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, + ,10464, 10496, 10528, 1792, 1344, 1344, 1344, 8128, 10560, 10592, 10624, + 10656, 10688, 10720, 10752, 10784, 1792, 1792, 1792, 1792, 9088, 1344, + 10816, 10848, 1344, 10880, 10912, 10944, 10976, 1344, 11008, 1792, + 11040, 11072, 11104, 1344, 11136, 11168, 1792, 1792, 1344, 11200, 1344, + 11232, 1792, 1792, 1792, 1792, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 7616, 4544, 10048, 1792, 1792, 1792, 1792, 11264, + 11296, 11328, 11360, 4576, 11392, 1792, 1792, 11424, 11456, 1792, 1792, + 1344, 11488, 1792, 1792, 11520, 11552, 11584, 11616, 11648, 1792, 11680, + 11712, 1344, 11744, 11776, 11808, 11840, 11872, 1792, 1792, 1344, 1344, + 11904, 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, 11968, 12000, 12032, + 12064, 5088, 12096, 12128, 12160, 12192, 12224, 12256, 12288, 5088, + 12320, 12352, 12384, 12416, 12448, 1792, 1792, 1792, 9984, 12480, 12512, + 2400, 2304, 12544, 12576, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1344, 12608, 12640, 1792, 1792, 1792, 1792, 1792, 1344, 12672, + 12704, 1792, 1344, 12736, 12768, 1792, 1344, 12800, 11168, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 12832, 12864, 12896, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 1344, 12928, 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, + 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, 11744, 1792, 1792, - 1792, 1792, 10368, 10368, 10368, 11776, 1792, 1792, 1792, 1792, 1792, + 1344, 1344, 1344, 1344, 1344, 12928, 1792, 1792, 1792, 10624, 10624, + 10624, 12960, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 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, + 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, - 11744, 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, 12992, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, @@ -266,16 +265,14 @@ static const unsigned short pageMap[] = { 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 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, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 12928, 4576, + 13024, 1792, 1792, 9984, 13056, 1344, 13088, 13120, 13152, 13184, 1792, 1792, 1792, 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, 13216, 13248, 13280, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, @@ -314,11 +311,11 @@ static const unsigned short pageMap[] = { 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 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, 13312, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, @@ -326,6 +323,8 @@ static const unsigned short pageMap[] = { 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 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, 13344, + 13376, 13408, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, @@ -336,15 +335,15 @@ static const unsigned short pageMap[] = { 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 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, 4768, 4768, 4768, 4768, 4768, 4768, 4768, 7840, 4768, 13440, + 4768, 13472, 13504, 13536, 13568, 1792, 4768, 4768, 13600, 1792, 1792, + 1792, 1792, 1792, 4768, 4768, 13632, 13664, 1792, 1792, 1792, 1792, + 13696, 13728, 13760, 13792, 13824, 13856, 13888, 13920, 13952, 13984, + 14016, 14048, 14080, 13696, 13728, 14112, 13792, 14144, 14176, 14208, + 13920, 14240, 14272, 14304, 14336, 14368, 14400, 14432, 14464, 14496, + 14528, 14560, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, @@ -354,23 +353,24 @@ static const unsigned short pageMap[] = { 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 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, 14592, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 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, + 14624, 14656, 14688, 14720, 14752, 14784, 1792, 14816, 1792, 1792, + 1792, 1792, 1792, 1792, 1792, 1792, 4768, 14848, 4768, 4768, 7808, + 14880, 14912, 7840, 14944, 14976, 4768, 14848, 15008, 1792, 1792, 15040, + 15072, 15008, 15104, 1792, 1792, 1792, 1792, 1792, 4768, 15136, 4768, + 13568, 4768, 4768, 15168, 15200, 4768, 4768, 4768, 4768, 4768, 4768, + 4768, 8192, 4768, 4768, 15232, 7776, 4768, 15264, 4768, 4768, 4768, + 4768, 15296, 4768, 4768, 4768, 15328, 15360, 4768, 4768, 4768, 7808, + 4768, 4768, 15392, 1792, 14848, 4768, 15424, 4768, 15456, 15488, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 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, + 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, 1344, 1344, 1344, 1344, 1344, 1344, @@ -480,8 +480,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, 7616, + 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, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, @@ -491,8 +492,8 @@ 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, + 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 4032, 1344, + 1344, 1344, 1344, 1344, 1344, 11136, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, @@ -535,8 +536,8 @@ static const unsigned short pageMap[] = { 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 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 + 1792, 1792, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, + 1344, 1344, 1344, 1344, 1344, 1344, 11136 #endif /* TCL_UTF_MAX > 3 */ }; @@ -577,333 +578,336 @@ 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, 21, 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, 21, 89, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, + 90, 90, 90, 90, 90, 90, 90, 90, 11, 11, 11, 11, 90, 90, 90, 90, 90, + 90, 90, 90, 90, 90, 90, 90, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, + 11, 11, 11, 11, 90, 90, 90, 90, 90, 11, 11, 11, 11, 11, 11, 11, 90, + 11, 90, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, + 11, 11, 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, 92, 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, 23, 24, 23, + 24, 90, 11, 23, 24, 0, 0, 90, 42, 42, 42, 3, 93, 0, 0, 0, 0, 11, 11, + 94, 3, 95, 95, 95, 0, 96, 0, 97, 97, 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, + 10, 10, 10, 98, 99, 99, 99, 21, 13, 13, 13, 13, 13, 13, 13, 13, 13, + 13, 13, 13, 13, 13, 13, 13, 13, 100, 13, 13, 13, 13, 13, 13, 13, 13, + 13, 101, 102, 102, 103, 104, 105, 106, 106, 106, 107, 108, 109, 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, + 23, 24, 23, 24, 23, 24, 110, 111, 112, 113, 114, 115, 7, 23, 24, 116, + 23, 24, 21, 54, 54, 54, 117, 117, 117, 117, 117, 117, 117, 117, 117, + 117, 117, 117, 117, 117, 117, 117, 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, + 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, 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, + 13, 13, 13, 13, 13, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, + 111, 111, 111, 111, 111, 111, 23, 24, 14, 91, 91, 91, 91, 91, 118, + 118, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, + 23, 24, 23, 24, 23, 24, 119, 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, 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, - 0, 0, 0, 0, 0, 0, 0, 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, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 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, 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, 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, + 24, 23, 24, 0, 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, + 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, + 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, 0, + 0, 90, 3, 3, 3, 3, 3, 3, 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, 21, 0, 3, 8, 0, 0, 14, 14, 4, 0, 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, 8, 91, 3, 91, 91, 3, 91, 91, 3, 91, 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, 17, 7, 7, 7, 3, 3, 4, 3, 3, 14, 14, 91, 91, 91, 91, 91, 91, 91, + 91, 91, 91, 91, 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, 90, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, + 91, 91, 91, 91, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 3, 3, 15, 15, 91, 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, - 15, 15, 15, 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, + 15, 3, 15, 91, 91, 91, 91, 91, 91, 91, 17, 14, 91, 91, 91, 91, 91, + 91, 90, 90, 91, 91, 14, 91, 91, 91, 91, 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, 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, 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, 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, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 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, 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, 91, 91, + 91, 91, 91, 91, 91, 91, 91, 90, 90, 14, 3, 3, 3, 90, 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, 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, 91, 91, 91, 91, 90, 91, 91, 91, 91, 91, 91, 91, + 91, 91, 90, 91, 91, 91, 90, 91, 91, 91, 91, 91, 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, 91, + 91, 91, 0, 0, 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, 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, 0, 0, 0, 0, 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, 123, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 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, 123, 91, 15, 123, 123, + 123, 91, 91, 91, 91, 91, 91, 91, 91, 123, 123, 123, 123, 91, 123, 123, + 15, 91, 91, 91, 91, 91, 91, 91, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 91, 91, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 90, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 91, 123, 123, 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, + 91, 15, 123, 123, 123, 91, 91, 91, 91, 0, 0, 123, 123, 0, 0, 123, 123, + 91, 15, 0, 0, 0, 0, 0, 0, 0, 0, 123, 0, 0, 0, 0, 15, 15, 0, 15, 15, + 15, 91, 91, 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, 91, 91, 123, 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, 91, 0, 123, + 123, 123, 91, 91, 0, 0, 0, 0, 91, 91, 0, 0, 91, 91, 91, 0, 0, 0, 91, + 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, 91, 91, 15, 15, 15, 91, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 91, 91, 123, 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, 91, 15, 123, 123, 123, 91, + 91, 91, 91, 91, 0, 91, 91, 123, 0, 123, 123, 91, 0, 0, 15, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 91, 91, 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, + 0, 91, 123, 123, 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, 91, 15, 123, 91, 123, 91, 91, 91, 91, 0, + 0, 123, 123, 0, 0, 123, 123, 91, 0, 0, 0, 0, 0, 0, 0, 0, 91, 123, 0, + 0, 0, 0, 15, 15, 0, 15, 15, 15, 91, 91, 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, 91, 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, 123, 123, 91, 123, 123, 0, 0, 0, 123, 123, 123, 0, 123, + 123, 123, 91, 0, 0, 15, 0, 0, 0, 0, 0, 0, 123, 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, 91, 123, 123, 123, 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, 15, 15, 15, 15, 15, 15, + 0, 0, 0, 15, 91, 91, 91, 123, 123, 123, 123, 0, 91, 91, 91, 0, 91, + 91, 91, 91, 0, 0, 0, 0, 0, 0, 0, 91, 91, 0, 15, 15, 0, 0, 0, 0, 0, + 0, 15, 15, 91, 91, 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, 91, 123, 123, 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, 91, 15, 123, 91, 123, 123, 123, 123, 123, 0, 91, 123, 123, 0, 123, + 123, 91, 91, 0, 0, 0, 0, 0, 0, 0, 123, 123, 0, 0, 0, 0, 0, 0, 0, 15, + 0, 15, 15, 91, 91, 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, 123, 123, 123, 91, 91, 91, 91, 0, 123, 123, 123, + 0, 123, 123, 123, 91, 15, 0, 0, 0, 0, 0, 0, 0, 0, 123, 0, 0, 0, 0, + 0, 0, 0, 0, 15, 15, 91, 91, 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, 123, + 123, 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, - 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, + 15, 15, 15, 15, 15, 0, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 0, 0, + 0, 91, 0, 0, 0, 0, 123, 123, 123, 91, 91, 91, 0, 91, 0, 123, 123, 123, + 123, 123, 123, 123, 123, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, + 9, 9, 0, 0, 123, 123, 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, 91, 15, 15, 91, 91, + 91, 91, 91, 91, 91, 0, 0, 0, 0, 4, 15, 15, 15, 15, 15, 15, 90, 91, + 91, 91, 91, 91, 91, 91, 91, 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, 91, 15, 15, 91, + 91, 91, 91, 91, 91, 0, 91, 91, 15, 0, 0, 15, 15, 15, 15, 15, 0, 90, + 0, 91, 91, 91, 91, 91, 91, 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, 91, 91, 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, 91, + 14, 91, 14, 91, 5, 6, 5, 6, 123, 123, 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, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, + 91, 91, 91, 123, 91, 91, 91, 91, 91, 3, 91, 91, 15, 15, 15, 15, 15, + 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 0, 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, 0, 14, 14, + 14, 14, 14, 14, 14, 14, 91, 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, 123, 123, 91, 91, 91, 91, 123, 91, 91, 91, 91, + 91, 91, 123, 91, 91, 123, 123, 91, 91, 15, 9, 9, 9, 9, 9, 9, 9, 9, + 9, 9, 3, 3, 3, 3, 3, 3, 15, 15, 15, 15, 15, 15, 123, 123, 91, 91, 15, + 15, 15, 15, 91, 91, 91, 15, 123, 123, 123, 15, 15, 123, 123, 123, 123, + 123, 123, 123, 15, 15, 15, 91, 91, 91, 91, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 91, 123, 123, 91, 91, 123, 123, 123, 123, + 123, 123, 91, 15, 123, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 123, 123, 123, + 91, 14, 14, 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, + 124, 0, 0, 0, 0, 0, 124, 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, 90, 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, 91, 91, 91, 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, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 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, 125, 125, 125, 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, 91, 91, 91, 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, 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, + 15, 15, 15, 15, 15, 15, 15, 91, 91, 91, 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, 91, 91, 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, 91, 91, 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, 91, 91, 123, 91, 91, 91, 91, + 91, 91, 91, 123, 123, 123, 123, 123, 123, 123, 123, 91, 123, 123, 91, + 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 3, 3, 3, 90, 3, 3, 3, 4, 15, + 91, 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, 91, 91, 91, 17, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, + 0, 0, 0, 0, 15, 15, 15, 90, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, - 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 15, 0, 0, 0, 0, 0, + 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 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, 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, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 0, 91, 91, 91, 123, 123, 123, 123, 91, 91, 123, 123, + 123, 0, 0, 0, 0, 123, 123, 91, 123, 123, 123, 123, 123, 123, 91, 91, + 91, 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, 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, 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, 123, 123, 123, 123, 123, 123, 123, 123, + 123, 123, 123, 123, 123, 123, 123, 123, 123, 15, 15, 15, 15, 15, 15, + 15, 123, 123, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, 0, + 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 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, 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, 123, 123, 91, 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, 123, 91, 123, 91, 91, 91, 91, 91, 91, 91, 0, 91, 123, 91, 123, + 123, 91, 91, 91, 91, 91, 91, 91, 91, 123, 123, 123, 123, 123, 123, + 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 0, 0, 91, 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, 90, 3, 3, 3, 3, 3, 3, 0, 0, 91, 91, 91, + 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 118, 0, 91, 91, 91, 91, + 123, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 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, 123, 91, + 91, 91, 91, 91, 123, 91, 123, 123, 123, 123, 123, 91, 123, 123, 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, 91, 91, 91, + 91, 91, 91, 91, 91, 91, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, + 91, 91, 123, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 123, + 91, 91, 91, 91, 123, 123, 91, 91, 123, 91, 91, 91, 15, 15, 9, 9, 9, + 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 91, 123, 91, 91, 123, 123, 123, 91, 123, 91, 91, 91, 123, 123, 0, 0, + 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 15, 15, 15, 15, 123, 123, 123, 123, 123, + 123, 123, 123, 91, 91, 91, 91, 91, 91, 91, 91, 123, 123, 91, 91, 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, 90, 90, 90, 90, 90, 90, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 3, 0, 0, 0, 0, 0, 0, 0, 0, 91, 91, 91, 3, 91, 91, 91, 91, 91, 91, 91, + 91, 91, 91, 91, 91, 91, 123, 91, 91, 91, 91, 91, 91, 91, 15, 15, 15, + 15, 91, 15, 15, 15, 15, 123, 123, 91, 15, 15, 0, 91, 91, 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, 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, 90, 90, 90, 90, 90, 90, + 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, + 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, + 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, 90, + 90, 90, 90, 90, 90, 90, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 90, 126, 21, 21, 21, 127, 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, 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, 90, 90, 90, 90, 90, 91, 91, 91, 91, 91, 91, 91, 91, 91, + 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 0, 0, 0, 0, 0, + 0, 91, 91, 91, 91, 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, 128, 21, + 21, 129, 21, 130, 130, 130, 130, 130, 130, 130, 130, 131, 131, 131, + 131, 131, 131, 131, 131, 130, 130, 130, 130, 130, 130, 0, 0, 131, 131, + 131, 131, 131, 131, 0, 0, 130, 130, 130, 130, 130, 130, 130, 130, 131, + 131, 131, 131, 131, 131, 131, 131, 130, 130, 130, 130, 130, 130, 130, + 130, 131, 131, 131, 131, 131, 131, 131, 131, 130, 130, 130, 130, 130, + 130, 0, 0, 131, 131, 131, 131, 131, 131, 0, 0, 21, 130, 21, 130, 21, + 130, 21, 130, 0, 131, 0, 131, 0, 131, 0, 131, 130, 130, 130, 130, 130, + 130, 130, 130, 131, 131, 131, 131, 131, 131, 131, 131, 132, 132, 133, + 133, 133, 133, 134, 134, 135, 135, 136, 136, 137, 137, 0, 0, 130, 130, + 130, 130, 130, 130, 130, 130, 138, 138, 138, 138, 138, 138, 138, 138, + 130, 130, 130, 130, 130, 130, 130, 130, 138, 138, 138, 138, 138, 138, + 138, 138, 130, 130, 130, 130, 130, 130, 130, 130, 138, 138, 138, 138, + 138, 138, 138, 138, 130, 130, 21, 139, 21, 0, 21, 21, 131, 131, 140, + 140, 141, 11, 142, 11, 11, 11, 21, 139, 21, 0, 21, 21, 143, 143, 143, + 143, 141, 11, 11, 11, 130, 130, 21, 21, 0, 0, 21, 21, 131, 131, 144, + 144, 0, 11, 11, 11, 130, 130, 21, 21, 21, 112, 21, 21, 131, 131, 145, + 145, 116, 11, 11, 11, 0, 0, 21, 139, 21, 0, 21, 21, 146, 146, 147, + 147, 141, 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, 148, 149, 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, 90, 0, 0, + 18, 18, 18, 18, 18, 18, 7, 7, 7, 5, 6, 90, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 7, 7, 7, 5, 6, 0, 90, 90, 90, 90, 90, 90, 90, 90, 90, + 90, 90, 90, 90, 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, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 91, 91, 91, 91, 91, 91, 91, 91, 91, + 91, 91, 91, 91, 118, 118, 118, 118, 91, 118, 118, 118, 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, 14, 14, 106, 14, 14, 14, 14, 106, 14, 14, 21, 106, 106, + 106, 21, 21, 106, 106, 106, 21, 14, 106, 14, 14, 7, 106, 106, 106, + 106, 106, 14, 14, 14, 14, 14, 14, 106, 14, 150, 14, 106, 14, 151, 152, + 106, 106, 14, 21, 106, 106, 153, 106, 21, 15, 15, 15, 15, 21, 14, 14, + 21, 21, 106, 106, 7, 7, 7, 7, 7, 106, 21, 21, 21, 21, 14, 7, 14, 14, + 154, 14, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 155, 155, 155, 155, 155, 155, 155, 155, 155, 155, 155, 155, 155, + 155, 155, 155, 156, 156, 156, 156, 156, 156, 156, 156, 156, 156, 156, + 156, 156, 156, 156, 156, 125, 125, 125, 23, 24, 125, 125, 125, 125, + 18, 0, 0, 0, 0, 0, 0, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 7, 7, 14, + 14, 14, 14, 7, 14, 14, 7, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 14, 14, 7, - 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 14, 14, + 7, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 14, 14, - 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 5, 6, 5, 6, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 14, 14, 14, 14, 14, 14, 14, 5, 6, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, @@ -914,209 +918,222 @@ static const unsigned char groupMap[] = { 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, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 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, 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, 14, 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, + 14, 14, 14, 14, 14, 14, 14, 14, 157, 157, 157, 157, 157, 157, 157, + 157, 157, 157, 157, 157, 157, 157, 157, 157, 157, 157, 157, 157, 157, + 157, 157, 157, 157, 157, 158, 158, 158, 158, 158, 158, 158, 158, 158, + 158, 158, 158, 158, 158, 158, 158, 158, 158, 158, 158, 158, 158, 158, + 158, 158, 158, 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, 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, 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, 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, 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, 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, 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, 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, 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, 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, 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, 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, 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, 0, 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, + 14, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, + 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, + 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, + 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, + 121, 121, 121, 121, 121, 121, 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, 23, + 24, 159, 160, 161, 162, 163, 23, 24, 23, 24, 23, 24, 164, 165, 166, + 167, 21, 23, 24, 21, 23, 24, 21, 21, 21, 21, 21, 90, 90, 168, 168, + 23, 24, 23, 24, 21, 14, 14, 14, 14, 14, 14, 23, 24, 23, 24, 91, 91, + 91, 23, 24, 0, 0, 0, 0, 0, 3, 3, 3, 3, 18, 3, 3, 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, 0, 169, 0, 0, 0, 0, 0, 169, 0, 0, 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, + 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 90, 3, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 91, 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, 90, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 8, 8, 3, 3, 3, + 3, 8, 3, 5, 0, 0, 0, 0, 0, 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, 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, 90, 15, 125, 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, 125, 125, + 125, 125, 125, 125, 125, 125, 125, 91, 91, 91, 91, 123, 123, 8, 90, + 90, 90, 90, 90, 14, 14, 125, 125, 125, 90, 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, 3, 85, 85, 85, 15, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 0, 0, 91, 91, 11, 11, 90, 90, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 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, 3, 90, 90, 90, 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, 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, - 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, 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, 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, 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, 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, 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, 90, 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, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 90, 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, 91, 118, 118, 118, 3, 91, 91, 91, 91, 91, 91, 91, + 91, 91, 91, 3, 90, 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, 90, + 90, 0, 91, 15, 15, 15, 15, 15, 15, 125, 125, 125, 125, 125, 125, 125, + 125, 125, 125, 91, 91, 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, - 85, 85, 85, 85, 85, 85, 85, 85, 85, 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, + 11, 11, 11, 11, 11, 90, 90, 90, 90, 90, 90, 90, 90, 90, 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, 90, 21, 21, 21, 21, 21, + 21, 21, 21, 23, 24, 23, 24, 170, 23, 24, 23, 24, 23, 24, 23, 24, 23, + 24, 90, 11, 11, 23, 24, 171, 21, 0, 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, 172, 173, 174, 175, 0, 0, 176, 177, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 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, + 0, 0, 0, 0, 0, 15, 90, 90, 21, 15, 15, 15, 15, 15, 15, 15, 91, 15, + 15, 15, 91, 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, 123, 123, 91, + 91, 123, 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, 123, 123, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, + 123, 123, 123, 123, 91, 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, 91, 91, 91, 91, 91, 91, 91, 91, + 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 15, 15, 15, 15, 15, 15, 3, + 3, 3, 15, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 91, 91, 91, 91, 91, 91, + 91, 91, 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, 91, 91, 91, 91, 91, 91, 91, 91, + 91, 91, 91, 123, 123, 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, 91, 123, 123, 91, + 91, 91, 91, 123, 123, 91, 123, 123, 123, 123, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 3, 3, 3, 3, 0, 90, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, + 3, 3, 15, 15, 15, 15, 15, 91, 90, 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, 91, 91, 91, 91, 91, 91, 123, 123, 91, 91, 123, + 123, 91, 91, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 91, 15, 15, 15, + 15, 15, 15, 15, 15, 91, 123, 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, 90, 15, 15, 15, 15, 15, 15, 14, 14, 14, 15, 123, 91, 123, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 91, 15, 91, 91, 91, 15, 15, 91, 91, 15, 15, 15, 15, 15, 91, 91, + 15, 91, 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, 90, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 123, 91, 91, 123, 123, 3, 3, 15, 90, 90, 123, 91, 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, 21, 21, + 21, 21, 21, 21, 21, 21, 11, 90, 90, 90, 90, 0, 0, 0, 0, 21, 21, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 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, - 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, + 0, 0, 15, 15, 15, 123, 123, 91, 123, 123, 91, 123, 123, 3, 123, 91, + 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, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, + 0, 0, 0, 178, 178, 178, 178, 178, 178, 178, 178, 178, 178, 178, 178, + 178, 178, 178, 178, 178, 178, 178, 178, 178, 178, 178, 178, 178, 178, + 178, 178, 178, 178, 178, 178, 179, 179, 179, 179, 179, 179, 179, 179, + 179, 179, 179, 179, 179, 179, 179, 179, 179, 179, 179, 179, 179, 179, + 179, 179, 179, 179, 179, 179, 179, 179, 179, 179, 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, 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, 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, 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, 91, 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, 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, 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, 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, 15, 15, 15, 0, 0, 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, 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, 15, 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, 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 + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 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, 91, 91, 91, 91, 91, 91, + 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 3, 3, 3, 3, 3, 3, 3, 5, 6, + 3, 0, 0, 0, 0, 0, 0, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, + 91, 91, 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, 15, 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, 90, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 90, 90, 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,213 +1144,282 @@ 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, 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, 125, 125, + 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 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, 0, 0, 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, 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, - 15, 15, 15, 15, 15, 15, 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, 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, 91, 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, 91, 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, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 125, 15, 15, 15, 15, 15, 15, 15, 15, + 125, 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, 0, 15, 15, 0, 0, 0, 15, 0, 0, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 91, 91, 91, 91, 91, 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, 125, 125, 125, + 125, 125, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 180, 180, 180, 180, 180, 180, + 180, 180, 180, 180, 180, 180, 180, 180, 180, 180, 180, 180, 180, 180, + 180, 180, 180, 180, 180, 180, 180, 180, 180, 180, 180, 180, 180, 180, + 180, 180, 180, 180, 180, 180, 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, 181, 181, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 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, 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, 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, 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, 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, 0, 0, 0, 0, 0, 0, 15, 15, + 15, 91, 91, 91, 0, 91, 91, 0, 0, 0, 0, 0, 91, 91, 91, 91, 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, 91, 91, 91, 0, 0, 0, 0, 91, 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, - 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, 18, 18, 3, 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, 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, 91, 91, + 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, 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, + 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, 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, + 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, 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, 116, 86, 116, 15, + 18, 0, 123, 91, 123, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 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, 91, 91, 91, 91, + 91, 91, 91, 91, 91, 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, 91, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 123, 123, 123, 91, 91, 91, 91, 123, 123, 91, 91, 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, 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, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, + 0, 0, 0, 0, 91, 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, - 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, 91, 91, 91, 91, 91, 123, 91, 91, 91, + 91, 91, 91, 91, 91, 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, 15, 15, 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, 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, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 91, 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, - 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, - 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 123, 123, 123, 91, 91, 91, 91, 91, 91, 91, 91, 91, + 123, 123, 15, 15, 15, 15, 3, 3, 3, 3, 0, 0, 0, 0, 3, 0, 0, 9, 9, 9, + 9, 9, 9, 9, 9, 9, 9, 15, 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, 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, 123, 123, + 123, 91, 91, 91, 123, 123, 91, 123, 91, 91, 3, 3, 3, 3, 3, 3, 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, 91, 123, 123, + 123, 91, 91, 91, 91, 91, 91, 91, 91, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, + 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 91, 123, 123, 123, 123, 0, 0, 123, + 123, 0, 0, 123, 123, 123, 0, 0, 0, 0, 0, 0, 0, 0, 0, 123, 0, 0, 0, + 0, 0, 15, 15, 15, 15, 15, 123, 123, 0, 0, 91, 91, 91, 91, 91, 91, 91, + 0, 0, 0, 91, 91, 91, 91, 91, 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, 123, 123, 123, + 91, 91, 91, 91, 91, 91, 123, 91, 123, 123, 123, 123, 91, 91, 123, 91, + 91, 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, 123, 123, 123, 91, 91, 91, 91, 0, 0, 123, 123, 123, + 123, 91, 91, 123, 91, 91, 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, 0, 0, 0, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 123, 123, 123, 91, + 91, 91, 91, 91, 91, 91, 91, 123, 123, 91, 123, 91, 91, 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, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 91, 123, 91, + 123, 123, 91, 91, 91, 91, 91, 91, 123, 91, 0, 0, 0, 0, 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, 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, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, + 125, 125, 0, 3, 3, 3, 3, 3, 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, 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, 91, 91, 91, + 91, 91, 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, 91, 91, 91, 91, 91, 91, 91, 3, + 3, 3, 3, 3, 14, 14, 14, 14, 90, 90, 90, 90, 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, 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, - 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, 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, 14, 14, 14, 14, 14, 14, 14, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 15, 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, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 91, 91, 91, 91, 90, 90, 90, 90, 90, 90, 90, 90, 90, + 90, 90, 90, 90, 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, 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, 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, + 91, 91, 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, 14, 123, 123, 91, 91, 91, + 14, 14, 14, 123, 123, 123, 123, 123, 123, 17, 17, 17, 17, 17, 17, 17, + 17, 91, 91, 91, 91, 91, 91, 91, 91, 14, 14, 91, 91, 91, 91, 91, 91, + 91, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 91, 91, 91, + 91, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 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, - 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, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, + 14, 91, 91, 91, 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, 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, 106, 106, + 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, + 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 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, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, + 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, + 106, 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, 106, 106, 106, 106, 106, 106, + 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, + 106, 106, 106, 106, 106, 106, 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, 106, + 0, 106, 106, 0, 0, 106, 0, 0, 106, 106, 0, 0, 106, 106, 106, 106, 0, + 106, 106, 106, 106, 106, 106, 106, 106, 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, 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, + 21, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, + 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 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, 21, 21, 106, 106, 0, 106, 106, 106, 106, 0, + 0, 106, 106, 106, 106, 106, 106, 106, 106, 0, 106, 106, 106, 106, 106, + 106, 106, 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, 106, 106, 0, 106, 106, + 106, 106, 0, 106, 106, 106, 106, 106, 0, 106, 0, 0, 0, 106, 106, 106, + 106, 106, 106, 106, 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, 106, 106, + 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, + 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 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, 21, 21, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, + 106, 106, 106, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 106, 106, 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, 106, + 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, + 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 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, 106, 106, 106, 106, 106, 106, 106, 106, 106, + 106, 106, 106, 106, 106, 106, 106, 21, 21, 21, 21, 21, 21, 0, 0, 106, + 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, + 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 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, 7, 21, 21, 21, 21, 21, 21, 106, 106, 106, 106, 106, + 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, + 106, 106, 106, 106, 106, 106, 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, 106, 106, 106, 106, 106, 106, 106, 106, 106, + 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, + 106, 106, 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, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, + 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 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, 7, 21, 21, 21, 21, 21, 21, 106, 106, 106, + 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, + 106, 106, 106, 106, 106, 106, 106, 106, 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, 21, 0, 0, 9, 9, 9, 9, 9, 9, + 21, 21, 7, 21, 21, 21, 21, 21, 21, 106, 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, 15, + 15, 15, 15, 15, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 91, 91, 91, + 91, 91, 91, 91, 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, 15, 15, 15, 0, 15, 0, 15, + 0, 0, 0, 0, 0, 0, 15, 0, 0, 0, 0, 15, 0, 15, 0, 15, 0, 15, 15, 15, + 0, 15, 15, 0, 15, 0, 0, 15, 0, 15, 0, 15, 0, 15, 0, 15, 0, 15, 15, + 0, 15, 0, 0, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, + 15, 15, 15, 0, 15, 15, 15, 15, 0, 15, 0, 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, 0, 15, 15, - 0, 15, 0, 0, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, - 15, 15, 15, 0, 15, 0, 15, 0, 0, 0, 0, 0, 0, 15, 0, 0, 0, 0, 15, 0, - 15, 0, 15, 0, 15, 15, 15, 0, 15, 15, 0, 15, 0, 0, 15, 0, 15, 0, 15, - 0, 15, 0, 15, 0, 15, 15, 0, 15, 0, 0, 15, 15, 15, 15, 0, 15, 15, 15, - 15, 15, 15, 15, 0, 15, 15, 15, 15, 0, 15, 15, 15, 15, 0, 15, 0, 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, 0, 0, 0, 0, 0, 15, 15, 15, - 0, 15, 15, 15, 15, 15, 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, 7, 7, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 14, 14, 14, + 15, 15, 15, 15, 0, 0, 0, 0, 0, 15, 15, 15, 0, 15, 15, 15, 15, 15, 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, 7, 7, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 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, 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, 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, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 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, 14, 14, + 14, 14, 14, 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, 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, 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, + 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 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, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, + 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 0, 14, 14, 14, 14, 14, 14, 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, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 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 + 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 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, 0, 0, 0, 0, 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, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 #endif /* TCL_UTF_MAX > 3 */ }; @@ -1361,11 +1447,12 @@ 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, + -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, -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, 10, -9044862, -976254, 15234, -1949375, -1918, -1983, -18814, -21886, -25470, -32638, -28542, -32126, -1981, -2174, -18879, @@ -1373,7 +1460,8 @@ static const int groups[] = { -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 + -10833599, -10832575, -10830015, -10817983, -10824127, 18, 17, + 10305, 10370 }; #if TCL_UTF_MAX > 3 diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 4b5b37b..15529c7 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -1106,6 +1106,46 @@ Tcl_UtfNcasecmp( /* *---------------------------------------------------------------------- * + * Tcl_UtfNcasecmp -- + * + * Compare UTF chars of string cs to string ct case insensitively. + * Replacement for strcasecmp in Tcl core, in places where UTF-8 should + * be handled. + * + * Results: + * Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclUtfCasecmp( + const char *cs, /* UTF string to compare to ct. */ + const char *ct) /* UTF string cs is compared to. */ +{ + while (*cs && *ct) { + Tcl_UniChar ch1, ch2; + + cs += TclUtfToUniChar(cs, &ch1); + ct += TclUtfToUniChar(ct, &ch2); + if (ch1 != ch2) { + ch1 = Tcl_UniCharToLower(ch1); + ch2 = Tcl_UniCharToLower(ch2); + if (ch1 != ch2) { + return ch1 - ch2; + } + } + } + return UCHAR(*cs) - UCHAR(*ct); +} + + +/* + *---------------------------------------------------------------------- + * * Tcl_UniCharToUpper -- * * Compute the uppercase equivalent of the given Unicode character. @@ -1515,9 +1555,10 @@ Tcl_UniCharIsSpace( */ if (((Tcl_UniChar) ch) < ((Tcl_UniChar) 0x80)) { - return isspace(UCHAR(ch)); /* INTL: ISO space */ - } else if ((Tcl_UniChar) ch == 0x0085 || (Tcl_UniChar) ch == 0x200b - || (Tcl_UniChar) ch == 0x2060 || (Tcl_UniChar) ch == 0xfeff) { + return TclIsSpaceProc((char) ch); + } else if ((Tcl_UniChar) ch == 0x0085 || (Tcl_UniChar) ch == 0x180e + || (Tcl_UniChar) ch == 0x200b || (Tcl_UniChar) ch == 0x2060 + || (Tcl_UniChar) ch == 0x202f || (Tcl_UniChar) ch == 0xfeff) { return 1; } else { return ((SPACE_BITS >> GetCategory(ch)) & 1); diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 27e2474..ae3adae 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> /* @@ -110,7 +111,11 @@ 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 @@ -236,7 +241,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 @@ -504,9 +509,70 @@ TclFindElement( * does not/does require a call to * TclCopyAndCollapse() by the caller. */ { - const char *p = list; + 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 = 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 +582,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 +647,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 +716,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 +729,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; @@ -1768,8 +1834,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( @@ -1825,7 +1890,8 @@ Tcl_Concat( * Trim away the leading whitespace. */ - trim = TclTrimLeft(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); + trim = TclTrimLeft(element, elemLength, CONCAT_TRIM_SET, + CONCAT_WS_SIZE); element += trim; elemLength -= trim; @@ -1834,7 +1900,8 @@ Tcl_Concat( * a final backslash character. */ - trim = TclTrimRight(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); + trim = TclTrimRight(element, elemLength, CONCAT_TRIM_SET, + CONCAT_WS_SIZE); trim -= trim && (element[elemLength - trim - 1] == '\\'); elemLength -= trim; @@ -1959,7 +2026,8 @@ Tcl_ConcatObj( * Trim away the leading whitespace. */ - trim = TclTrimLeft(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); + trim = TclTrimLeft(element, elemLength, CONCAT_TRIM_SET, + CONCAT_WS_SIZE); element += trim; elemLength -= trim; @@ -1968,7 +2036,8 @@ Tcl_ConcatObj( * a final backslash character. */ - trim = TclTrimRight(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); + trim = TclTrimRight(element, elemLength, CONCAT_TRIM_SET, + CONCAT_WS_SIZE); trim -= trim && (element[elemLength - trim - 1] == '\\'); elemLength -= trim; @@ -3580,10 +3649,9 @@ UpdateStringOfEndOffset( register Tcl_Obj *objPtr) { char buffer[TCL_INTEGER_SPACE + 5]; - register int len; + register int len = 3; memcpy(buffer, "end", 4); - len = sizeof("end") - 1; if (objPtr->internalRep.longValue != 0) { buffer[len++] = '-'; len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue)); diff --git a/generic/tclVar.c b/generic/tclVar.c index 9b8527c..5e3157e 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -144,6 +144,30 @@ static const char *isArrayElement = #define HasLocalVars(framePtr) ((framePtr)->isProcCallFrame & FRAME_IS_PROC) /* + * The following structure describes an enumerative search in progress on an + * array variable; this are invoked with options to the "array" command. + */ + +typedef struct ArraySearch { + int id; /* Integer id used to distinguish among + * multiple concurrent searches for the same + * array. */ + struct Var *varPtr; /* Pointer to array variable that's being + * searched. */ + Tcl_HashSearch search; /* Info kept by the hash module about progress + * through the array. */ + Tcl_HashEntry *nextEntry; /* Non-null means this is the next element to + * be enumerated (it's leftover from the + * Tcl_FirstHashEntry call or from an "array + * anymore" command). NULL means must call + * Tcl_NextHashEntry to get value to + * return. */ + struct ArraySearch *nextPtr;/* Next in list of all active searches for + * this variable, or NULL if this is the last + * one. */ +} ArraySearch; + +/* * Forward references to functions defined later in this file: */ @@ -475,6 +499,9 @@ TclObjLookupVar( if (part2) { part2Ptr = Tcl_NewStringObj(part2, -1); + if (createPart2) { + Tcl_IncrRefCount(part2Ptr); + } } resPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, @@ -487,6 +514,12 @@ TclObjLookupVar( return resPtr; } +/* + * When createPart1 is 1, callers must IncrRefCount part1Ptr if they + * plan to DecrRefCount it. + * When createPart2 is 1, callers must IncrRefCount part2Ptr if they + * plan to DecrRefCount it. + */ Var * TclObjLookupVarEx( Tcl_Interp *interp, /* Interpreter to use for lookup. */ @@ -627,7 +660,9 @@ TclObjLookupVarEx( part2 = newPart2 = part1Ptr->internalRep.twoPtrValue.ptr2; if (newPart2) { part2Ptr = Tcl_NewStringObj(newPart2, -1); - Tcl_IncrRefCount(part2Ptr); + if (createPart2) { + Tcl_IncrRefCount(part2Ptr); + } } part1Ptr = part1Ptr->internalRep.twoPtrValue.ptr1; typePtr = part1Ptr->typePtr; @@ -673,7 +708,9 @@ TclObjLookupVarEx( *(newPart2+len2) = '\0'; part2 = newPart2; part2Ptr = Tcl_NewStringObj(newPart2, -1); - Tcl_IncrRefCount(part2Ptr); + if (createPart2) { + Tcl_IncrRefCount(part2Ptr); + } /* * Free the internal rep of the original part1Ptr, now renamed @@ -1083,6 +1120,8 @@ TclLookupSimpleVar( * The variable at arrayPtr may be converted to be an array if * createPart1 is 1. A new hashtable entry may be created if createPart2 * is 1. + * When createElem is 1, callers must incr elNamePtr if they plan + * to decr it. * *---------------------------------------------------------------------- */ @@ -1208,6 +1247,7 @@ TclLookupArrayElement( *---------------------------------------------------------------------- */ +#undef Tcl_GetVar const char * Tcl_GetVar( Tcl_Interp *interp, /* Command interpreter in which varName is to @@ -1217,11 +1257,9 @@ Tcl_GetVar( * TCL_NAMESPACE_ONLY or TCL_LEAVE_ERR_MSG * bits. */ { - Tcl_Obj *varNamePtr, *resultPtr; + Tcl_Obj *varNamePtr = Tcl_NewStringObj(varName, -1); + Tcl_Obj *resultPtr = Tcl_ObjGetVar2(interp, varNamePtr, NULL, flags); - varNamePtr = Tcl_NewStringObj(varName, -1); - Tcl_IncrRefCount(varNamePtr); - resultPtr = Tcl_ObjGetVar2(interp, varNamePtr, NULL, flags); TclDecrRefCount(varNamePtr); if (resultPtr == NULL) { @@ -1265,15 +1303,12 @@ Tcl_GetVar2( * TCL_NAMESPACE_ONLY and TCL_LEAVE_ERR_MSG * * bits. */ { - Tcl_Obj *resultPtr, *part1Ptr, *part2Ptr; + Tcl_Obj *resultPtr; + Tcl_Obj *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, -1); - part1Ptr = Tcl_NewStringObj(part1, -1); - Tcl_IncrRefCount(part1Ptr); if (part2) { part2Ptr = Tcl_NewStringObj(part2, -1); Tcl_IncrRefCount(part2Ptr); - } else { - part2Ptr = NULL; } resultPtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags); @@ -1326,6 +1361,7 @@ Tcl_GetVar2Ex( if (part2) { part2Ptr = Tcl_NewStringObj(part2, -1); + Tcl_IncrRefCount(part2Ptr); } resPtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags); @@ -1358,6 +1394,8 @@ Tcl_GetVar2Ex( * the returned reference; if you want to keep a reference to the object * you must increment its ref count yourself. * + * Callers must incr part2Ptr if they plan to decr it. + * *---------------------------------------------------------------------- */ @@ -1552,6 +1590,7 @@ Tcl_SetObjCmd( *---------------------------------------------------------------------- */ +#undef Tcl_SetVar const char * Tcl_SetVar( Tcl_Interp *interp, /* Command interpreter in which varName is to @@ -1563,17 +1602,13 @@ Tcl_SetVar( * TCL_APPEND_VALUE, TCL_LIST_ELEMENT, * TCL_LEAVE_ERR_MSG. */ { - Tcl_Obj *valuePtr, *varNamePtr, *varValuePtr; + Tcl_Obj *varValuePtr, *varNamePtr = Tcl_NewStringObj(varName, -1); - varNamePtr = Tcl_NewStringObj(varName, -1); Tcl_IncrRefCount(varNamePtr); - valuePtr = Tcl_NewStringObj(newValue, -1); - Tcl_IncrRefCount(valuePtr); - - varValuePtr = Tcl_ObjSetVar2(interp, varNamePtr, NULL, valuePtr, flags); - + varValuePtr = Tcl_ObjSetVar2(interp, varNamePtr, NULL, + Tcl_NewStringObj(newValue, -1), flags); Tcl_DecrRefCount(varNamePtr); - Tcl_DecrRefCount(valuePtr); + if (varValuePtr == NULL) { return NULL; } @@ -1721,6 +1756,7 @@ Tcl_SetVar2Ex( * The value of the given variable is set. If either the array or the * entry didn't exist then a new variable is created. * Callers must Incr part1Ptr if they plan to Decr it. + * Callers must Incr part2Ptr if they plan to Decr it. * *---------------------------------------------------------------------- */ @@ -1922,6 +1958,9 @@ TclPtrSetVar( Tcl_IncrRefCount(oldValuePtr); /* Since var is ref */ } Tcl_AppendObjToObj(oldValuePtr, newValuePtr); + if (newValuePtr->refCount == 0) { + Tcl_DecrRefCount(newValuePtr); + } } } } else if (newValuePtr != oldValuePtr) { @@ -2011,6 +2050,7 @@ TclPtrSetVar( * incremented to reflect the returned reference; if you want to keep a * reference to the object you must increment its ref count yourself. * Callers must Incr part1Ptr if they plan to Decr it. + * Callers must Incr part2Ptr if they plan to Decr it. * *---------------------------------------------------------------------- */ @@ -2036,8 +2076,8 @@ TclIncrObjVar2( varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, flags, "read", 1, 1, &arrayPtr); if (varPtr == NULL) { - Tcl_AddObjErrorInfo(interp, - "\n (reading value of variable to increment)", -1); + Tcl_AddErrorInfo(interp, + "\n (reading value of variable to increment)"); return NULL; } return TclPtrIncrObjVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, @@ -2156,6 +2196,7 @@ TclPtrIncrObjVar( *---------------------------------------------------------------------- */ +#undef Tcl_UnsetVar int Tcl_UnsetVar( Tcl_Interp *interp, /* Command interpreter in which varName is to @@ -3812,6 +3853,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 @@ -4515,6 +4603,7 @@ TclPtrObjMakeUpvar( *---------------------------------------------------------------------- */ +#undef Tcl_UpVar int Tcl_UpVar( Tcl_Interp *interp, /* Command interpreter in which varName is to @@ -5108,7 +5197,8 @@ ParseSearchId( * Parse the id. */ - if (Tcl_ConvertToType(interp, handleObj, &tclArraySearchType) != TCL_OK) { + if ((handleObj->typePtr != &tclArraySearchType) + && (SetArraySearchObj(interp, handleObj) != TCL_OK)) { return NULL; } diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 47091de..4ccda3b 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -643,7 +643,6 @@ Tcl_ZlibStreamInit( int e; ZlibStreamHandle *zshPtr = NULL; Tcl_DString cmdname; - Tcl_CmdInfo cmdinfo; GzipHeader *gzHeaderPtr = NULL; switch (mode) { @@ -769,8 +768,8 @@ Tcl_ZlibStreamInit( 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); @@ -2994,47 +2993,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 +3022,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 @@ -3111,7 +3075,7 @@ ZlibTransformOutput( e = deflate(&cd->outStream, Z_NO_FLUSH); produced = cd->outAllocated - cd->outStream.avail_out; - if (e == Z_OK && cd->outStream.avail_out > 0) { + if (e == Z_OK && produced > 0) { if (Tcl_WriteRaw(cd->parent, cd->outBuffer, produced) < 0) { *errorCodePtr = Tcl_GetErrno(); return -1; @@ -3891,8 +3855,10 @@ Tcl_ZlibStreamInit( Tcl_Obj *dictObj, Tcl_ZlibStream *zshandle) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1)); - Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL); + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1)); + Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL); + } return TCL_ERROR; } @@ -3957,8 +3923,10 @@ Tcl_ZlibDeflate( int level, Tcl_Obj *gzipHeaderDictObj) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1)); - Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL); + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1)); + Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL); + } return TCL_ERROR; } @@ -3970,8 +3938,10 @@ Tcl_ZlibInflate( int bufferSize, Tcl_Obj *gzipHeaderDictObj) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1)); - Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL); + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1)); + Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL); + } return TCL_ERROR; } |